File Coverage

blib/lib/Elatin7.pm
Criterion Covered Total %
statement 83 3085 2.6
branch 4 2674 0.1
condition 1 373 0.2
subroutine 36 125 28.8
pod 7 74 9.4
total 131 6331 2.0


line stmt bran cond sub pod time code
1             package Elatin7;
2             ######################################################################
3             #
4             # Elatin7 - Run-time routines for Latin7.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin7/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
9             ######################################################################
10              
11 200     200   6270 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         642  
  200         13339  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   16201 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1247  
  200         373  
  200         36100  
27             $VERSION = '1.05';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1373 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         317 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         30734 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   15404 CORE::eval q{
  200     200   1278  
  200     63   364  
  200         31966  
  63         10962  
  72         21195  
  57         10920  
  79         15240  
  68         13045  
  61         11674  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       132734 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
  0         0  
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
  0         0  
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65             BEGIN {
66 200     200   694 my $genpkg = "Symbol::";
67 200         10425 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Elatin7::index($name, '::') == -1) && (Elatin7::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   490 if (CORE::eval { local $@; CORE::require strict }) {
  200         374  
  200         2274  
115 200         28967 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   17975 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1306  
  200         330  
  200         14024  
145 200     200   15523 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1141  
  200         325  
  200         13877  
146 200     200   14278 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   1355  
  200         301  
  200         15892  
147              
148             #
149             # Latin-7 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   14814 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   1143  
  200         326  
  200         442021  
157              
158             #
159             # Latin-7 case conversion
160             #
161             my %lc = ();
162             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
163             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
164             my %uc = ();
165             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
166             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
167             my %fc = ();
168             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
169             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
170              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Elatin7 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-13 | iec[- ]?8859-13 | latin-?7 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA8" => "\xB8", # LATIN LETTER O WITH STROKE
183             "\xAA" => "\xBA", # LATIN LETTER R WITH CEDILLA
184             "\xAF" => "\xBF", # LATIN LETTER AE
185             "\xC0" => "\xE0", # LATIN LETTER A WITH OGONEK
186             "\xC1" => "\xE1", # LATIN LETTER I WITH OGONEK
187             "\xC2" => "\xE2", # LATIN LETTER A WITH MACRON
188             "\xC3" => "\xE3", # LATIN LETTER C WITH ACUTE
189             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
190             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
191             "\xC6" => "\xE6", # LATIN LETTER E WITH OGONEK
192             "\xC7" => "\xE7", # LATIN LETTER E WITH MACRON
193             "\xC8" => "\xE8", # LATIN LETTER C WITH CARON
194             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
195             "\xCA" => "\xEA", # LATIN LETTER Z WITH ACUTE
196             "\xCB" => "\xEB", # LATIN LETTER E WITH DOT ABOVE
197             "\xCC" => "\xEC", # LATIN LETTER G WITH CEDILLA
198             "\xCD" => "\xED", # LATIN LETTER K WITH CEDILLA
199             "\xCE" => "\xEE", # LATIN LETTER I WITH MACRON
200             "\xCF" => "\xEF", # LATIN LETTER L WITH CEDILLA
201             "\xD0" => "\xF0", # LATIN LETTER S WITH CARON
202             "\xD1" => "\xF1", # LATIN LETTER N WITH ACUTE
203             "\xD2" => "\xF2", # LATIN LETTER N WITH CEDILLA
204             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
205             "\xD4" => "\xF4", # LATIN LETTER O WITH MACRON
206             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
207             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
208             "\xD8" => "\xF8", # LATIN LETTER U WITH OGONEK
209             "\xD9" => "\xF9", # LATIN LETTER L WITH STROKE
210             "\xDA" => "\xFA", # LATIN LETTER S WITH ACUTE
211             "\xDB" => "\xFB", # LATIN LETTER U WITH MACRON
212             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
213             "\xDD" => "\xFD", # LATIN LETTER Z WITH DOT ABOVE
214             "\xDE" => "\xFE", # LATIN LETTER Z WITH CARON
215             );
216              
217             %uc = (%uc,
218             "\xB8" => "\xA8", # LATIN LETTER O WITH STROKE
219             "\xBA" => "\xAA", # LATIN LETTER R WITH CEDILLA
220             "\xBF" => "\xAF", # LATIN LETTER AE
221             "\xE0" => "\xC0", # LATIN LETTER A WITH OGONEK
222             "\xE1" => "\xC1", # LATIN LETTER I WITH OGONEK
223             "\xE2" => "\xC2", # LATIN LETTER A WITH MACRON
224             "\xE3" => "\xC3", # LATIN LETTER C WITH ACUTE
225             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
226             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
227             "\xE6" => "\xC6", # LATIN LETTER E WITH OGONEK
228             "\xE7" => "\xC7", # LATIN LETTER E WITH MACRON
229             "\xE8" => "\xC8", # LATIN LETTER C WITH CARON
230             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
231             "\xEA" => "\xCA", # LATIN LETTER Z WITH ACUTE
232             "\xEB" => "\xCB", # LATIN LETTER E WITH DOT ABOVE
233             "\xEC" => "\xCC", # LATIN LETTER G WITH CEDILLA
234             "\xED" => "\xCD", # LATIN LETTER K WITH CEDILLA
235             "\xEE" => "\xCE", # LATIN LETTER I WITH MACRON
236             "\xEF" => "\xCF", # LATIN LETTER L WITH CEDILLA
237             "\xF0" => "\xD0", # LATIN LETTER S WITH CARON
238             "\xF1" => "\xD1", # LATIN LETTER N WITH ACUTE
239             "\xF2" => "\xD2", # LATIN LETTER N WITH CEDILLA
240             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
241             "\xF4" => "\xD4", # LATIN LETTER O WITH MACRON
242             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
243             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
244             "\xF8" => "\xD8", # LATIN LETTER U WITH OGONEK
245             "\xF9" => "\xD9", # LATIN LETTER L WITH STROKE
246             "\xFA" => "\xDA", # LATIN LETTER S WITH ACUTE
247             "\xFB" => "\xDB", # LATIN LETTER U WITH MACRON
248             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
249             "\xFD" => "\xDD", # LATIN LETTER Z WITH DOT ABOVE
250             "\xFE" => "\xDE", # LATIN LETTER Z WITH CARON
251             );
252              
253             %fc = (%fc,
254             "\xA8" => "\xB8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
255             "\xAA" => "\xBA", # LATIN CAPITAL LETTER R WITH CEDILLA --> LATIN SMALL LETTER R WITH CEDILLA
256             "\xAF" => "\xBF", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
257             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH OGONEK --> LATIN SMALL LETTER A WITH OGONEK
258             "\xC1" => "\xE1", # LATIN CAPITAL LETTER I WITH OGONEK --> LATIN SMALL LETTER I WITH OGONEK
259             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH MACRON --> LATIN SMALL LETTER A WITH MACRON
260             "\xC3" => "\xE3", # LATIN CAPITAL LETTER C WITH ACUTE --> LATIN SMALL LETTER C WITH ACUTE
261             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
262             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
263             "\xC6" => "\xE6", # LATIN CAPITAL LETTER E WITH OGONEK --> LATIN SMALL LETTER E WITH OGONEK
264             "\xC7" => "\xE7", # LATIN CAPITAL LETTER E WITH MACRON --> LATIN SMALL LETTER E WITH MACRON
265             "\xC8" => "\xE8", # LATIN CAPITAL LETTER C WITH CARON --> LATIN SMALL LETTER C WITH CARON
266             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
267             "\xCA" => "\xEA", # LATIN CAPITAL LETTER Z WITH ACUTE --> LATIN SMALL LETTER Z WITH ACUTE
268             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DOT ABOVE --> LATIN SMALL LETTER E WITH DOT ABOVE
269             "\xCC" => "\xEC", # LATIN CAPITAL LETTER G WITH CEDILLA --> LATIN SMALL LETTER G WITH CEDILLA
270             "\xCD" => "\xED", # LATIN CAPITAL LETTER K WITH CEDILLA --> LATIN SMALL LETTER K WITH CEDILLA
271             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH MACRON --> LATIN SMALL LETTER I WITH MACRON
272             "\xCF" => "\xEF", # LATIN CAPITAL LETTER L WITH CEDILLA --> LATIN SMALL LETTER L WITH CEDILLA
273             "\xD0" => "\xF0", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
274             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH ACUTE --> LATIN SMALL LETTER N WITH ACUTE
275             "\xD2" => "\xF2", # LATIN CAPITAL LETTER N WITH CEDILLA --> LATIN SMALL LETTER N WITH CEDILLA
276             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
277             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH MACRON --> LATIN SMALL LETTER O WITH MACRON
278             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
279             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
280             "\xD8" => "\xF8", # LATIN CAPITAL LETTER U WITH OGONEK --> LATIN SMALL LETTER U WITH OGONEK
281             "\xD9" => "\xF9", # LATIN CAPITAL LETTER L WITH STROKE --> LATIN SMALL LETTER L WITH STROKE
282             "\xDA" => "\xFA", # LATIN CAPITAL LETTER S WITH ACUTE --> LATIN SMALL LETTER S WITH ACUTE
283             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH MACRON --> LATIN SMALL LETTER U WITH MACRON
284             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
285             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Z WITH DOT ABOVE --> LATIN SMALL LETTER Z WITH DOT ABOVE
286             "\xDE" => "\xFE", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
287             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
288             );
289             }
290              
291             else {
292             croak "Don't know my package name '@{[__PACKAGE__]}'";
293             }
294              
295             #
296             # @ARGV wildcard globbing
297             #
298             sub import {
299              
300 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
301 0         0 my @argv = ();
302 0         0 for (@ARGV) {
303              
304             # has space
305 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
306 0 0       0 if (my @glob = Elatin7::glob(qq{"$_"})) {
307 0         0 push @argv, @glob;
308             }
309             else {
310 0         0 push @argv, $_;
311             }
312             }
313              
314             # has wildcard metachar
315             elsif (/\A (?:$q_char)*? [*?] /oxms) {
316 0 0       0 if (my @glob = Elatin7::glob($_)) {
317 0         0 push @argv, @glob;
318             }
319             else {
320 0         0 push @argv, $_;
321             }
322             }
323              
324             # no wildcard globbing
325             else {
326 0         0 push @argv, $_;
327             }
328             }
329 0         0 @ARGV = @argv;
330             }
331              
332 0         0 *Char::ord = \&Latin7::ord;
333 0         0 *Char::ord_ = \&Latin7::ord_;
334 0         0 *Char::reverse = \&Latin7::reverse;
335 0         0 *Char::getc = \&Latin7::getc;
336 0         0 *Char::length = \&Latin7::length;
337 0         0 *Char::substr = \&Latin7::substr;
338 0         0 *Char::index = \&Latin7::index;
339 0         0 *Char::rindex = \&Latin7::rindex;
340 0         0 *Char::eval = \&Latin7::eval;
341 0         0 *Char::escape = \&Latin7::escape;
342 0         0 *Char::escape_token = \&Latin7::escape_token;
343 0         0 *Char::escape_script = \&Latin7::escape_script;
344             }
345              
346             # P.230 Care with Prototypes
347             # in Chapter 6: Subroutines
348             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
349             #
350             # If you aren't careful, you can get yourself into trouble with prototypes.
351             # But if you are careful, you can do a lot of neat things with them. This is
352             # all very powerful, of course, and should only be used in moderation to make
353             # the world a better place.
354              
355             # P.332 Care with Prototypes
356             # in Chapter 7: Subroutines
357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
358             #
359             # If you aren't careful, you can get yourself into trouble with prototypes.
360             # But if you are careful, you can do a lot of neat things with them. This is
361             # all very powerful, of course, and should only be used in moderation to make
362             # the world a better place.
363              
364             #
365             # Prototypes of subroutines
366             #
367 0     0   0 sub unimport {}
368             sub Elatin7::split(;$$$);
369             sub Elatin7::tr($$$$;$);
370             sub Elatin7::chop(@);
371             sub Elatin7::index($$;$);
372             sub Elatin7::rindex($$;$);
373             sub Elatin7::lcfirst(@);
374             sub Elatin7::lcfirst_();
375             sub Elatin7::lc(@);
376             sub Elatin7::lc_();
377             sub Elatin7::ucfirst(@);
378             sub Elatin7::ucfirst_();
379             sub Elatin7::uc(@);
380             sub Elatin7::uc_();
381             sub Elatin7::fc(@);
382             sub Elatin7::fc_();
383             sub Elatin7::ignorecase;
384             sub Elatin7::classic_character_class;
385             sub Elatin7::capture;
386             sub Elatin7::chr(;$);
387             sub Elatin7::chr_();
388             sub Elatin7::glob($);
389             sub Elatin7::glob_();
390              
391             sub Latin7::ord(;$);
392             sub Latin7::ord_();
393             sub Latin7::reverse(@);
394             sub Latin7::getc(;*@);
395             sub Latin7::length(;$);
396             sub Latin7::substr($$;$$);
397             sub Latin7::index($$;$);
398             sub Latin7::rindex($$;$);
399             sub Latin7::escape(;$);
400              
401             #
402             # Regexp work
403             #
404 200     200   20252 BEGIN { CORE::eval q{ use vars qw(
  200     200   1597  
  200         385  
  200         91256  
405             $Latin7::re_a
406             $Latin7::re_t
407             $Latin7::re_n
408             $Latin7::re_r
409             ) } }
410              
411             #
412             # Character class
413             #
414 200     200   19256 BEGIN { CORE::eval q{ use vars qw(
  200     200   1221  
  200         350  
  200         3241747  
415             $dot
416             $dot_s
417             $eD
418             $eS
419             $eW
420             $eH
421             $eV
422             $eR
423             $eN
424             $not_alnum
425             $not_alpha
426             $not_ascii
427             $not_blank
428             $not_cntrl
429             $not_digit
430             $not_graph
431             $not_lower
432             $not_lower_i
433             $not_print
434             $not_punct
435             $not_space
436             $not_upper
437             $not_upper_i
438             $not_word
439             $not_xdigit
440             $eb
441             $eB
442             ) } }
443              
444             ${Elatin7::dot} = qr{(?>[^\x0A])};
445             ${Elatin7::dot_s} = qr{(?>[\x00-\xFF])};
446             ${Elatin7::eD} = qr{(?>[^0-9])};
447              
448             # Vertical tabs are now whitespace
449             # \s in a regex now matches a vertical tab in all circumstances.
450             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
451             # ${Elatin7::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
452             # ${Elatin7::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
453             ${Elatin7::eS} = qr{(?>[^\s])};
454              
455             ${Elatin7::eW} = qr{(?>[^0-9A-Z_a-z])};
456             ${Elatin7::eH} = qr{(?>[^\x09\x20])};
457             ${Elatin7::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
458             ${Elatin7::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
459             ${Elatin7::eN} = qr{(?>[^\x0A])};
460             ${Elatin7::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
461             ${Elatin7::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
462             ${Elatin7::not_ascii} = qr{(?>[^\x00-\x7F])};
463             ${Elatin7::not_blank} = qr{(?>[^\x09\x20])};
464             ${Elatin7::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
465             ${Elatin7::not_digit} = qr{(?>[^\x30-\x39])};
466             ${Elatin7::not_graph} = qr{(?>[^\x21-\x7F])};
467             ${Elatin7::not_lower} = qr{(?>[^\x61-\x7A])};
468             ${Elatin7::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
469             # ${Elatin7::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
470             ${Elatin7::not_print} = qr{(?>[^\x20-\x7F])};
471             ${Elatin7::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
472             ${Elatin7::not_space} = qr{(?>[^\s\x0B])};
473             ${Elatin7::not_upper} = qr{(?>[^\x41-\x5A])};
474             ${Elatin7::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
475             # ${Elatin7::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
476             ${Elatin7::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
477             ${Elatin7::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
478             ${Elatin7::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
479             ${Elatin7::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
480              
481             # avoid: Name "Elatin7::foo" used only once: possible typo at here.
482             ${Elatin7::dot} = ${Elatin7::dot};
483             ${Elatin7::dot_s} = ${Elatin7::dot_s};
484             ${Elatin7::eD} = ${Elatin7::eD};
485             ${Elatin7::eS} = ${Elatin7::eS};
486             ${Elatin7::eW} = ${Elatin7::eW};
487             ${Elatin7::eH} = ${Elatin7::eH};
488             ${Elatin7::eV} = ${Elatin7::eV};
489             ${Elatin7::eR} = ${Elatin7::eR};
490             ${Elatin7::eN} = ${Elatin7::eN};
491             ${Elatin7::not_alnum} = ${Elatin7::not_alnum};
492             ${Elatin7::not_alpha} = ${Elatin7::not_alpha};
493             ${Elatin7::not_ascii} = ${Elatin7::not_ascii};
494             ${Elatin7::not_blank} = ${Elatin7::not_blank};
495             ${Elatin7::not_cntrl} = ${Elatin7::not_cntrl};
496             ${Elatin7::not_digit} = ${Elatin7::not_digit};
497             ${Elatin7::not_graph} = ${Elatin7::not_graph};
498             ${Elatin7::not_lower} = ${Elatin7::not_lower};
499             ${Elatin7::not_lower_i} = ${Elatin7::not_lower_i};
500             ${Elatin7::not_print} = ${Elatin7::not_print};
501             ${Elatin7::not_punct} = ${Elatin7::not_punct};
502             ${Elatin7::not_space} = ${Elatin7::not_space};
503             ${Elatin7::not_upper} = ${Elatin7::not_upper};
504             ${Elatin7::not_upper_i} = ${Elatin7::not_upper_i};
505             ${Elatin7::not_word} = ${Elatin7::not_word};
506             ${Elatin7::not_xdigit} = ${Elatin7::not_xdigit};
507             ${Elatin7::eb} = ${Elatin7::eb};
508             ${Elatin7::eB} = ${Elatin7::eB};
509              
510             #
511             # Latin-7 split
512             #
513             sub Elatin7::split(;$$$) {
514              
515             # P.794 29.2.161. split
516             # in Chapter 29: Functions
517             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
518              
519             # P.951 split
520             # in Chapter 27: Functions
521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
522              
523 0     0 0 0 my $pattern = $_[0];
524 0         0 my $string = $_[1];
525 0         0 my $limit = $_[2];
526              
527             # if $pattern is also omitted or is the literal space, " "
528 0 0       0 if (not defined $pattern) {
529 0         0 $pattern = ' ';
530             }
531              
532             # if $string is omitted, the function splits the $_ string
533 0 0       0 if (not defined $string) {
534 0 0       0 if (defined $_) {
535 0         0 $string = $_;
536             }
537             else {
538 0         0 $string = '';
539             }
540             }
541              
542 0         0 my @split = ();
543              
544             # when string is empty
545 0 0       0 if ($string eq '') {
    0          
546              
547             # resulting list value in list context
548 0 0       0 if (wantarray) {
549 0         0 return @split;
550             }
551              
552             # count of substrings in scalar context
553             else {
554 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
555 0         0 @_ = @split;
556 0         0 return scalar @_;
557             }
558             }
559              
560             # split's first argument is more consistently interpreted
561             #
562             # After some changes earlier in v5.17, split's behavior has been simplified:
563             # if the PATTERN argument evaluates to a string containing one space, it is
564             # treated the way that a literal string containing one space once was.
565             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
566              
567             # if $pattern is also omitted or is the literal space, " ", the function splits
568             # on whitespace, /\s+/, after skipping any leading whitespace
569             # (and so on)
570              
571             elsif ($pattern eq ' ') {
572 0 0       0 if (not defined $limit) {
573 0         0 return CORE::split(' ', $string);
574             }
575             else {
576 0         0 return CORE::split(' ', $string, $limit);
577             }
578             }
579              
580             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
581 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
582              
583             # a pattern capable of matching either the null string or something longer than the
584             # null string will split the value of $string into separate characters wherever it
585             # matches the null string between characters
586             # (and so on)
587              
588 0 0       0 if ('' =~ / \A $pattern \z /xms) {
589 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
590 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
591              
592             # P.1024 Appendix W.10 Multibyte Processing
593             # of ISBN 1-56592-224-7 CJKV Information Processing
594             # (and so on)
595              
596             # the //m modifier is assumed when you split on the pattern /^/
597             # (and so on)
598              
599             # V
600 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
601              
602             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
603             # is included in the resulting list, interspersed with the fields that are ordinarily returned
604             # (and so on)
605              
606 0         0 local $@;
607 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
608 0         0 push @split, CORE::eval('$' . $digit);
609             }
610             }
611             }
612              
613             else {
614 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
615              
616             # V
617 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
618 0         0 local $@;
619 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
620 0         0 push @split, CORE::eval('$' . $digit);
621             }
622             }
623             }
624             }
625              
626             elsif ($limit > 0) {
627 0 0       0 if ('' =~ / \A $pattern \z /xms) {
628 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
629 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
630              
631             # V
632 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
633 0         0 local $@;
634 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
635 0         0 push @split, CORE::eval('$' . $digit);
636             }
637             }
638             }
639             }
640             else {
641 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
642 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
643              
644             # V
645 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
646 0         0 local $@;
647 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
648 0         0 push @split, CORE::eval('$' . $digit);
649             }
650             }
651             }
652             }
653             }
654              
655 0 0       0 if (CORE::length($string) > 0) {
656 0         0 push @split, $string;
657             }
658              
659             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
660 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
661 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
662 0         0 pop @split;
663             }
664             }
665              
666             # resulting list value in list context
667 0 0       0 if (wantarray) {
668 0         0 return @split;
669             }
670              
671             # count of substrings in scalar context
672             else {
673 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
674 0         0 @_ = @split;
675 0         0 return scalar @_;
676             }
677             }
678              
679             #
680             # get last subexpression offsets
681             #
682             sub _last_subexpression_offsets {
683 0     0   0 my $pattern = $_[0];
684              
685             # remove comment
686 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
687              
688 0         0 my $modifier = '';
689 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
690 0         0 $modifier = $1;
691 0         0 $modifier =~ s/-[A-Za-z]*//;
692             }
693              
694             # with /x modifier
695 0         0 my @char = ();
696 0 0       0 if ($modifier =~ /x/oxms) {
697 0         0 @char = $pattern =~ /\G((?>
698             [^\\\#\[\(] |
699             \\ $q_char |
700             \# (?>[^\n]*) $ |
701             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
702             \(\? |
703             $q_char
704             ))/oxmsg;
705             }
706              
707             # without /x modifier
708             else {
709 0         0 @char = $pattern =~ /\G((?>
710             [^\\\[\(] |
711             \\ $q_char |
712             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
713             \(\? |
714             $q_char
715             ))/oxmsg;
716             }
717              
718 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
719             }
720              
721             #
722             # Latin-7 transliteration (tr///)
723             #
724             sub Elatin7::tr($$$$;$) {
725              
726 0     0 0 0 my $bind_operator = $_[1];
727 0         0 my $searchlist = $_[2];
728 0         0 my $replacementlist = $_[3];
729 0   0     0 my $modifier = $_[4] || '';
730              
731 0 0       0 if ($modifier =~ /r/oxms) {
732 0 0       0 if ($bind_operator =~ / !~ /oxms) {
733 0         0 croak "Using !~ with tr///r doesn't make sense";
734             }
735             }
736              
737 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
738 0         0 my @searchlist = _charlist_tr($searchlist);
739 0         0 my @replacementlist = _charlist_tr($replacementlist);
740              
741 0         0 my %tr = ();
742 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
743 0 0       0 if (not exists $tr{$searchlist[$i]}) {
744 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
745 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
746             }
747             elsif ($modifier =~ /d/oxms) {
748 0         0 $tr{$searchlist[$i]} = '';
749             }
750             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
751 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
752             }
753             else {
754 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
755             }
756             }
757             }
758              
759 0         0 my $tr = 0;
760 0         0 my $replaced = '';
761 0 0       0 if ($modifier =~ /c/oxms) {
762 0         0 while (defined(my $char = shift @char)) {
763 0 0       0 if (not exists $tr{$char}) {
764 0 0       0 if (defined $replacementlist[0]) {
765 0         0 $replaced .= $replacementlist[0];
766             }
767 0         0 $tr++;
768 0 0       0 if ($modifier =~ /s/oxms) {
769 0   0     0 while (@char and (not exists $tr{$char[0]})) {
770 0         0 shift @char;
771 0         0 $tr++;
772             }
773             }
774             }
775             else {
776 0         0 $replaced .= $char;
777             }
778             }
779             }
780             else {
781 0         0 while (defined(my $char = shift @char)) {
782 0 0       0 if (exists $tr{$char}) {
783 0         0 $replaced .= $tr{$char};
784 0         0 $tr++;
785 0 0       0 if ($modifier =~ /s/oxms) {
786 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
787 0         0 shift @char;
788 0         0 $tr++;
789             }
790             }
791             }
792             else {
793 0         0 $replaced .= $char;
794             }
795             }
796             }
797              
798 0 0       0 if ($modifier =~ /r/oxms) {
799 0         0 return $replaced;
800             }
801             else {
802 0         0 $_[0] = $replaced;
803 0 0       0 if ($bind_operator =~ / !~ /oxms) {
804 0         0 return not $tr;
805             }
806             else {
807 0         0 return $tr;
808             }
809             }
810             }
811              
812             #
813             # Latin-7 chop
814             #
815             sub Elatin7::chop(@) {
816              
817 0     0 0 0 my $chop;
818 0 0       0 if (@_ == 0) {
819 0         0 my @char = /\G (?>$q_char) /oxmsg;
820 0         0 $chop = pop @char;
821 0         0 $_ = join '', @char;
822             }
823             else {
824 0         0 for (@_) {
825 0         0 my @char = /\G (?>$q_char) /oxmsg;
826 0         0 $chop = pop @char;
827 0         0 $_ = join '', @char;
828             }
829             }
830 0         0 return $chop;
831             }
832              
833             #
834             # Latin-7 index by octet
835             #
836             sub Elatin7::index($$;$) {
837              
838 0     0 1 0 my($str,$substr,$position) = @_;
839 0   0     0 $position ||= 0;
840 0         0 my $pos = 0;
841              
842 0         0 while ($pos < CORE::length($str)) {
843 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
844 0 0       0 if ($pos >= $position) {
845 0         0 return $pos;
846             }
847             }
848 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
849 0         0 $pos += CORE::length($1);
850             }
851             else {
852 0         0 $pos += 1;
853             }
854             }
855 0         0 return -1;
856             }
857              
858             #
859             # Latin-7 reverse index
860             #
861             sub Elatin7::rindex($$;$) {
862              
863 0     0 0 0 my($str,$substr,$position) = @_;
864 0   0     0 $position ||= CORE::length($str) - 1;
865 0         0 my $pos = 0;
866 0         0 my $rindex = -1;
867              
868 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
869 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
870 0         0 $rindex = $pos;
871             }
872 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
873 0         0 $pos += CORE::length($1);
874             }
875             else {
876 0         0 $pos += 1;
877             }
878             }
879 0         0 return $rindex;
880             }
881              
882             #
883             # Latin-7 lower case first with parameter
884             #
885             sub Elatin7::lcfirst(@) {
886 0 0   0 0 0 if (@_) {
887 0         0 my $s = shift @_;
888 0 0 0     0 if (@_ and wantarray) {
889 0         0 return Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
890             }
891             else {
892 0         0 return Elatin7::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
893             }
894             }
895             else {
896 0         0 return Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
897             }
898             }
899              
900             #
901             # Latin-7 lower case first without parameter
902             #
903             sub Elatin7::lcfirst_() {
904 0     0 0 0 return Elatin7::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
905             }
906              
907             #
908             # Latin-7 lower case with parameter
909             #
910             sub Elatin7::lc(@) {
911 0 0   0 0 0 if (@_) {
912 0         0 my $s = shift @_;
913 0 0 0     0 if (@_ and wantarray) {
914 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
915             }
916             else {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
918             }
919             }
920             else {
921 0         0 return Elatin7::lc_();
922             }
923             }
924              
925             #
926             # Latin-7 lower case without parameter
927             #
928             sub Elatin7::lc_() {
929 0     0 0 0 my $s = $_;
930 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
931             }
932              
933             #
934             # Latin-7 upper case first with parameter
935             #
936             sub Elatin7::ucfirst(@) {
937 0 0   0 0 0 if (@_) {
938 0         0 my $s = shift @_;
939 0 0 0     0 if (@_ and wantarray) {
940 0         0 return Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
941             }
942             else {
943 0         0 return Elatin7::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
944             }
945             }
946             else {
947 0         0 return Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
948             }
949             }
950              
951             #
952             # Latin-7 upper case first without parameter
953             #
954             sub Elatin7::ucfirst_() {
955 0     0 0 0 return Elatin7::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
956             }
957              
958             #
959             # Latin-7 upper case with parameter
960             #
961             sub Elatin7::uc(@) {
962 0 0   0 0 0 if (@_) {
963 0         0 my $s = shift @_;
964 0 0 0     0 if (@_ and wantarray) {
965 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
966             }
967             else {
968 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
969             }
970             }
971             else {
972 0         0 return Elatin7::uc_();
973             }
974             }
975              
976             #
977             # Latin-7 upper case without parameter
978             #
979             sub Elatin7::uc_() {
980 0     0 0 0 my $s = $_;
981 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
982             }
983              
984             #
985             # Latin-7 fold case with parameter
986             #
987             sub Elatin7::fc(@) {
988 0 0   0 0 0 if (@_) {
989 0         0 my $s = shift @_;
990 0 0 0     0 if (@_ and wantarray) {
991 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
992             }
993             else {
994 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
995             }
996             }
997             else {
998 0         0 return Elatin7::fc_();
999             }
1000             }
1001              
1002             #
1003             # Latin-7 fold case without parameter
1004             #
1005             sub Elatin7::fc_() {
1006 0     0 0 0 my $s = $_;
1007 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1008             }
1009              
1010             #
1011             # Latin-7 regexp capture
1012             #
1013             {
1014             sub Elatin7::capture {
1015 0     0 1 0 return $_[0];
1016             }
1017             }
1018              
1019             #
1020             # Latin-7 regexp ignore case modifier
1021             #
1022             sub Elatin7::ignorecase {
1023              
1024 0     0 0 0 my @string = @_;
1025 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1026              
1027             # ignore case of $scalar or @array
1028 0         0 for my $string (@string) {
1029              
1030             # split regexp
1031 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1032              
1033             # unescape character
1034 0         0 for (my $i=0; $i <= $#char; $i++) {
1035 0 0       0 next if not defined $char[$i];
1036              
1037             # open character class [...]
1038 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1039 0         0 my $left = $i;
1040              
1041             # [] make die "unmatched [] in regexp ...\n"
1042              
1043 0 0       0 if ($char[$i+1] eq ']') {
1044 0         0 $i++;
1045             }
1046              
1047 0         0 while (1) {
1048 0 0       0 if (++$i > $#char) {
1049 0         0 croak "Unmatched [] in regexp";
1050             }
1051 0 0       0 if ($char[$i] eq ']') {
1052 0         0 my $right = $i;
1053 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1054              
1055             # escape character
1056 0         0 for my $char (@charlist) {
1057 0 0       0 if (0) {
1058             }
1059              
1060 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1061 0         0 $char = '\\' . $char;
1062             }
1063             }
1064              
1065             # [...]
1066 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1067              
1068 0         0 $i = $left;
1069 0         0 last;
1070             }
1071             }
1072             }
1073              
1074             # open character class [^...]
1075             elsif ($char[$i] eq '[^') {
1076 0         0 my $left = $i;
1077              
1078             # [^] make die "unmatched [] in regexp ...\n"
1079              
1080 0 0       0 if ($char[$i+1] eq ']') {
1081 0         0 $i++;
1082             }
1083              
1084 0         0 while (1) {
1085 0 0       0 if (++$i > $#char) {
1086 0         0 croak "Unmatched [] in regexp";
1087             }
1088 0 0       0 if ($char[$i] eq ']') {
1089 0         0 my $right = $i;
1090 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1091              
1092             # escape character
1093 0         0 for my $char (@charlist) {
1094 0 0       0 if (0) {
1095             }
1096              
1097 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1098 0         0 $char = '\\' . $char;
1099             }
1100             }
1101              
1102             # [^...]
1103 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1104              
1105 0         0 $i = $left;
1106 0         0 last;
1107             }
1108             }
1109             }
1110              
1111             # rewrite classic character class or escape character
1112             elsif (my $char = classic_character_class($char[$i])) {
1113 0         0 $char[$i] = $char;
1114             }
1115              
1116             # with /i modifier
1117             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1118 0         0 my $uc = Elatin7::uc($char[$i]);
1119 0         0 my $fc = Elatin7::fc($char[$i]);
1120 0 0       0 if ($uc ne $fc) {
1121 0 0       0 if (CORE::length($fc) == 1) {
1122 0         0 $char[$i] = '[' . $uc . $fc . ']';
1123             }
1124             else {
1125 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1126             }
1127             }
1128             }
1129             }
1130              
1131             # characterize
1132 0         0 for (my $i=0; $i <= $#char; $i++) {
1133 0 0       0 next if not defined $char[$i];
1134              
1135 0 0       0 if (0) {
1136             }
1137              
1138             # quote character before ? + * {
1139 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1140 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1141 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1142             }
1143             }
1144             }
1145              
1146 0         0 $string = join '', @char;
1147             }
1148              
1149             # make regexp string
1150 0         0 return @string;
1151             }
1152              
1153             #
1154             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1155             #
1156             sub Elatin7::classic_character_class {
1157 0     0 0 0 my($char) = @_;
1158              
1159             return {
1160 0   0     0 '\D' => '${Elatin7::eD}',
1161             '\S' => '${Elatin7::eS}',
1162             '\W' => '${Elatin7::eW}',
1163             '\d' => '[0-9]',
1164              
1165             # Before Perl 5.6, \s only matched the five whitespace characters
1166             # tab, newline, form-feed, carriage return, and the space character
1167             # itself, which, taken together, is the character class [\t\n\f\r ].
1168              
1169             # Vertical tabs are now whitespace
1170             # \s in a regex now matches a vertical tab in all circumstances.
1171             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1172             # \t \n \v \f \r space
1173             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1174             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1175             '\s' => '\s',
1176              
1177             '\w' => '[0-9A-Z_a-z]',
1178             '\C' => '[\x00-\xFF]',
1179             '\X' => 'X',
1180              
1181             # \h \v \H \V
1182              
1183             # P.114 Character Class Shortcuts
1184             # in Chapter 7: In the World of Regular Expressions
1185             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1186              
1187             # P.357 13.2.3 Whitespace
1188             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1189             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1190             #
1191             # 0x00009 CHARACTER TABULATION h s
1192             # 0x0000a LINE FEED (LF) vs
1193             # 0x0000b LINE TABULATION v
1194             # 0x0000c FORM FEED (FF) vs
1195             # 0x0000d CARRIAGE RETURN (CR) vs
1196             # 0x00020 SPACE h s
1197              
1198             # P.196 Table 5-9. Alphanumeric regex metasymbols
1199             # in Chapter 5. Pattern Matching
1200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1201              
1202             # (and so on)
1203              
1204             '\H' => '${Elatin7::eH}',
1205             '\V' => '${Elatin7::eV}',
1206             '\h' => '[\x09\x20]',
1207             '\v' => '[\x0A\x0B\x0C\x0D]',
1208             '\R' => '${Elatin7::eR}',
1209              
1210             # \N
1211             #
1212             # http://perldoc.perl.org/perlre.html
1213             # Character Classes and other Special Escapes
1214             # Any character but \n (experimental). Not affected by /s modifier
1215              
1216             '\N' => '${Elatin7::eN}',
1217              
1218             # \b \B
1219              
1220             # P.180 Boundaries: The \b and \B Assertions
1221             # in Chapter 5: Pattern Matching
1222             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1223              
1224             # P.219 Boundaries: The \b and \B Assertions
1225             # in Chapter 5: Pattern Matching
1226             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1227              
1228             # \b really means (?:(?<=\w)(?!\w)|(?
1229             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1230             '\b' => '${Elatin7::eb}',
1231              
1232             # \B really means (?:(?<=\w)(?=\w)|(?
1233             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1234             '\B' => '${Elatin7::eB}',
1235              
1236             }->{$char} || '';
1237             }
1238              
1239             #
1240             # prepare Latin-7 characters per length
1241             #
1242              
1243             # 1 octet characters
1244             my @chars1 = ();
1245             sub chars1 {
1246 0 0   0 0 0 if (@chars1) {
1247 0         0 return @chars1;
1248             }
1249 0 0       0 if (exists $range_tr{1}) {
1250 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1251 0         0 while (my @range = splice(@ranges,0,1)) {
1252 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1253 0         0 push @chars1, pack 'C', $oct0;
1254             }
1255             }
1256             }
1257 0         0 return @chars1;
1258             }
1259              
1260             # 2 octets characters
1261             my @chars2 = ();
1262             sub chars2 {
1263 0 0   0 0 0 if (@chars2) {
1264 0         0 return @chars2;
1265             }
1266 0 0       0 if (exists $range_tr{2}) {
1267 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1268 0         0 while (my @range = splice(@ranges,0,2)) {
1269 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1270 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1271 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1272             }
1273             }
1274             }
1275             }
1276 0         0 return @chars2;
1277             }
1278              
1279             # 3 octets characters
1280             my @chars3 = ();
1281             sub chars3 {
1282 0 0   0 0 0 if (@chars3) {
1283 0         0 return @chars3;
1284             }
1285 0 0       0 if (exists $range_tr{3}) {
1286 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1287 0         0 while (my @range = splice(@ranges,0,3)) {
1288 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1289 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1290 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1291 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1292             }
1293             }
1294             }
1295             }
1296             }
1297 0         0 return @chars3;
1298             }
1299              
1300             # 4 octets characters
1301             my @chars4 = ();
1302             sub chars4 {
1303 0 0   0 0 0 if (@chars4) {
1304 0         0 return @chars4;
1305             }
1306 0 0       0 if (exists $range_tr{4}) {
1307 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1308 0         0 while (my @range = splice(@ranges,0,4)) {
1309 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1310 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1311 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1312 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1313 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1314             }
1315             }
1316             }
1317             }
1318             }
1319             }
1320 0         0 return @chars4;
1321             }
1322              
1323             #
1324             # Latin-7 open character list for tr
1325             #
1326             sub _charlist_tr {
1327              
1328 0     0   0 local $_ = shift @_;
1329              
1330             # unescape character
1331 0         0 my @char = ();
1332 0         0 while (not /\G \z/oxmsgc) {
1333 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1334 0         0 push @char, '\-';
1335             }
1336             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1337 0         0 push @char, CORE::chr(oct $1);
1338             }
1339             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(hex $1);
1341             }
1342             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1343 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1344             }
1345             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1346 0         0 push @char, {
1347             '\0' => "\0",
1348             '\n' => "\n",
1349             '\r' => "\r",
1350             '\t' => "\t",
1351             '\f' => "\f",
1352             '\b' => "\x08", # \b means backspace in character class
1353             '\a' => "\a",
1354             '\e' => "\e",
1355             }->{$1};
1356             }
1357             elsif (/\G \\ ($q_char) /oxmsgc) {
1358 0         0 push @char, $1;
1359             }
1360             elsif (/\G ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             }
1364              
1365             # join separated multiple-octet
1366 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1367              
1368             # unescape '-'
1369 0         0 my @i = ();
1370 0         0 for my $i (0 .. $#char) {
1371 0 0       0 if ($char[$i] eq '\-') {
    0          
1372 0         0 $char[$i] = '-';
1373             }
1374             elsif ($char[$i] eq '-') {
1375 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1376 0         0 push @i, $i;
1377             }
1378             }
1379             }
1380              
1381             # open character list (reverse for splice)
1382 0         0 for my $i (CORE::reverse @i) {
1383 0         0 my @range = ();
1384              
1385             # range error
1386 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1387 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1388             }
1389              
1390             # range of multiple-octet code
1391 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1392 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1393 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1394             }
1395             elsif (CORE::length($char[$i+1]) == 2) {
1396 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1397 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1398             }
1399             elsif (CORE::length($char[$i+1]) == 3) {
1400 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1401 0         0 push @range, chars2();
1402 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1403             }
1404             elsif (CORE::length($char[$i+1]) == 4) {
1405 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1406 0         0 push @range, chars2();
1407 0         0 push @range, chars3();
1408 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1409             }
1410             else {
1411 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1412             }
1413             }
1414             elsif (CORE::length($char[$i-1]) == 2) {
1415 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1416 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1417             }
1418             elsif (CORE::length($char[$i+1]) == 3) {
1419 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1421             }
1422             elsif (CORE::length($char[$i+1]) == 4) {
1423 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1424 0         0 push @range, chars3();
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1426             }
1427             else {
1428 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1429             }
1430             }
1431             elsif (CORE::length($char[$i-1]) == 3) {
1432 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1433 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1434             }
1435             elsif (CORE::length($char[$i+1]) == 4) {
1436 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1437 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1438             }
1439             else {
1440 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1441             }
1442             }
1443             elsif (CORE::length($char[$i-1]) == 4) {
1444 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1445 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1446             }
1447             else {
1448 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1449             }
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454              
1455 0         0 splice @char, $i-1, 3, @range;
1456             }
1457              
1458 0         0 return @char;
1459             }
1460              
1461             #
1462             # Latin-7 open character class
1463             #
1464             sub _cc {
1465 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1466 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1467             }
1468             elsif (scalar(@_) == 1) {
1469 0         0 return sprintf('\x%02X',$_[0]);
1470             }
1471             elsif (scalar(@_) == 2) {
1472 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1473 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1474             }
1475             elsif ($_[0] == $_[1]) {
1476 0         0 return sprintf('\x%02X',$_[0]);
1477             }
1478             elsif (($_[0]+1) == $_[1]) {
1479 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1480             }
1481             else {
1482 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1483             }
1484             }
1485             else {
1486 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1487             }
1488             }
1489              
1490             #
1491             # Latin-7 octet range
1492             #
1493             sub _octets {
1494 0     0   0 my $length = shift @_;
1495              
1496 0 0       0 if ($length == 1) {
1497 0         0 my($a1) = unpack 'C', $_[0];
1498 0         0 my($z1) = unpack 'C', $_[1];
1499              
1500 0 0       0 if ($a1 > $z1) {
1501 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1502             }
1503              
1504 0 0       0 if ($a1 == $z1) {
    0          
1505 0         0 return sprintf('\x%02X',$a1);
1506             }
1507             elsif (($a1+1) == $z1) {
1508 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1509             }
1510             else {
1511 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1512             }
1513             }
1514             else {
1515 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1516             }
1517             }
1518              
1519             #
1520             # Latin-7 range regexp
1521             #
1522             sub _range_regexp {
1523 0     0   0 my($length,$first,$last) = @_;
1524              
1525 0         0 my @range_regexp = ();
1526 0 0       0 if (not exists $range_tr{$length}) {
1527 0         0 return @range_regexp;
1528             }
1529              
1530 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1531 0         0 while (my @range = splice(@ranges,0,$length)) {
1532 0         0 my $min = '';
1533 0         0 my $max = '';
1534 0         0 for (my $i=0; $i < $length; $i++) {
1535 0         0 $min .= pack 'C', $range[$i][0];
1536 0         0 $max .= pack 'C', $range[$i][-1];
1537             }
1538              
1539             # min___max
1540             # FIRST_____________LAST
1541             # (nothing)
1542              
1543 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1544             }
1545              
1546             # **********
1547             # min_________max
1548             # FIRST_____________LAST
1549             # **********
1550              
1551             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1552 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1553             }
1554              
1555             # **********************
1556             # min________________max
1557             # FIRST_____________LAST
1558             # **********************
1559              
1560             elsif (($min eq $first) and ($max eq $last)) {
1561 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1562             }
1563              
1564             # *********
1565             # min___max
1566             # FIRST_____________LAST
1567             # *********
1568              
1569             elsif (($first le $min) and ($max le $last)) {
1570 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1571             }
1572              
1573             # **********************
1574             # min__________________________max
1575             # FIRST_____________LAST
1576             # **********************
1577              
1578             elsif (($min le $first) and ($last le $max)) {
1579 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1580             }
1581              
1582             # *********
1583             # min________max
1584             # FIRST_____________LAST
1585             # *********
1586              
1587             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1588 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1589             }
1590              
1591             # min___max
1592             # FIRST_____________LAST
1593             # (nothing)
1594              
1595             elsif ($last lt $min) {
1596             }
1597              
1598             else {
1599 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1600             }
1601             }
1602              
1603 0         0 return @range_regexp;
1604             }
1605              
1606             #
1607             # Latin-7 open character list for qr and not qr
1608             #
1609             sub _charlist {
1610              
1611 0     0   0 my $modifier = pop @_;
1612 0         0 my @char = @_;
1613              
1614 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1615              
1616             # unescape character
1617 0         0 for (my $i=0; $i <= $#char; $i++) {
1618              
1619             # escape - to ...
1620 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1621 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1622 0         0 $char[$i] = '...';
1623             }
1624             }
1625              
1626             # octal escape sequence
1627             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1628 0         0 $char[$i] = octchr($1);
1629             }
1630              
1631             # hexadecimal escape sequence
1632             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1633 0         0 $char[$i] = hexchr($1);
1634             }
1635              
1636             # \b{...} --> b\{...}
1637             # \B{...} --> B\{...}
1638             # \N{CHARNAME} --> N\{CHARNAME}
1639             # \p{PROPERTY} --> p\{PROPERTY}
1640             # \P{PROPERTY} --> P\{PROPERTY}
1641             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1642 0         0 $char[$i] = $1 . '\\' . $2;
1643             }
1644              
1645             # \p, \P, \X --> p, P, X
1646             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1647 0         0 $char[$i] = $1;
1648             }
1649              
1650             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1651 0         0 $char[$i] = CORE::chr oct $1;
1652             }
1653             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr hex $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1657 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1658             }
1659             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1660 0         0 $char[$i] = {
1661             '\0' => "\0",
1662             '\n' => "\n",
1663             '\r' => "\r",
1664             '\t' => "\t",
1665             '\f' => "\f",
1666             '\b' => "\x08", # \b means backspace in character class
1667             '\a' => "\a",
1668             '\e' => "\e",
1669             '\d' => '[0-9]',
1670              
1671             # Vertical tabs are now whitespace
1672             # \s in a regex now matches a vertical tab in all circumstances.
1673             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1674             # \t \n \v \f \r space
1675             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1676             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1677             '\s' => '\s',
1678              
1679             '\w' => '[0-9A-Z_a-z]',
1680             '\D' => '${Elatin7::eD}',
1681             '\S' => '${Elatin7::eS}',
1682             '\W' => '${Elatin7::eW}',
1683              
1684             '\H' => '${Elatin7::eH}',
1685             '\V' => '${Elatin7::eV}',
1686             '\h' => '[\x09\x20]',
1687             '\v' => '[\x0A\x0B\x0C\x0D]',
1688             '\R' => '${Elatin7::eR}',
1689              
1690             }->{$1};
1691             }
1692              
1693             # POSIX-style character classes
1694             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1695 0         0 $char[$i] = {
1696              
1697             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1698             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1699             '[:^lower:]' => '${Elatin7::not_lower_i}',
1700             '[:^upper:]' => '${Elatin7::not_upper_i}',
1701              
1702             }->{$1};
1703             }
1704             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1705 0         0 $char[$i] = {
1706              
1707             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1708             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1709             '[:ascii:]' => '[\x00-\x7F]',
1710             '[:blank:]' => '[\x09\x20]',
1711             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1712             '[:digit:]' => '[\x30-\x39]',
1713             '[:graph:]' => '[\x21-\x7F]',
1714             '[:lower:]' => '[\x61-\x7A]',
1715             '[:print:]' => '[\x20-\x7F]',
1716             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1717              
1718             # P.174 POSIX-Style Character Classes
1719             # in Chapter 5: Pattern Matching
1720             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1721              
1722             # P.311 11.2.4 Character Classes and other Special Escapes
1723             # in Chapter 11: perlre: Perl regular expressions
1724             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1725              
1726             # P.210 POSIX-Style Character Classes
1727             # in Chapter 5: Pattern Matching
1728             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1729              
1730             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1731              
1732             '[:upper:]' => '[\x41-\x5A]',
1733             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1734             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1735             '[:^alnum:]' => '${Elatin7::not_alnum}',
1736             '[:^alpha:]' => '${Elatin7::not_alpha}',
1737             '[:^ascii:]' => '${Elatin7::not_ascii}',
1738             '[:^blank:]' => '${Elatin7::not_blank}',
1739             '[:^cntrl:]' => '${Elatin7::not_cntrl}',
1740             '[:^digit:]' => '${Elatin7::not_digit}',
1741             '[:^graph:]' => '${Elatin7::not_graph}',
1742             '[:^lower:]' => '${Elatin7::not_lower}',
1743             '[:^print:]' => '${Elatin7::not_print}',
1744             '[:^punct:]' => '${Elatin7::not_punct}',
1745             '[:^space:]' => '${Elatin7::not_space}',
1746             '[:^upper:]' => '${Elatin7::not_upper}',
1747             '[:^word:]' => '${Elatin7::not_word}',
1748             '[:^xdigit:]' => '${Elatin7::not_xdigit}',
1749              
1750             }->{$1};
1751             }
1752             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1753 0         0 $char[$i] = $1;
1754             }
1755             }
1756              
1757             # open character list
1758 0         0 my @singleoctet = ();
1759 0         0 my @multipleoctet = ();
1760 0         0 for (my $i=0; $i <= $#char; ) {
1761              
1762             # escaped -
1763 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1764 0         0 $i += 1;
1765 0         0 next;
1766             }
1767              
1768             # make range regexp
1769             elsif ($char[$i] eq '...') {
1770              
1771             # range error
1772 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1773 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1774             }
1775             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1776 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1777 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1778             }
1779             }
1780              
1781             # make range regexp per length
1782 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1783 0         0 my @regexp = ();
1784              
1785             # is first and last
1786 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1787 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1788             }
1789              
1790             # is first
1791             elsif ($length == CORE::length($char[$i-1])) {
1792 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1793             }
1794              
1795             # is inside in first and last
1796             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1797 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1798             }
1799              
1800             # is last
1801             elsif ($length == CORE::length($char[$i+1])) {
1802 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1803             }
1804              
1805             else {
1806 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1807             }
1808              
1809 0 0       0 if ($length == 1) {
1810 0         0 push @singleoctet, @regexp;
1811             }
1812             else {
1813 0         0 push @multipleoctet, @regexp;
1814             }
1815             }
1816              
1817 0         0 $i += 2;
1818             }
1819              
1820             # with /i modifier
1821             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1822 0 0       0 if ($modifier =~ /i/oxms) {
1823 0         0 my $uc = Elatin7::uc($char[$i]);
1824 0         0 my $fc = Elatin7::fc($char[$i]);
1825 0 0       0 if ($uc ne $fc) {
1826 0 0       0 if (CORE::length($fc) == 1) {
1827 0         0 push @singleoctet, $uc, $fc;
1828             }
1829             else {
1830 0         0 push @singleoctet, $uc;
1831 0         0 push @multipleoctet, $fc;
1832             }
1833             }
1834             else {
1835 0         0 push @singleoctet, $char[$i];
1836             }
1837             }
1838             else {
1839 0         0 push @singleoctet, $char[$i];
1840             }
1841 0         0 $i += 1;
1842             }
1843              
1844             # single character of single octet code
1845             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1846 0         0 push @singleoctet, "\t", "\x20";
1847 0         0 $i += 1;
1848             }
1849             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1850 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1851 0         0 $i += 1;
1852             }
1853             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1854 0         0 push @singleoctet, $char[$i];
1855 0         0 $i += 1;
1856             }
1857              
1858             # single character of multiple-octet code
1859             else {
1860 0         0 push @multipleoctet, $char[$i];
1861 0         0 $i += 1;
1862             }
1863             }
1864              
1865             # quote metachar
1866 0         0 for (@singleoctet) {
1867 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1868 0         0 $_ = '-';
1869             }
1870             elsif (/\A \n \z/oxms) {
1871 0         0 $_ = '\n';
1872             }
1873             elsif (/\A \r \z/oxms) {
1874 0         0 $_ = '\r';
1875             }
1876             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1877 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1878             }
1879             elsif (/\A [\x00-\xFF] \z/oxms) {
1880 0         0 $_ = quotemeta $_;
1881             }
1882             }
1883              
1884             # return character list
1885 0         0 return \@singleoctet, \@multipleoctet;
1886             }
1887              
1888             #
1889             # Latin-7 octal escape sequence
1890             #
1891             sub octchr {
1892 0     0 0 0 my($octdigit) = @_;
1893              
1894 0         0 my @binary = ();
1895 0         0 for my $octal (split(//,$octdigit)) {
1896 0         0 push @binary, {
1897             '0' => '000',
1898             '1' => '001',
1899             '2' => '010',
1900             '3' => '011',
1901             '4' => '100',
1902             '5' => '101',
1903             '6' => '110',
1904             '7' => '111',
1905             }->{$octal};
1906             }
1907 0         0 my $binary = join '', @binary;
1908              
1909 0         0 my $octchr = {
1910             # 1234567
1911             1 => pack('B*', "0000000$binary"),
1912             2 => pack('B*', "000000$binary"),
1913             3 => pack('B*', "00000$binary"),
1914             4 => pack('B*', "0000$binary"),
1915             5 => pack('B*', "000$binary"),
1916             6 => pack('B*', "00$binary"),
1917             7 => pack('B*', "0$binary"),
1918             0 => pack('B*', "$binary"),
1919              
1920             }->{CORE::length($binary) % 8};
1921              
1922 0         0 return $octchr;
1923             }
1924              
1925             #
1926             # Latin-7 hexadecimal escape sequence
1927             #
1928             sub hexchr {
1929 0     0 0 0 my($hexdigit) = @_;
1930              
1931 0         0 my $hexchr = {
1932             1 => pack('H*', "0$hexdigit"),
1933             0 => pack('H*', "$hexdigit"),
1934              
1935             }->{CORE::length($_[0]) % 2};
1936              
1937 0         0 return $hexchr;
1938             }
1939              
1940             #
1941             # Latin-7 open character list for qr
1942             #
1943             sub charlist_qr {
1944              
1945 0     0 0 0 my $modifier = pop @_;
1946 0         0 my @char = @_;
1947              
1948 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1949 0         0 my @singleoctet = @$singleoctet;
1950 0         0 my @multipleoctet = @$multipleoctet;
1951              
1952             # return character list
1953 0 0       0 if (scalar(@singleoctet) >= 1) {
1954              
1955             # with /i modifier
1956 0 0       0 if ($modifier =~ m/i/oxms) {
1957 0         0 my %singleoctet_ignorecase = ();
1958 0         0 for (@singleoctet) {
1959 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1960 0         0 for my $ord (hex($1) .. hex($2)) {
1961 0         0 my $char = CORE::chr($ord);
1962 0         0 my $uc = Elatin7::uc($char);
1963 0         0 my $fc = Elatin7::fc($char);
1964 0 0       0 if ($uc eq $fc) {
1965 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1966             }
1967             else {
1968 0 0       0 if (CORE::length($fc) == 1) {
1969 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1970 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1971             }
1972             else {
1973 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1974 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1975             }
1976             }
1977             }
1978             }
1979 0 0       0 if ($_ ne '') {
1980 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1981             }
1982             }
1983 0         0 my $i = 0;
1984 0         0 my @singleoctet_ignorecase = ();
1985 0         0 for my $ord (0 .. 255) {
1986 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1987 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1988             }
1989             else {
1990 0         0 $i++;
1991             }
1992             }
1993 0         0 @singleoctet = ();
1994 0         0 for my $range (@singleoctet_ignorecase) {
1995 0 0       0 if (ref $range) {
1996 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1997 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1998             }
1999             elsif (scalar(@{$range}) == 2) {
2000 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2001             }
2002             else {
2003 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2004             }
2005             }
2006             }
2007             }
2008              
2009 0         0 my $not_anchor = '';
2010              
2011 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2012             }
2013 0 0       0 if (scalar(@multipleoctet) >= 2) {
2014 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2015             }
2016             else {
2017 0         0 return $multipleoctet[0];
2018             }
2019             }
2020              
2021             #
2022             # Latin-7 open character list for not qr
2023             #
2024             sub charlist_not_qr {
2025              
2026 0     0 0 0 my $modifier = pop @_;
2027 0         0 my @char = @_;
2028              
2029 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2030 0         0 my @singleoctet = @$singleoctet;
2031 0         0 my @multipleoctet = @$multipleoctet;
2032              
2033             # with /i modifier
2034 0 0       0 if ($modifier =~ m/i/oxms) {
2035 0         0 my %singleoctet_ignorecase = ();
2036 0         0 for (@singleoctet) {
2037 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2038 0         0 for my $ord (hex($1) .. hex($2)) {
2039 0         0 my $char = CORE::chr($ord);
2040 0         0 my $uc = Elatin7::uc($char);
2041 0         0 my $fc = Elatin7::fc($char);
2042 0 0       0 if ($uc eq $fc) {
2043 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2044             }
2045             else {
2046 0 0       0 if (CORE::length($fc) == 1) {
2047 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2048 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2049             }
2050             else {
2051 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2052 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2053             }
2054             }
2055             }
2056             }
2057 0 0       0 if ($_ ne '') {
2058 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2059             }
2060             }
2061 0         0 my $i = 0;
2062 0         0 my @singleoctet_ignorecase = ();
2063 0         0 for my $ord (0 .. 255) {
2064 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2065 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2066             }
2067             else {
2068 0         0 $i++;
2069             }
2070             }
2071 0         0 @singleoctet = ();
2072 0         0 for my $range (@singleoctet_ignorecase) {
2073 0 0       0 if (ref $range) {
2074 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2075 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2076             }
2077             elsif (scalar(@{$range}) == 2) {
2078 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2079             }
2080             else {
2081 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2082             }
2083             }
2084             }
2085             }
2086              
2087             # return character list
2088 0 0       0 if (scalar(@multipleoctet) >= 1) {
2089 0 0       0 if (scalar(@singleoctet) >= 1) {
2090              
2091             # any character other than multiple-octet and single octet character class
2092 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2093             }
2094             else {
2095              
2096             # any character other than multiple-octet character class
2097 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2098             }
2099             }
2100             else {
2101 0 0       0 if (scalar(@singleoctet) >= 1) {
2102              
2103             # any character other than single octet character class
2104 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2105             }
2106             else {
2107              
2108             # any character
2109 0         0 return "(?:$your_char)";
2110             }
2111             }
2112             }
2113              
2114             #
2115             # open file in read mode
2116             #
2117             sub _open_r {
2118 200     200   647 my(undef,$file) = @_;
2119 200         846 $file =~ s#\A (\s) #./$1#oxms;
2120 200   33     18036 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2121             open($_[0],"< $file\0");
2122             }
2123              
2124             #
2125             # open file in write mode
2126             #
2127             sub _open_w {
2128 0     0   0 my(undef,$file) = @_;
2129 0         0 $file =~ s#\A (\s) #./$1#oxms;
2130 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2131             open($_[0],"> $file\0");
2132             }
2133              
2134             #
2135             # open file in append mode
2136             #
2137             sub _open_a {
2138 0     0   0 my(undef,$file) = @_;
2139 0         0 $file =~ s#\A (\s) #./$1#oxms;
2140 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2141             open($_[0],">> $file\0");
2142             }
2143              
2144             #
2145             # safe system
2146             #
2147             sub _systemx {
2148              
2149             # P.707 29.2.33. exec
2150             # in Chapter 29: Functions
2151             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2152             #
2153             # Be aware that in older releases of Perl, exec (and system) did not flush
2154             # your output buffer, so you needed to enable command buffering by setting $|
2155             # on one or more filehandles to avoid lost output in the case of exec, or
2156             # misordererd output in the case of system. This situation was largely remedied
2157             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2158              
2159             # P.855 exec
2160             # in Chapter 27: Functions
2161             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2162             #
2163             # In very old release of Perl (before v5.6), exec (and system) did not flush
2164             # your output buffer, so you needed to enable command buffering by setting $|
2165             # on one or more filehandles to avoid lost output with exec or misordered
2166             # output with system.
2167              
2168 200     200   742 $| = 1;
2169              
2170             # P.565 23.1.2. Cleaning Up Your Environment
2171             # in Chapter 23: Security
2172             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2173              
2174             # P.656 Cleaning Up Your Environment
2175             # in Chapter 20: Security
2176             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2177              
2178             # local $ENV{'PATH'} = '.';
2179 200         2068 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2180              
2181             # P.707 29.2.33. exec
2182             # in Chapter 29: Functions
2183             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2184             #
2185             # As we mentioned earlier, exec treats a discrete list of arguments as an
2186             # indication that it should bypass shell processing. However, there is one
2187             # place where you might still get tripped up. The exec call (and system, too)
2188             # will not distinguish between a single scalar argument and an array containing
2189             # only one element.
2190             #
2191             # @args = ("echo surprise"); # just one element in list
2192             # exec @args # still subject to shell escapes
2193             # or die "exec: $!"; # because @args == 1
2194             #
2195             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2196             # first argument as the pathname, which forces the rest of the arguments to be
2197             # interpreted as a list, even if there is only one of them:
2198             #
2199             # exec { $args[0] } @args # safe even with one-argument list
2200             # or die "can't exec @args: $!";
2201              
2202             # P.855 exec
2203             # in Chapter 27: Functions
2204             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2205             #
2206             # As we mentioned earlier, exec treats a discrete list of arguments as a
2207             # directive to bypass shell processing. However, there is one place where
2208             # you might still get tripped up. The exec call (and system, too) cannot
2209             # distinguish between a single scalar argument and an array containing
2210             # only one element.
2211             #
2212             # @args = ("echo surprise"); # just one element in list
2213             # exec @args # still subject to shell escapes
2214             # || die "exec: $!"; # because @args == 1
2215             #
2216             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2217             # argument as the pathname, which forces the rest of the arguments to be
2218             # interpreted as a list, even if there is only one of them:
2219             #
2220             # exec { $args[0] } @args # safe even with one-argument list
2221             # || die "can't exec @args: $!";
2222              
2223 200         422 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         23504364  
2224             }
2225              
2226             #
2227             # Latin-7 order to character (with parameter)
2228             #
2229             sub Elatin7::chr(;$) {
2230              
2231 0 0   0 0   my $c = @_ ? $_[0] : $_;
2232              
2233 0 0         if ($c == 0x00) {
2234 0           return "\x00";
2235             }
2236             else {
2237 0           my @chr = ();
2238 0           while ($c > 0) {
2239 0           unshift @chr, ($c % 0x100);
2240 0           $c = int($c / 0x100);
2241             }
2242 0           return pack 'C*', @chr;
2243             }
2244             }
2245              
2246             #
2247             # Latin-7 order to character (without parameter)
2248             #
2249             sub Elatin7::chr_() {
2250              
2251 0     0 0   my $c = $_;
2252              
2253 0 0         if ($c == 0x00) {
2254 0           return "\x00";
2255             }
2256             else {
2257 0           my @chr = ();
2258 0           while ($c > 0) {
2259 0           unshift @chr, ($c % 0x100);
2260 0           $c = int($c / 0x100);
2261             }
2262 0           return pack 'C*', @chr;
2263             }
2264             }
2265              
2266             #
2267             # Latin-7 path globbing (with parameter)
2268             #
2269             sub Elatin7::glob($) {
2270              
2271 0 0   0 0   if (wantarray) {
2272 0           my @glob = _DOS_like_glob(@_);
2273 0           for my $glob (@glob) {
2274 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2275             }
2276 0           return @glob;
2277             }
2278             else {
2279 0           my $glob = _DOS_like_glob(@_);
2280 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2281 0           return $glob;
2282             }
2283             }
2284              
2285             #
2286             # Latin-7 path globbing (without parameter)
2287             #
2288             sub Elatin7::glob_() {
2289              
2290 0 0   0 0   if (wantarray) {
2291 0           my @glob = _DOS_like_glob();
2292 0           for my $glob (@glob) {
2293 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2294             }
2295 0           return @glob;
2296             }
2297             else {
2298 0           my $glob = _DOS_like_glob();
2299 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2300 0           return $glob;
2301             }
2302             }
2303              
2304             #
2305             # Latin-7 path globbing via File::DosGlob 1.10
2306             #
2307             # Often I confuse "_dosglob" and "_doglob".
2308             # So, I renamed "_dosglob" to "_DOS_like_glob".
2309             #
2310             my %iter;
2311             my %entries;
2312             sub _DOS_like_glob {
2313              
2314             # context (keyed by second cxix argument provided by core)
2315 0     0     my($expr,$cxix) = @_;
2316              
2317             # glob without args defaults to $_
2318 0 0         $expr = $_ if not defined $expr;
2319              
2320             # represents the current user's home directory
2321             #
2322             # 7.3. Expanding Tildes in Filenames
2323             # in Chapter 7. File Access
2324             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2325             #
2326             # and File::HomeDir, File::HomeDir::Windows module
2327              
2328             # DOS-like system
2329 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2330 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2331 0           { my_home_MSWin32() }oxmse;
2332             }
2333              
2334             # UNIX-like system
2335             else {
2336 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2337 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2338             }
2339              
2340             # assume global context if not provided one
2341 0 0         $cxix = '_G_' if not defined $cxix;
2342 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2343              
2344             # if we're just beginning, do it all first
2345 0 0         if ($iter{$cxix} == 0) {
2346 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2347             }
2348              
2349             # chuck it all out, quick or slow
2350 0 0         if (wantarray) {
2351 0           delete $iter{$cxix};
2352 0           return @{delete $entries{$cxix}};
  0            
2353             }
2354             else {
2355 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2356 0           return shift @{$entries{$cxix}};
  0            
2357             }
2358             else {
2359             # return undef for EOL
2360 0           delete $iter{$cxix};
2361 0           delete $entries{$cxix};
2362 0           return undef;
2363             }
2364             }
2365             }
2366              
2367             #
2368             # Latin-7 path globbing subroutine
2369             #
2370             sub _do_glob {
2371              
2372 0     0     my($cond,@expr) = @_;
2373 0           my @glob = ();
2374 0           my $fix_drive_relative_paths = 0;
2375              
2376             OUTER:
2377 0           for my $expr (@expr) {
2378 0 0         next OUTER if not defined $expr;
2379 0 0         next OUTER if $expr eq '';
2380              
2381 0           my @matched = ();
2382 0           my @globdir = ();
2383 0           my $head = '.';
2384 0           my $pathsep = '/';
2385 0           my $tail;
2386              
2387             # if argument is within quotes strip em and do no globbing
2388 0 0         if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2389 0           $expr = $1;
2390 0 0         if ($cond eq 'd') {
2391 0 0         if (-d $expr) {
2392 0           push @glob, $expr;
2393             }
2394             }
2395             else {
2396 0 0         if (-e $expr) {
2397 0           push @glob, $expr;
2398             }
2399             }
2400 0           next OUTER;
2401             }
2402              
2403             # wildcards with a drive prefix such as h:*.pm must be changed
2404             # to h:./*.pm to expand correctly
2405 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2406 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2407 0           $fix_drive_relative_paths = 1;
2408             }
2409             }
2410              
2411 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2412 0 0         if ($tail eq '') {
2413 0           push @glob, $expr;
2414 0           next OUTER;
2415             }
2416 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2417 0 0         if (@globdir = _do_glob('d', $head)) {
2418 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2419 0           next OUTER;
2420             }
2421             }
2422 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2423 0           $head .= $pathsep;
2424             }
2425 0           $expr = $tail;
2426             }
2427              
2428             # If file component has no wildcards, we can avoid opendir
2429 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2430 0 0         if ($head eq '.') {
2431 0           $head = '';
2432             }
2433 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2434 0           $head .= $pathsep;
2435             }
2436 0           $head .= $expr;
2437 0 0         if ($cond eq 'd') {
2438 0 0         if (-d $head) {
2439 0           push @glob, $head;
2440             }
2441             }
2442             else {
2443 0 0         if (-e $head) {
2444 0           push @glob, $head;
2445             }
2446             }
2447 0           next OUTER;
2448             }
2449 0 0         opendir(*DIR, $head) or next OUTER;
2450 0           my @leaf = readdir DIR;
2451 0           closedir DIR;
2452              
2453 0 0         if ($head eq '.') {
2454 0           $head = '';
2455             }
2456 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2457 0           $head .= $pathsep;
2458             }
2459              
2460 0           my $pattern = '';
2461 0           while ($expr =~ / \G ($q_char) /oxgc) {
2462 0           my $char = $1;
2463              
2464             # 6.9. Matching Shell Globs as Regular Expressions
2465             # in Chapter 6. Pattern Matching
2466             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2467             # (and so on)
2468              
2469 0 0         if ($char eq '*') {
    0          
    0          
2470 0           $pattern .= "(?:$your_char)*",
2471             }
2472             elsif ($char eq '?') {
2473 0           $pattern .= "(?:$your_char)?", # DOS style
2474             # $pattern .= "(?:$your_char)", # UNIX style
2475             }
2476             elsif ((my $fc = Elatin7::fc($char)) ne $char) {
2477 0           $pattern .= $fc;
2478             }
2479             else {
2480 0           $pattern .= quotemeta $char;
2481             }
2482             }
2483 0     0     my $matchsub = sub { Elatin7::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2484              
2485             # if ($@) {
2486             # print STDERR "$0: $@\n";
2487             # next OUTER;
2488             # }
2489              
2490             INNER:
2491 0           for my $leaf (@leaf) {
2492 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2493 0           next INNER;
2494             }
2495 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2496 0           next INNER;
2497             }
2498              
2499 0 0         if (&$matchsub($leaf)) {
2500 0           push @matched, "$head$leaf";
2501 0           next INNER;
2502             }
2503              
2504             # [DOS compatibility special case]
2505             # Failed, add a trailing dot and try again, but only...
2506              
2507 0 0 0       if (Elatin7::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2508             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2509             Elatin7::index($pattern,'\\.') != -1 # pattern has a dot.
2510             ) {
2511 0 0         if (&$matchsub("$leaf.")) {
2512 0           push @matched, "$head$leaf";
2513 0           next INNER;
2514             }
2515             }
2516             }
2517 0 0         if (@matched) {
2518 0           push @glob, @matched;
2519             }
2520             }
2521 0 0         if ($fix_drive_relative_paths) {
2522 0           for my $glob (@glob) {
2523 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2524             }
2525             }
2526 0           return @glob;
2527             }
2528              
2529             #
2530             # Latin-7 parse line
2531             #
2532             sub _parse_line {
2533              
2534 0     0     my($line) = @_;
2535              
2536 0           $line .= ' ';
2537 0           my @piece = ();
2538 0           while ($line =~ /
2539             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2540             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2541             /oxmsg
2542             ) {
2543 0 0         push @piece, defined($1) ? $1 : $2;
2544             }
2545 0           return @piece;
2546             }
2547              
2548             #
2549             # Latin-7 parse path
2550             #
2551             sub _parse_path {
2552              
2553 0     0     my($path,$pathsep) = @_;
2554              
2555 0           $path .= '/';
2556 0           my @subpath = ();
2557 0           while ($path =~ /
2558             ((?: [^\/\\] )+?) [\/\\]
2559             /oxmsg
2560             ) {
2561 0           push @subpath, $1;
2562             }
2563              
2564 0           my $tail = pop @subpath;
2565 0           my $head = join $pathsep, @subpath;
2566 0           return $head, $tail;
2567             }
2568              
2569             #
2570             # via File::HomeDir::Windows 1.00
2571             #
2572             sub my_home_MSWin32 {
2573              
2574             # A lot of unix people and unix-derived tools rely on
2575             # the ability to overload HOME. We will support it too
2576             # so that they can replace raw HOME calls with File::HomeDir.
2577 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2578 0           return $ENV{'HOME'};
2579             }
2580              
2581             # Do we have a user profile?
2582             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2583 0           return $ENV{'USERPROFILE'};
2584             }
2585              
2586             # Some Windows use something like $ENV{'HOME'}
2587             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2588 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2589             }
2590              
2591 0           return undef;
2592             }
2593              
2594             #
2595             # via File::HomeDir::Unix 1.00
2596             #
2597             sub my_home {
2598 0     0 0   my $home;
2599              
2600 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2601 0           $home = $ENV{'HOME'};
2602             }
2603              
2604             # This is from the original code, but I'm guessing
2605             # it means "login directory" and exists on some Unixes.
2606             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2607 0           $home = $ENV{'LOGDIR'};
2608             }
2609              
2610             ### More-desperate methods
2611              
2612             # Light desperation on any (Unixish) platform
2613             else {
2614 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2615             }
2616              
2617             # On Unix in general, a non-existant home means "no home"
2618             # For example, "nobody"-like users might use /nonexistant
2619 0 0 0       if (defined $home and ! -d($home)) {
2620 0           $home = undef;
2621             }
2622 0           return $home;
2623             }
2624              
2625             #
2626             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2627             #
2628             sub Elatin7::PREMATCH {
2629 0     0 0   return $`;
2630             }
2631              
2632             #
2633             # ${^MATCH}, $MATCH, $& the string that matched
2634             #
2635             sub Elatin7::MATCH {
2636 0     0 0   return $&;
2637             }
2638              
2639             #
2640             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2641             #
2642             sub Elatin7::POSTMATCH {
2643 0     0 0   return $';
2644             }
2645              
2646             #
2647             # Latin-7 character to order (with parameter)
2648             #
2649             sub Latin7::ord(;$) {
2650              
2651 0 0   0 1   local $_ = shift if @_;
2652              
2653 0 0         if (/\A ($q_char) /oxms) {
2654 0           my @ord = unpack 'C*', $1;
2655 0           my $ord = 0;
2656 0           while (my $o = shift @ord) {
2657 0           $ord = $ord * 0x100 + $o;
2658             }
2659 0           return $ord;
2660             }
2661             else {
2662 0           return CORE::ord $_;
2663             }
2664             }
2665              
2666             #
2667             # Latin-7 character to order (without parameter)
2668             #
2669             sub Latin7::ord_() {
2670              
2671 0 0   0 0   if (/\A ($q_char) /oxms) {
2672 0           my @ord = unpack 'C*', $1;
2673 0           my $ord = 0;
2674 0           while (my $o = shift @ord) {
2675 0           $ord = $ord * 0x100 + $o;
2676             }
2677 0           return $ord;
2678             }
2679             else {
2680 0           return CORE::ord $_;
2681             }
2682             }
2683              
2684             #
2685             # Latin-7 reverse
2686             #
2687             sub Latin7::reverse(@) {
2688              
2689 0 0   0 0   if (wantarray) {
2690 0           return CORE::reverse @_;
2691             }
2692             else {
2693              
2694             # One of us once cornered Larry in an elevator and asked him what
2695             # problem he was solving with this, but he looked as far off into
2696             # the distance as he could in an elevator and said, "It seemed like
2697             # a good idea at the time."
2698              
2699 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2700             }
2701             }
2702              
2703             #
2704             # Latin-7 getc (with parameter, without parameter)
2705             #
2706             sub Latin7::getc(;*@) {
2707              
2708 0     0 0   my($package) = caller;
2709 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2710 0 0 0       croak 'Too many arguments for Latin7::getc' if @_ and not wantarray;
2711              
2712 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2713 0           my $getc = '';
2714 0           for my $length ($length[0] .. $length[-1]) {
2715 0           $getc .= CORE::getc($fh);
2716 0 0         if (exists $range_tr{CORE::length($getc)}) {
2717 0 0         if ($getc =~ /\A ${Elatin7::dot_s} \z/oxms) {
2718 0 0         return wantarray ? ($getc,@_) : $getc;
2719             }
2720             }
2721             }
2722 0 0         return wantarray ? ($getc,@_) : $getc;
2723             }
2724              
2725             #
2726             # Latin-7 length by character
2727             #
2728             sub Latin7::length(;$) {
2729              
2730 0 0   0 1   local $_ = shift if @_;
2731              
2732 0           local @_ = /\G ($q_char) /oxmsg;
2733 0           return scalar @_;
2734             }
2735              
2736             #
2737             # Latin-7 substr by character
2738             #
2739             BEGIN {
2740              
2741             # P.232 The lvalue Attribute
2742             # in Chapter 6: Subroutines
2743             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2744              
2745             # P.336 The lvalue Attribute
2746             # in Chapter 7: Subroutines
2747             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2748              
2749             # P.144 8.4 Lvalue subroutines
2750             # in Chapter 8: perlsub: Perl subroutines
2751             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2752              
2753 200 50 0 200 1 145281 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0      
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
2754             # vv----------------------*******
2755             sub Latin7::substr($$;$$) %s {
2756              
2757             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2758              
2759             # If the substring is beyond either end of the string, substr() returns the undefined
2760             # value and produces a warning. When used as an lvalue, specifying a substring that
2761             # is entirely outside the string raises an exception.
2762             # http://perldoc.perl.org/functions/substr.html
2763              
2764             # A return with no argument returns the scalar value undef in scalar context,
2765             # an empty list () in list context, and (naturally) nothing at all in void
2766             # context.
2767              
2768             my $offset = $_[1];
2769             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2770             return;
2771             }
2772              
2773             # substr($string,$offset,$length,$replacement)
2774             if (@_ == 4) {
2775             my(undef,undef,$length,$replacement) = @_;
2776             my $substr = join '', splice(@char, $offset, $length, $replacement);
2777             $_[0] = join '', @char;
2778              
2779             # return $substr; this doesn't work, don't say "return"
2780             $substr;
2781             }
2782              
2783             # substr($string,$offset,$length)
2784             elsif (@_ == 3) {
2785             my(undef,undef,$length) = @_;
2786             my $octet_offset = 0;
2787             my $octet_length = 0;
2788             if ($offset == 0) {
2789             $octet_offset = 0;
2790             }
2791             elsif ($offset > 0) {
2792             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2793             }
2794             else {
2795             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2796             }
2797             if ($length == 0) {
2798             $octet_length = 0;
2799             }
2800             elsif ($length > 0) {
2801             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2802             }
2803             else {
2804             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2805             }
2806             CORE::substr($_[0], $octet_offset, $octet_length);
2807             }
2808              
2809             # substr($string,$offset)
2810             else {
2811             my $octet_offset = 0;
2812             if ($offset == 0) {
2813             $octet_offset = 0;
2814             }
2815             elsif ($offset > 0) {
2816             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2817             }
2818             else {
2819             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2820             }
2821             CORE::substr($_[0], $octet_offset);
2822             }
2823             }
2824             END
2825             }
2826              
2827             #
2828             # Latin-7 index by character
2829             #
2830             sub Latin7::index($$;$) {
2831              
2832 0     0 1   my $index;
2833 0 0         if (@_ == 3) {
2834 0           $index = Elatin7::index($_[0], $_[1], CORE::length(Latin7::substr($_[0], 0, $_[2])));
2835             }
2836             else {
2837 0           $index = Elatin7::index($_[0], $_[1]);
2838             }
2839              
2840 0 0         if ($index == -1) {
2841 0           return -1;
2842             }
2843             else {
2844 0           return Latin7::length(CORE::substr $_[0], 0, $index);
2845             }
2846             }
2847              
2848             #
2849             # Latin-7 rindex by character
2850             #
2851             sub Latin7::rindex($$;$) {
2852              
2853 0     0 1   my $rindex;
2854 0 0         if (@_ == 3) {
2855 0           $rindex = Elatin7::rindex($_[0], $_[1], CORE::length(Latin7::substr($_[0], 0, $_[2])));
2856             }
2857             else {
2858 0           $rindex = Elatin7::rindex($_[0], $_[1]);
2859             }
2860              
2861 0 0         if ($rindex == -1) {
2862 0           return -1;
2863             }
2864             else {
2865 0           return Latin7::length(CORE::substr $_[0], 0, $rindex);
2866             }
2867             }
2868              
2869             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2870             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2871 200     200   18844 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   2094  
  200         521  
  200         16798  
2872              
2873             # ord() to ord() or Latin7::ord()
2874 200     200   15436 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1202  
  200         400  
  200         14453  
2875              
2876             # ord to ord or Latin7::ord_
2877 200     200   15241 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   1131  
  200         373  
  200         12735  
2878              
2879             # reverse to reverse or Latin7::reverse
2880 200     200   14346 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1146  
  200         410  
  200         14440  
2881              
2882             # getc to getc or Latin7::getc
2883 200     200   14688 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   1113  
  200         364  
  200         20439  
2884              
2885             # P.1023 Appendix W.9 Multibyte Anchoring
2886             # of ISBN 1-56592-224-7 CJKV Information Processing
2887              
2888             my $anchor = '';
2889              
2890 200     200   14536 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   1175  
  200         385  
  200         12465753  
2891              
2892             # regexp of nested parens in qqXX
2893              
2894             # P.340 Matching Nested Constructs with Embedded Code
2895             # in Chapter 7: Perl
2896             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2897              
2898             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2899             [^\\()] |
2900             \( (?{$nest++}) |
2901             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2902             \\ [^c] |
2903             \\c[\x40-\x5F] |
2904             [\x00-\xFF]
2905             }xms;
2906              
2907             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2908             [^\\{}] |
2909             \{ (?{$nest++}) |
2910             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2911             \\ [^c] |
2912             \\c[\x40-\x5F] |
2913             [\x00-\xFF]
2914             }xms;
2915              
2916             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2917             [^\\\[\]] |
2918             \[ (?{$nest++}) |
2919             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2920             \\ [^c] |
2921             \\c[\x40-\x5F] |
2922             [\x00-\xFF]
2923             }xms;
2924              
2925             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2926             [^\\<>] |
2927             \< (?{$nest++}) |
2928             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2929             \\ [^c] |
2930             \\c[\x40-\x5F] |
2931             [\x00-\xFF]
2932             }xms;
2933              
2934             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2935             (?: ::)? (?:
2936             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2937             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2938             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2939             ))
2940             }xms;
2941              
2942             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2943             (?: ::)? (?:
2944             (?>[0-9]+) |
2945             [^a-zA-Z_0-9\[\]] |
2946             ^[A-Z] |
2947             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2948             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2949             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2950             ))
2951             }xms;
2952              
2953             my $qq_substr = qr{(?> Char::substr | Latin7::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2954             }xms;
2955              
2956             # regexp of nested parens in qXX
2957             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2958             [^()] |
2959             \( (?{$nest++}) |
2960             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2961             [\x00-\xFF]
2962             }xms;
2963              
2964             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2965             [^\{\}] |
2966             \{ (?{$nest++}) |
2967             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2968             [\x00-\xFF]
2969             }xms;
2970              
2971             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2972             [^\[\]] |
2973             \[ (?{$nest++}) |
2974             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2975             [\x00-\xFF]
2976             }xms;
2977              
2978             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2979             [^<>] |
2980             \< (?{$nest++}) |
2981             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2982             [\x00-\xFF]
2983             }xms;
2984              
2985             my $matched = '';
2986             my $s_matched = '';
2987              
2988             my $tr_variable = ''; # variable of tr///
2989             my $sub_variable = ''; # variable of s///
2990             my $bind_operator = ''; # =~ or !~
2991              
2992             my @heredoc = (); # here document
2993             my @heredoc_delimiter = ();
2994             my $here_script = ''; # here script
2995              
2996             #
2997             # escape Latin-7 script
2998             #
2999             sub Latin7::escape(;$) {
3000 0 0   0 0   local($_) = $_[0] if @_;
3001              
3002             # P.359 The Study Function
3003             # in Chapter 7: Perl
3004             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3005              
3006 0           study $_; # Yes, I studied study yesterday.
3007              
3008             # while all script
3009              
3010             # 6.14. Matching from Where the Last Pattern Left Off
3011             # in Chapter 6. Pattern Matching
3012             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3013             # (and so on)
3014              
3015             # one member of Tag-team
3016             #
3017             # P.128 Start of match (or end of previous match): \G
3018             # P.130 Advanced Use of \G with Perl
3019             # in Chapter 3: Overview of Regular Expression Features and Flavors
3020             # P.255 Use leading anchors
3021             # P.256 Expose ^ and \G at the front expressions
3022             # in Chapter 6: Crafting an Efficient Expression
3023             # P.315 "Tag-team" matching with /gc
3024             # in Chapter 7: Perl
3025             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3026              
3027 0           my $e_script = '';
3028 0           while (not /\G \z/oxgc) { # member
3029 0           $e_script .= Latin7::escape_token();
3030             }
3031              
3032 0           return $e_script;
3033             }
3034              
3035             #
3036             # escape Latin-7 token of script
3037             #
3038             sub Latin7::escape_token {
3039              
3040             # \n output here document
3041              
3042 0     0 0   my $ignore_modules = join('|', qw(
3043             utf8
3044             bytes
3045             charnames
3046             I18N::Japanese
3047             I18N::Collate
3048             I18N::JExt
3049             File::DosGlob
3050             Wild
3051             Wildcard
3052             Japanese
3053             ));
3054              
3055             # another member of Tag-team
3056             #
3057             # P.315 "Tag-team" matching with /gc
3058             # in Chapter 7: Perl
3059             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3060              
3061 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3062 0           my $heredoc = '';
3063 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3064 0           $slash = 'm//';
3065              
3066 0           $heredoc = join '', @heredoc;
3067 0           @heredoc = ();
3068              
3069             # skip here document
3070 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3071 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3072             }
3073 0           @heredoc_delimiter = ();
3074              
3075 0           $here_script = '';
3076             }
3077 0           return "\n" . $heredoc;
3078             }
3079              
3080             # ignore space, comment
3081 0           elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3082              
3083             # if (, elsif (, unless (, while (, until (, given (, and when (
3084              
3085             # given, when
3086              
3087             # P.225 The given Statement
3088             # in Chapter 15: Smart Matching and given-when
3089             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3090              
3091             # P.133 The given Statement
3092             # in Chapter 4: Statements and Declarations
3093             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3094              
3095             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3096 0           $slash = 'm//';
3097 0           return $1;
3098             }
3099              
3100             # scalar variable ($scalar = ...) =~ tr///;
3101             # scalar variable ($scalar = ...) =~ s///;
3102              
3103             # state
3104              
3105             # P.68 Persistent, Private Variables
3106             # in Chapter 4: Subroutines
3107             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3108              
3109             # P.160 Persistent Lexically Scoped Variables: state
3110             # in Chapter 4: Statements and Declarations
3111             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3112              
3113             # (and so on)
3114              
3115             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3116 0           my $e_string = e_string($1);
3117              
3118 0 0         if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3119 0           $tr_variable = $e_string . e_string($1);
3120 0           $bind_operator = $2;
3121 0           $slash = 'm//';
3122 0           return '';
3123             }
3124             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3125 0           $sub_variable = $e_string . e_string($1);
3126 0           $bind_operator = $2;
3127 0           $slash = 'm//';
3128 0           return '';
3129             }
3130             else {
3131 0           $slash = 'div';
3132 0           return $e_string;
3133             }
3134             }
3135              
3136             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
3137             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3138 0           $slash = 'div';
3139 0           return q{Elatin7::PREMATCH()};
3140             }
3141              
3142             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
3143             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3144 0           $slash = 'div';
3145 0           return q{Elatin7::MATCH()};
3146             }
3147              
3148             # $', ${'} --> $', ${'}
3149             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3150 0           $slash = 'div';
3151 0           return $1;
3152             }
3153              
3154             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
3155             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3156 0           $slash = 'div';
3157 0           return q{Elatin7::POSTMATCH()};
3158             }
3159              
3160             # scalar variable $scalar =~ tr///;
3161             # scalar variable $scalar =~ s///;
3162             # substr() =~ tr///;
3163             # substr() =~ s///;
3164             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3165 0           my $scalar = e_string($1);
3166              
3167 0 0         if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3168 0           $tr_variable = $scalar;
3169 0           $bind_operator = $1;
3170 0           $slash = 'm//';
3171 0           return '';
3172             }
3173             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3174 0           $sub_variable = $scalar;
3175 0           $bind_operator = $1;
3176 0           $slash = 'm//';
3177 0           return '';
3178             }
3179             else {
3180 0           $slash = 'div';
3181 0           return $scalar;
3182             }
3183             }
3184              
3185             # end of statement
3186             elsif (/\G ( [,;] ) /oxgc) {
3187 0           $slash = 'm//';
3188              
3189             # clear tr/// variable
3190 0           $tr_variable = '';
3191              
3192             # clear s/// variable
3193 0           $sub_variable = '';
3194              
3195 0           $bind_operator = '';
3196              
3197 0           return $1;
3198             }
3199              
3200             # bareword
3201             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3202 0           return $1;
3203             }
3204              
3205             # $0 --> $0
3206             elsif (/\G ( \$ 0 ) /oxmsgc) {
3207 0           $slash = 'div';
3208 0           return $1;
3209             }
3210             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3211 0           $slash = 'div';
3212 0           return $1;
3213             }
3214              
3215             # $$ --> $$
3216             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3217 0           $slash = 'div';
3218 0           return $1;
3219             }
3220              
3221             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3222             # $1, $2, $3 --> $1, $2, $3 otherwise
3223             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3224 0           $slash = 'div';
3225 0           return e_capture($1);
3226             }
3227             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3228 0           $slash = 'div';
3229 0           return e_capture($1);
3230             }
3231              
3232             # $$foo[ ... ] --> $ $foo->[ ... ]
3233             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3234 0           $slash = 'div';
3235 0           return e_capture($1.'->'.$2);
3236             }
3237              
3238             # $$foo{ ... } --> $ $foo->{ ... }
3239             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3240 0           $slash = 'div';
3241 0           return e_capture($1.'->'.$2);
3242             }
3243              
3244             # $$foo
3245             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3246 0           $slash = 'div';
3247 0           return e_capture($1);
3248             }
3249              
3250             # ${ foo }
3251             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3252 0           $slash = 'div';
3253 0           return '${' . $1 . '}';
3254             }
3255              
3256             # ${ ... }
3257             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3258 0           $slash = 'div';
3259 0           return e_capture($1);
3260             }
3261              
3262             # variable or function
3263             # $ @ % & * $ #
3264             elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
3265 0           $slash = 'div';
3266 0           return $1;
3267             }
3268             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3269             # $ @ # \ ' " / ? ( ) [ ] < >
3270             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3271 0           $slash = 'div';
3272 0           return $1;
3273             }
3274              
3275             # while ()
3276             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3277 0           return $1;
3278             }
3279              
3280             # while () --- glob
3281              
3282             # avoid "Error: Runtime exception" of perl version 5.005_03
3283              
3284             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3285 0           return 'while ($_ = Elatin7::glob("' . $1 . '"))';
3286             }
3287              
3288             # while (glob)
3289             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3290 0           return 'while ($_ = Elatin7::glob_)';
3291             }
3292              
3293             # while (glob(WILDCARD))
3294             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3295 0           return 'while ($_ = Elatin7::glob';
3296             }
3297              
3298             # doit if, doit unless, doit while, doit until, doit for, doit when
3299 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3300              
3301             # subroutines of package Elatin7
3302 0           elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3303 0           elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3304 0           elsif (/\G \b Latin7::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3305 0           elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0            
3306 0           elsif (/\G \b Latin7::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin7::escape'; }
  0            
3307 0           elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3308 0           elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::chop'; }
  0            
3309 0           elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3310 0           elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0            
3311 0           elsif (/\G \b Latin7::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin7::index'; }
  0            
3312 0           elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::index'; }
  0            
3313 0           elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3314 0           elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0            
3315 0           elsif (/\G \b Latin7::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin7::rindex'; }
  0            
3316 0           elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::rindex'; }
  0            
3317 0           elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::lc'; }
  0            
3318 0           elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::lcfirst'; }
  0            
3319 0           elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::uc'; }
  0            
3320 0           elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::ucfirst'; }
  0            
3321 0           elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::fc'; }
  0            
3322              
3323             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3324 0           elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3325 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3326 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3327 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3328 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3329 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3330 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3331              
3332 0           elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3333 0           elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3334 0           elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3335 0           elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3336 0           elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3337 0           elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3338 0           elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3339              
3340             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3341 0           { $slash = 'm//'; return "-s $1"; }
  0            
3342 0           elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3343 0           elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3344 0           elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3345              
3346 0           elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3347 0           elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3348 0           elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::chr'; }
  0            
3349 0           elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3350 0           elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3351 0           elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin7::glob'; }
  0            
3352 0           elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::lc_'; }
  0            
3353 0           elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::lcfirst_'; }
  0            
3354 0           elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::uc_'; }
  0            
3355 0           elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::ucfirst_'; }
  0            
3356 0           elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::fc_'; }
  0            
3357 0           elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3358              
3359 0           elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3360 0           elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3361 0           elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::chr_'; }
  0            
3362 0           elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3363 0           elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3364 0           elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin7::glob_'; }
  0            
3365 0           elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3366 0           elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3367             # split
3368             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3369 0           $slash = 'm//';
3370              
3371 0           my $e = '';
3372 0           while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3373 0           $e .= $1;
3374             }
3375              
3376             # end of split
3377 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin7::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3378              
3379             # split scalar value
3380 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin7::split' . $e . e_string($1); }
3381              
3382             # split literal space
3383 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin7::split' . $e . qq {qq$1 $2}; }
3384 0           elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3385 0           elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3386 0           elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3387 0           elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3388 0           elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin7::split' . $e . qq{$1qq$2 $3}; }
3389 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin7::split' . $e . qq {q$1 $2}; }
3390 0           elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3391 0           elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3392 0           elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3393 0           elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3394 0           elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin7::split' . $e . qq {$1q$2 $3}; }
3395 0           elsif (/\G ' [ ] ' /oxgc) { return 'Elatin7::split' . $e . qq {' '}; }
3396 0           elsif (/\G " [ ] " /oxgc) { return 'Elatin7::split' . $e . qq {" "}; }
3397              
3398             # split qq//
3399             elsif (/\G \b (qq) \b /oxgc) {
3400 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3401             else {
3402 0           while (not /\G \z/oxgc) {
3403 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3404 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3405 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3406 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3407 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3408 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3409 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3410             }
3411 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3412             }
3413             }
3414              
3415             # split qr//
3416             elsif (/\G \b (qr) \b /oxgc) {
3417 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3418             else {
3419 0           while (not /\G \z/oxgc) {
3420 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3421 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3422 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3423 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3424 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3425 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3426 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3427 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3428             }
3429 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3430             }
3431             }
3432              
3433             # split q//
3434             elsif (/\G \b (q) \b /oxgc) {
3435 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3436             else {
3437 0           while (not /\G \z/oxgc) {
3438 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3439 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3440 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3441 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3442 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3443 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3444 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3445             }
3446 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3447             }
3448             }
3449              
3450             # split m//
3451             elsif (/\G \b (m) \b /oxgc) {
3452 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3453             else {
3454 0           while (not /\G \z/oxgc) {
3455 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3456 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3457 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3458 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3459 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3460 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3461 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3462 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3463             }
3464 0           die __FILE__, ": Search pattern not terminated\n";
3465             }
3466             }
3467              
3468             # split ''
3469             elsif (/\G (\') /oxgc) {
3470 0           my $q_string = '';
3471 0           while (not /\G \z/oxgc) {
3472 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3473 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3474 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3475 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3476             }
3477 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3478             }
3479              
3480             # split ""
3481             elsif (/\G (\") /oxgc) {
3482 0           my $qq_string = '';
3483 0           while (not /\G \z/oxgc) {
3484 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3485 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3486 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3487 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3488             }
3489 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3490             }
3491              
3492             # split //
3493             elsif (/\G (\/) /oxgc) {
3494 0           my $regexp = '';
3495 0           while (not /\G \z/oxgc) {
3496 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3497 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3498 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3499 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3500             }
3501 0           die __FILE__, ": Search pattern not terminated\n";
3502             }
3503             }
3504              
3505             # tr/// or y///
3506              
3507             # about [cdsrbB]* (/B modifier)
3508             #
3509             # P.559 appendix C
3510             # of ISBN 4-89052-384-7 Programming perl
3511             # (Japanese title is: Perl puroguramingu)
3512              
3513             elsif (/\G \b ( tr | y ) \b /oxgc) {
3514 0           my $ope = $1;
3515              
3516             # $1 $2 $3 $4 $5 $6
3517 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3518 0           my @tr = ($tr_variable,$2);
3519 0           return e_tr(@tr,'',$4,$6);
3520             }
3521             else {
3522 0           my $e = '';
3523 0           while (not /\G \z/oxgc) {
3524 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3525             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3526 0           my @tr = ($tr_variable,$2);
3527 0           while (not /\G \z/oxgc) {
3528 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3529 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3530 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3531 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3532 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3533 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3534             }
3535 0           die __FILE__, ": Transliteration replacement not terminated\n";
3536             }
3537             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3538 0           my @tr = ($tr_variable,$2);
3539 0           while (not /\G \z/oxgc) {
3540 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3541 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3542 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3543 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3544 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3545 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3546             }
3547 0           die __FILE__, ": Transliteration replacement not terminated\n";
3548             }
3549             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3550 0           my @tr = ($tr_variable,$2);
3551 0           while (not /\G \z/oxgc) {
3552 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3553 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3554 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3555 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3556 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3557 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3558             }
3559 0           die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3562 0           my @tr = ($tr_variable,$2);
3563 0           while (not /\G \z/oxgc) {
3564 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3565 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3566 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3567 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3568 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3569 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3570             }
3571 0           die __FILE__, ": Transliteration replacement not terminated\n";
3572             }
3573             # $1 $2 $3 $4 $5 $6
3574             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3575 0           my @tr = ($tr_variable,$2);
3576 0           return e_tr(@tr,'',$4,$6);
3577             }
3578             }
3579 0           die __FILE__, ": Transliteration pattern not terminated\n";
3580             }
3581             }
3582              
3583             # qq//
3584             elsif (/\G \b (qq) \b /oxgc) {
3585 0           my $ope = $1;
3586              
3587             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3588 0 0         if (/\G (\#) /oxgc) { # qq# #
3589 0           my $qq_string = '';
3590 0           while (not /\G \z/oxgc) {
3591 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3592 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3593 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3594 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3595             }
3596 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3597             }
3598              
3599             else {
3600 0           my $e = '';
3601 0           while (not /\G \z/oxgc) {
3602 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3603              
3604             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3605             elsif (/\G (\() /oxgc) { # qq ( )
3606 0           my $qq_string = '';
3607 0           local $nest = 1;
3608 0           while (not /\G \z/oxgc) {
3609 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3610 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3611 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3612             elsif (/\G (\)) /oxgc) {
3613 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3614 0           else { $qq_string .= $1; }
3615             }
3616 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3617             }
3618 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3619             }
3620              
3621             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3622             elsif (/\G (\{) /oxgc) { # qq { }
3623 0           my $qq_string = '';
3624 0           local $nest = 1;
3625 0           while (not /\G \z/oxgc) {
3626 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3627 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3628 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3629             elsif (/\G (\}) /oxgc) {
3630 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3631 0           else { $qq_string .= $1; }
3632             }
3633 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3634             }
3635 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3636             }
3637              
3638             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3639             elsif (/\G (\[) /oxgc) { # qq [ ]
3640 0           my $qq_string = '';
3641 0           local $nest = 1;
3642 0           while (not /\G \z/oxgc) {
3643 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3644 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3645 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3646             elsif (/\G (\]) /oxgc) {
3647 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3648 0           else { $qq_string .= $1; }
3649             }
3650 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3651             }
3652 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3653             }
3654              
3655             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3656             elsif (/\G (\<) /oxgc) { # qq < >
3657 0           my $qq_string = '';
3658 0           local $nest = 1;
3659 0           while (not /\G \z/oxgc) {
3660 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3661 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3662 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3663             elsif (/\G (\>) /oxgc) {
3664 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3665 0           else { $qq_string .= $1; }
3666             }
3667 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3668             }
3669 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3670             }
3671              
3672             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3673             elsif (/\G (\S) /oxgc) { # qq * *
3674 0           my $delimiter = $1;
3675 0           my $qq_string = '';
3676 0           while (not /\G \z/oxgc) {
3677 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3678 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3679 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3680 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3681             }
3682 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3683             }
3684             }
3685 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686             }
3687             }
3688              
3689             # qr//
3690             elsif (/\G \b (qr) \b /oxgc) {
3691 0           my $ope = $1;
3692 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3693 0           return e_qr($ope,$1,$3,$2,$4);
3694             }
3695             else {
3696 0           my $e = '';
3697 0           while (not /\G \z/oxgc) {
3698 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3699 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3700 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3701 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3702 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3703 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3704 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3705 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3706             }
3707 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3708             }
3709             }
3710              
3711             # qw//
3712             elsif (/\G \b (qw) \b /oxgc) {
3713 0           my $ope = $1;
3714 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3715 0           return e_qw($ope,$1,$3,$2);
3716             }
3717             else {
3718 0           my $e = '';
3719 0           while (not /\G \z/oxgc) {
3720 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3721              
3722 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3723 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3724              
3725 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3726 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3727              
3728 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3729 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3730              
3731 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3732 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3733              
3734 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3735 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3736             }
3737 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3738             }
3739             }
3740              
3741             # qx//
3742             elsif (/\G \b (qx) \b /oxgc) {
3743 0           my $ope = $1;
3744 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3745 0           return e_qq($ope,$1,$3,$2);
3746             }
3747             else {
3748 0           my $e = '';
3749 0           while (not /\G \z/oxgc) {
3750 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3751 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3752 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3753 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3754 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3755 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3756 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3757             }
3758 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3759             }
3760             }
3761              
3762             # q//
3763             elsif (/\G \b (q) \b /oxgc) {
3764 0           my $ope = $1;
3765              
3766             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3767              
3768             # avoid "Error: Runtime exception" of perl version 5.005_03
3769             # (and so on)
3770              
3771 0 0         if (/\G (\#) /oxgc) { # q# #
3772 0           my $q_string = '';
3773 0           while (not /\G \z/oxgc) {
3774 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3775 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3776 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3777 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3778             }
3779 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3780             }
3781              
3782             else {
3783 0           my $e = '';
3784 0           while (not /\G \z/oxgc) {
3785 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3786              
3787             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3788             elsif (/\G (\() /oxgc) { # q ( )
3789 0           my $q_string = '';
3790 0           local $nest = 1;
3791 0           while (not /\G \z/oxgc) {
3792 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3793 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3794 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3795 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3796             elsif (/\G (\)) /oxgc) {
3797 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3798 0           else { $q_string .= $1; }
3799             }
3800 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3801             }
3802 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3803             }
3804              
3805             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3806             elsif (/\G (\{) /oxgc) { # q { }
3807 0           my $q_string = '';
3808 0           local $nest = 1;
3809 0           while (not /\G \z/oxgc) {
3810 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3811 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3812 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3813 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3814             elsif (/\G (\}) /oxgc) {
3815 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3816 0           else { $q_string .= $1; }
3817             }
3818 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3819             }
3820 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3821             }
3822              
3823             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3824             elsif (/\G (\[) /oxgc) { # q [ ]
3825 0           my $q_string = '';
3826 0           local $nest = 1;
3827 0           while (not /\G \z/oxgc) {
3828 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3829 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3830 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3831 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3832             elsif (/\G (\]) /oxgc) {
3833 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3834 0           else { $q_string .= $1; }
3835             }
3836 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3837             }
3838 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3839             }
3840              
3841             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3842             elsif (/\G (\<) /oxgc) { # q < >
3843 0           my $q_string = '';
3844 0           local $nest = 1;
3845 0           while (not /\G \z/oxgc) {
3846 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3847 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3848 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3849 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3850             elsif (/\G (\>) /oxgc) {
3851 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3852 0           else { $q_string .= $1; }
3853             }
3854 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3855             }
3856 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3857             }
3858              
3859             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3860             elsif (/\G (\S) /oxgc) { # q * *
3861 0           my $delimiter = $1;
3862 0           my $q_string = '';
3863 0           while (not /\G \z/oxgc) {
3864 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3865 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3866 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3867 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3868             }
3869 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3870             }
3871             }
3872 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873             }
3874             }
3875              
3876             # m//
3877             elsif (/\G \b (m) \b /oxgc) {
3878 0           my $ope = $1;
3879 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3880 0           return e_qr($ope,$1,$3,$2,$4);
3881             }
3882             else {
3883 0           my $e = '';
3884 0           while (not /\G \z/oxgc) {
3885 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3886 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3887 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3888 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3889 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3890 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3891 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3892 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3893 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3894             }
3895 0           die __FILE__, ": Search pattern not terminated\n";
3896             }
3897             }
3898              
3899             # s///
3900              
3901             # about [cegimosxpradlunbB]* (/cg modifier)
3902             #
3903             # P.67 Pattern-Matching Operators
3904             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3905              
3906             elsif (/\G \b (s) \b /oxgc) {
3907 0           my $ope = $1;
3908              
3909             # $1 $2 $3 $4 $5 $6
3910 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3911 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3912             }
3913             else {
3914 0           my $e = '';
3915 0           while (not /\G \z/oxgc) {
3916 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3917             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3918 0           my @s = ($1,$2,$3);
3919 0           while (not /\G \z/oxgc) {
3920 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3921             # $1 $2 $3 $4
3922 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3923 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931             }
3932 0           die __FILE__, ": Substitution replacement not terminated\n";
3933             }
3934             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3935 0           my @s = ($1,$2,$3);
3936 0           while (not /\G \z/oxgc) {
3937 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3938             # $1 $2 $3 $4
3939 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3940 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3941 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3942 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948             }
3949 0           die __FILE__, ": Substitution replacement not terminated\n";
3950             }
3951             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3952 0           my @s = ($1,$2,$3);
3953 0           while (not /\G \z/oxgc) {
3954 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3955             # $1 $2 $3 $4
3956 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3957 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3958 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3959 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963             }
3964 0           die __FILE__, ": Substitution replacement not terminated\n";
3965             }
3966             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3967 0           my @s = ($1,$2,$3);
3968 0           while (not /\G \z/oxgc) {
3969 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3970             # $1 $2 $3 $4
3971 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3972 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3973 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3974 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980             }
3981 0           die __FILE__, ": Substitution replacement not terminated\n";
3982             }
3983             # $1 $2 $3 $4 $5 $6
3984             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3985 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3986             }
3987             # $1 $2 $3 $4 $5 $6
3988             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3989 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3990             }
3991             # $1 $2 $3 $4 $5 $6
3992             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3993 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3994             }
3995             # $1 $2 $3 $4 $5 $6
3996             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3997 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3998             }
3999             }
4000 0           die __FILE__, ": Substitution pattern not terminated\n";
4001             }
4002             }
4003              
4004             # require ignore module
4005 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4006 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4007 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4008              
4009             # use strict; --> use strict; no strict qw(refs);
4010 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4011 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4012 0           elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4013              
4014             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4015             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4016 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
4017 0           return "use $1; no strict qw(refs);";
4018             }
4019             else {
4020 0           return "use $1;";
4021             }
4022             }
4023             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4024 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4025 0           return "use $1; no strict qw(refs);";
4026             }
4027             else {
4028 0           return "use $1;";
4029             }
4030             }
4031              
4032             # ignore use module
4033 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4034 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4035 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4036              
4037             # ignore no module
4038 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4039 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4040 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4041              
4042             # use else
4043 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4044              
4045             # use else
4046 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4047              
4048             # ''
4049             elsif (/\G (?
4050 0           my $q_string = '';
4051 0           while (not /\G \z/oxgc) {
4052 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4053 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4054 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4055 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4056             }
4057 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4058             }
4059              
4060             # ""
4061             elsif (/\G (\") /oxgc) {
4062 0           my $qq_string = '';
4063 0           while (not /\G \z/oxgc) {
4064 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4065 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4066 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4067 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4068             }
4069 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4070             }
4071              
4072             # ``
4073             elsif (/\G (\`) /oxgc) {
4074 0           my $qx_string = '';
4075 0           while (not /\G \z/oxgc) {
4076 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4077 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4078 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4079 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4080             }
4081 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4082             }
4083              
4084             # // --- not divide operator (num / num), not defined-or
4085             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4086 0           my $regexp = '';
4087 0           while (not /\G \z/oxgc) {
4088 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4089 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4090 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4091 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4092             }
4093 0           die __FILE__, ": Search pattern not terminated\n";
4094             }
4095              
4096             # ?? --- not conditional operator (condition ? then : else)
4097             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4098 0           my $regexp = '';
4099 0           while (not /\G \z/oxgc) {
4100 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4101 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4102 0           elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4103 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4104             }
4105 0           die __FILE__, ": Search pattern not terminated\n";
4106             }
4107              
4108             # <<>> (a safer ARGV)
4109 0           elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4110              
4111             # << (bit shift) --- not here document
4112 0           elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4113              
4114             # <<'HEREDOC'
4115             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4116 0           $slash = 'm//';
4117 0           my $here_quote = $1;
4118 0           my $delimiter = $2;
4119              
4120             # get here document
4121 0 0         if ($here_script eq '') {
4122 0           $here_script = CORE::substr $_, pos $_;
4123 0           $here_script =~ s/.*?\n//oxm;
4124             }
4125 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4126 0           push @heredoc, $1 . qq{\n$delimiter\n};
4127 0           push @heredoc_delimiter, $delimiter;
4128             }
4129             else {
4130 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4131             }
4132 0           return $here_quote;
4133             }
4134              
4135             # <<\HEREDOC
4136              
4137             # P.66 2.6.6. "Here" Documents
4138             # in Chapter 2: Bits and Pieces
4139             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4140              
4141             # P.73 "Here" Documents
4142             # in Chapter 2: Bits and Pieces
4143             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4144              
4145             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4146 0           $slash = 'm//';
4147 0           my $here_quote = $1;
4148 0           my $delimiter = $2;
4149              
4150             # get here document
4151 0 0         if ($here_script eq '') {
4152 0           $here_script = CORE::substr $_, pos $_;
4153 0           $here_script =~ s/.*?\n//oxm;
4154             }
4155 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4156 0           push @heredoc, $1 . qq{\n$delimiter\n};
4157 0           push @heredoc_delimiter, $delimiter;
4158             }
4159             else {
4160 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4161             }
4162 0           return $here_quote;
4163             }
4164              
4165             # <<"HEREDOC"
4166             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4167 0           $slash = 'm//';
4168 0           my $here_quote = $1;
4169 0           my $delimiter = $2;
4170              
4171             # get here document
4172 0 0         if ($here_script eq '') {
4173 0           $here_script = CORE::substr $_, pos $_;
4174 0           $here_script =~ s/.*?\n//oxm;
4175             }
4176 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4177 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4178 0           push @heredoc_delimiter, $delimiter;
4179             }
4180             else {
4181 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4182             }
4183 0           return $here_quote;
4184             }
4185              
4186             # <
4187             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4188 0           $slash = 'm//';
4189 0           my $here_quote = $1;
4190 0           my $delimiter = $2;
4191              
4192             # get here document
4193 0 0         if ($here_script eq '') {
4194 0           $here_script = CORE::substr $_, pos $_;
4195 0           $here_script =~ s/.*?\n//oxm;
4196             }
4197 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4198 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4199 0           push @heredoc_delimiter, $delimiter;
4200             }
4201             else {
4202 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4203             }
4204 0           return $here_quote;
4205             }
4206              
4207             # <<`HEREDOC`
4208             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4209 0           $slash = 'm//';
4210 0           my $here_quote = $1;
4211 0           my $delimiter = $2;
4212              
4213             # get here document
4214 0 0         if ($here_script eq '') {
4215 0           $here_script = CORE::substr $_, pos $_;
4216 0           $here_script =~ s/.*?\n//oxm;
4217             }
4218 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4219 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4220 0           push @heredoc_delimiter, $delimiter;
4221             }
4222             else {
4223 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4224             }
4225 0           return $here_quote;
4226             }
4227              
4228             # <<= <=> <= < operator
4229             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4230 0           return $1;
4231             }
4232              
4233             #
4234             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4235 0           return $1;
4236             }
4237              
4238             # --- glob
4239              
4240             # avoid "Error: Runtime exception" of perl version 5.005_03
4241              
4242             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4243 0           return 'Elatin7::glob("' . $1 . '")';
4244             }
4245              
4246             # __DATA__
4247 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4248              
4249             # __END__
4250 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4251              
4252             # \cD Control-D
4253              
4254             # P.68 2.6.8. Other Literal Tokens
4255             # in Chapter 2: Bits and Pieces
4256             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4257              
4258             # P.76 Other Literal Tokens
4259             # in Chapter 2: Bits and Pieces
4260             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4261              
4262 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4263              
4264             # \cZ Control-Z
4265 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4266              
4267             # any operator before div
4268             elsif (/\G (
4269             -- | \+\+ |
4270             [\)\}\]]
4271              
4272 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4273              
4274             # yada-yada or triple-dot operator
4275             elsif (/\G (
4276             \.\.\.
4277              
4278 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4279              
4280             # any operator before m//
4281              
4282             # //, //= (defined-or)
4283              
4284             # P.164 Logical Operators
4285             # in Chapter 10: More Control Structures
4286             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4287              
4288             # P.119 C-Style Logical (Short-Circuit) Operators
4289             # in Chapter 3: Unary and Binary Operators
4290             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4291              
4292             # (and so on)
4293              
4294             # ~~
4295              
4296             # P.221 The Smart Match Operator
4297             # in Chapter 15: Smart Matching and given-when
4298             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4299              
4300             # P.112 Smartmatch Operator
4301             # in Chapter 3: Unary and Binary Operators
4302             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4303              
4304             # (and so on)
4305              
4306             elsif (/\G ((?>
4307              
4308             !~~ | !~ | != | ! |
4309             %= | % |
4310             &&= | && | &= | &\.= | &\. | & |
4311             -= | -> | - |
4312             :(?>\s*)= |
4313             : |
4314             <<>> |
4315             <<= | <=> | <= | < |
4316             == | => | =~ | = |
4317             >>= | >> | >= | > |
4318             \*\*= | \*\* | \*= | \* |
4319             \+= | \+ |
4320             \.\. | \.= | \. |
4321             \/\/= | \/\/ |
4322             \/= | \/ |
4323             \? |
4324             \\ |
4325             \^= | \^\.= | \^\. | \^ |
4326             \b x= |
4327             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4328             ~~ | ~\. | ~ |
4329             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4330             \b(?: print )\b |
4331              
4332             [,;\(\{\[]
4333              
4334 0           )) /oxgc) { $slash = 'm//'; return $1; }
  0            
4335              
4336             # other any character
4337 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4338              
4339             # system error
4340             else {
4341 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4342             }
4343             }
4344              
4345             # escape Latin-7 string
4346             sub e_string {
4347 0     0 0   my($string) = @_;
4348 0           my $e_string = '';
4349              
4350 0           local $slash = 'm//';
4351              
4352             # P.1024 Appendix W.10 Multibyte Processing
4353             # of ISBN 1-56592-224-7 CJKV Information Processing
4354             # (and so on)
4355              
4356 0           my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4357              
4358             # without { ... }
4359 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4360 0 0         if ($string !~ /<
4361 0           return $string;
4362             }
4363             }
4364              
4365             E_STRING_LOOP:
4366 0           while ($string !~ /\G \z/oxgc) {
4367 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4368             }
4369              
4370             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin7::PREMATCH()]}
4371 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4372 0           $e_string .= q{Elatin7::PREMATCH()};
4373 0           $slash = 'div';
4374             }
4375              
4376             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin7::MATCH()]}
4377             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4378 0           $e_string .= q{Elatin7::MATCH()};
4379 0           $slash = 'div';
4380             }
4381              
4382             # $', ${'} --> $', ${'}
4383             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4384 0           $e_string .= $1;
4385 0           $slash = 'div';
4386             }
4387              
4388             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin7::POSTMATCH()]}
4389             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4390 0           $e_string .= q{Elatin7::POSTMATCH()};
4391 0           $slash = 'div';
4392             }
4393              
4394             # bareword
4395             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4396 0           $e_string .= $1;
4397 0           $slash = 'div';
4398             }
4399              
4400             # $0 --> $0
4401             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4402 0           $e_string .= $1;
4403 0           $slash = 'div';
4404             }
4405             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4406 0           $e_string .= $1;
4407 0           $slash = 'div';
4408             }
4409              
4410             # $$ --> $$
4411             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4412 0           $e_string .= $1;
4413 0           $slash = 'div';
4414             }
4415              
4416             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4417             # $1, $2, $3 --> $1, $2, $3 otherwise
4418             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4419 0           $e_string .= e_capture($1);
4420 0           $slash = 'div';
4421             }
4422             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4423 0           $e_string .= e_capture($1);
4424 0           $slash = 'div';
4425             }
4426              
4427             # $$foo[ ... ] --> $ $foo->[ ... ]
4428             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4429 0           $e_string .= e_capture($1.'->'.$2);
4430 0           $slash = 'div';
4431             }
4432              
4433             # $$foo{ ... } --> $ $foo->{ ... }
4434             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4435 0           $e_string .= e_capture($1.'->'.$2);
4436 0           $slash = 'div';
4437             }
4438              
4439             # $$foo
4440             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4441 0           $e_string .= e_capture($1);
4442 0           $slash = 'div';
4443             }
4444              
4445             # ${ foo }
4446             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4447 0           $e_string .= '${' . $1 . '}';
4448 0           $slash = 'div';
4449             }
4450              
4451             # ${ ... }
4452             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4453 0           $e_string .= e_capture($1);
4454 0           $slash = 'div';
4455             }
4456              
4457             # variable or function
4458             # $ @ % & * $ #
4459             elsif ($string =~ /\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
4460 0           $e_string .= $1;
4461 0           $slash = 'div';
4462             }
4463             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4464             # $ @ # \ ' " / ? ( ) [ ] < >
4465             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4466 0           $e_string .= $1;
4467 0           $slash = 'div';
4468             }
4469              
4470             # subroutines of package Elatin7
4471 0           elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4472 0           elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4473 0           elsif ($string =~ /\G \b Latin7::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4474 0           elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0            
4475 0           elsif ($string =~ /\G \b Latin7::eval \b /oxgc) { $e_string .= 'eval Latin7::escape'; $slash = 'm//'; }
  0            
4476 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin7::chop'; $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4479 0           elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0            
4480 0           elsif ($string =~ /\G \b Latin7::index \b /oxgc) { $e_string .= 'Latin7::index'; $slash = 'm//'; }
  0            
4481 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin7::index'; $slash = 'm//'; }
  0            
4482 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4483 0           elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0            
4484 0           elsif ($string =~ /\G \b Latin7::rindex \b /oxgc) { $e_string .= 'Latin7::rindex'; $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin7::rindex'; $slash = 'm//'; }
  0            
4486 0           elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::lc'; $slash = 'm//'; }
  0            
4487 0           elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::lcfirst'; $slash = 'm//'; }
  0            
4488 0           elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::uc'; $slash = 'm//'; }
  0            
4489 0           elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::ucfirst'; $slash = 'm//'; }
  0            
4490 0           elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::fc'; $slash = 'm//'; }
  0            
4491              
4492             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4493 0           elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4494 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4495 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4496 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4497 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4498 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4499 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            
4500              
4501 0           elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4502 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4503 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4504 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4506 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4507 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4508              
4509             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4510 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4511 0           elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4512 0           elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4513 0           elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4514              
4515 0           elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4516 0           elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4517 0           elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::chr'; $slash = 'm//'; }
  0            
4518 0           elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4519 0           elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4520 0           elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin7::glob'; $slash = 'm//'; }
  0            
4521 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin7::lc_'; $slash = 'm//'; }
  0            
4522 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin7::lcfirst_'; $slash = 'm//'; }
  0            
4523 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin7::uc_'; $slash = 'm//'; }
  0            
4524 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin7::ucfirst_'; $slash = 'm//'; }
  0            
4525 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin7::fc_'; $slash = 'm//'; }
  0            
4526 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4527              
4528 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4529 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4530 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin7::chr_'; $slash = 'm//'; }
  0            
4531 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4532 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4533 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin7::glob_'; $slash = 'm//'; }
  0            
4534 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4535 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4536             # split
4537             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4538 0           $slash = 'm//';
4539              
4540 0           my $e = '';
4541 0           while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4542 0           $e .= $1;
4543             }
4544              
4545             # end of split
4546 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin7::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4547              
4548             # split scalar value
4549 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin7::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4550              
4551             # split literal space
4552 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4553 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4554 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4555 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4556 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4557 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4558 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4559 0           elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4560 0           elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4561 0           elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4562 0           elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4563 0           elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4564 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4565 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin7::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4566              
4567             # split qq//
4568             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4569 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0            
  0            
4570             else {
4571 0           while ($string !~ /\G \z/oxgc) {
4572 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4573 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4574 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4575 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4576 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4577 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4578 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0            
4579             }
4580 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4581             }
4582             }
4583              
4584             # split qr//
4585             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4586 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4587             else {
4588 0           while ($string !~ /\G \z/oxgc) {
4589 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4590 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4591 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4592 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4593 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4594 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            
4595 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4596 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0            
4597             }
4598 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4599             }
4600             }
4601              
4602             # split q//
4603             elsif ($string =~ /\G \b (q) \b /oxgc) {
4604 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0            
  0            
4605             else {
4606 0           while ($string !~ /\G \z/oxgc) {
4607 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4608 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4609 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4610 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4611 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4612 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4613 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0            
4614             }
4615 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4616             }
4617             }
4618              
4619             # split m//
4620             elsif ($string =~ /\G \b (m) \b /oxgc) {
4621 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0            
  0            
4622             else {
4623 0           while ($string !~ /\G \z/oxgc) {
4624 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4625 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            
4626 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            
4627 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            
4628 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            
4629 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            
4630 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4631 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0            
4632             }
4633 0           die __FILE__, ": Search pattern not terminated\n";
4634             }
4635             }
4636              
4637             # split ''
4638             elsif ($string =~ /\G (\') /oxgc) {
4639 0           my $q_string = '';
4640 0           while ($string !~ /\G \z/oxgc) {
4641 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4642 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4643 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4644 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4645             }
4646 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4647             }
4648              
4649             # split ""
4650             elsif ($string =~ /\G (\") /oxgc) {
4651 0           my $qq_string = '';
4652 0           while ($string !~ /\G \z/oxgc) {
4653 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4654 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4655 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4656 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4657             }
4658 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4659             }
4660              
4661             # split //
4662             elsif ($string =~ /\G (\/) /oxgc) {
4663 0           my $regexp = '';
4664 0           while ($string !~ /\G \z/oxgc) {
4665 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4666 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4667 0           elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4668 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4669             }
4670 0           die __FILE__, ": Search pattern not terminated\n";
4671             }
4672             }
4673              
4674             # qq//
4675             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4676 0           my $ope = $1;
4677 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4678 0           $e_string .= e_qq($ope,$1,$3,$2);
4679             }
4680             else {
4681 0           my $e = '';
4682 0           while ($string !~ /\G \z/oxgc) {
4683 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4684 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4685 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4686 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4687 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4688 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4689             }
4690 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4691             }
4692             }
4693              
4694             # qx//
4695             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4696 0           my $ope = $1;
4697 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4698 0           $e_string .= e_qq($ope,$1,$3,$2);
4699             }
4700             else {
4701 0           my $e = '';
4702 0           while ($string !~ /\G \z/oxgc) {
4703 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4704 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4705 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4706 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4707 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4708 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4709 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4710             }
4711 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4712             }
4713             }
4714              
4715             # q//
4716             elsif ($string =~ /\G \b (q) \b /oxgc) {
4717 0           my $ope = $1;
4718 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4719 0           $e_string .= e_q($ope,$1,$3,$2);
4720             }
4721             else {
4722 0           my $e = '';
4723 0           while ($string !~ /\G \z/oxgc) {
4724 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4725 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4726 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4727 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4728 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4729 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0            
4730             }
4731 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4732             }
4733             }
4734              
4735             # ''
4736 0           elsif ($string =~ /\G (?
4737              
4738             # ""
4739 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4740              
4741             # ``
4742 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4743              
4744             # <<>> (a safer ARGV)
4745 0           elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4746              
4747             # <<= <=> <= < operator
4748 0           elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4749              
4750             #
4751 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4752              
4753             # --- glob
4754             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4755 0           $e_string .= 'Elatin7::glob("' . $1 . '")';
4756             }
4757              
4758             # << (bit shift) --- not here document
4759 0           elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4760              
4761             # <<'HEREDOC'
4762             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4763 0           $slash = 'm//';
4764 0           my $here_quote = $1;
4765 0           my $delimiter = $2;
4766              
4767             # get here document
4768 0 0         if ($here_script eq '') {
4769 0           $here_script = CORE::substr $_, pos $_;
4770 0           $here_script =~ s/.*?\n//oxm;
4771             }
4772 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4773 0           push @heredoc, $1 . qq{\n$delimiter\n};
4774 0           push @heredoc_delimiter, $delimiter;
4775             }
4776             else {
4777 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4778             }
4779 0           $e_string .= $here_quote;
4780             }
4781              
4782             # <<\HEREDOC
4783             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4784 0           $slash = 'm//';
4785 0           my $here_quote = $1;
4786 0           my $delimiter = $2;
4787              
4788             # get here document
4789 0 0         if ($here_script eq '') {
4790 0           $here_script = CORE::substr $_, pos $_;
4791 0           $here_script =~ s/.*?\n//oxm;
4792             }
4793 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4794 0           push @heredoc, $1 . qq{\n$delimiter\n};
4795 0           push @heredoc_delimiter, $delimiter;
4796             }
4797             else {
4798 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4799             }
4800 0           $e_string .= $here_quote;
4801             }
4802              
4803             # <<"HEREDOC"
4804             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4805 0           $slash = 'm//';
4806 0           my $here_quote = $1;
4807 0           my $delimiter = $2;
4808              
4809             # get here document
4810 0 0         if ($here_script eq '') {
4811 0           $here_script = CORE::substr $_, pos $_;
4812 0           $here_script =~ s/.*?\n//oxm;
4813             }
4814 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4815 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4816 0           push @heredoc_delimiter, $delimiter;
4817             }
4818             else {
4819 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4820             }
4821 0           $e_string .= $here_quote;
4822             }
4823              
4824             # <
4825             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4826 0           $slash = 'm//';
4827 0           my $here_quote = $1;
4828 0           my $delimiter = $2;
4829              
4830             # get here document
4831 0 0         if ($here_script eq '') {
4832 0           $here_script = CORE::substr $_, pos $_;
4833 0           $here_script =~ s/.*?\n//oxm;
4834             }
4835 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4836 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4837 0           push @heredoc_delimiter, $delimiter;
4838             }
4839             else {
4840 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4841             }
4842 0           $e_string .= $here_quote;
4843             }
4844              
4845             # <<`HEREDOC`
4846             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4847 0           $slash = 'm//';
4848 0           my $here_quote = $1;
4849 0           my $delimiter = $2;
4850              
4851             # get here document
4852 0 0         if ($here_script eq '') {
4853 0           $here_script = CORE::substr $_, pos $_;
4854 0           $here_script =~ s/.*?\n//oxm;
4855             }
4856 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4857 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4858 0           push @heredoc_delimiter, $delimiter;
4859             }
4860             else {
4861 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4862             }
4863 0           $e_string .= $here_quote;
4864             }
4865              
4866             # any operator before div
4867             elsif ($string =~ /\G (
4868             -- | \+\+ |
4869             [\)\}\]]
4870              
4871 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4872              
4873             # yada-yada or triple-dot operator
4874             elsif ($string =~ /\G (
4875             \.\.\.
4876              
4877 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4878              
4879             # any operator before m//
4880             elsif ($string =~ /\G ((?>
4881              
4882             !~~ | !~ | != | ! |
4883             %= | % |
4884             &&= | && | &= | &\.= | &\. | & |
4885             -= | -> | - |
4886             :(?>\s*)= |
4887             : |
4888             <<>> |
4889             <<= | <=> | <= | < |
4890             == | => | =~ | = |
4891             >>= | >> | >= | > |
4892             \*\*= | \*\* | \*= | \* |
4893             \+= | \+ |
4894             \.\. | \.= | \. |
4895             \/\/= | \/\/ |
4896             \/= | \/ |
4897             \? |
4898             \\ |
4899             \^= | \^\.= | \^\. | \^ |
4900             \b x= |
4901             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4902             ~~ | ~\. | ~ |
4903             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4904             \b(?: print )\b |
4905              
4906             [,;\(\{\[]
4907              
4908 0           )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4909              
4910             # other any character
4911 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4912              
4913             # system error
4914             else {
4915 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4916             }
4917             }
4918              
4919 0           return $e_string;
4920             }
4921              
4922             #
4923             # character class
4924             #
4925             sub character_class {
4926 0     0 0   my($char,$modifier) = @_;
4927              
4928 0 0         if ($char eq '.') {
4929 0 0         if ($modifier =~ /s/) {
4930 0           return '${Elatin7::dot_s}';
4931             }
4932             else {
4933 0           return '${Elatin7::dot}';
4934             }
4935             }
4936             else {
4937 0           return Elatin7::classic_character_class($char);
4938             }
4939             }
4940              
4941             #
4942             # escape capture ($1, $2, $3, ...)
4943             #
4944             sub e_capture {
4945              
4946 0     0 0   return join '', '${', $_[0], '}';
4947             }
4948              
4949             #
4950             # escape transliteration (tr/// or y///)
4951             #
4952             sub e_tr {
4953 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4954 0           my $e_tr = '';
4955 0   0       $modifier ||= '';
4956              
4957 0           $slash = 'div';
4958              
4959             # quote character class 1
4960 0           $charclass = q_tr($charclass);
4961              
4962             # quote character class 2
4963 0           $charclass2 = q_tr($charclass2);
4964              
4965             # /b /B modifier
4966 0 0         if ($modifier =~ tr/bB//d) {
4967 0 0         if ($variable eq '') {
4968 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4969             }
4970             else {
4971 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4972             }
4973             }
4974             else {
4975 0 0         if ($variable eq '') {
4976 0           $e_tr = qq{Elatin7::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4977             }
4978             else {
4979 0           $e_tr = qq{Elatin7::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4980             }
4981             }
4982              
4983             # clear tr/// variable
4984 0           $tr_variable = '';
4985 0           $bind_operator = '';
4986              
4987 0           return $e_tr;
4988             }
4989              
4990             #
4991             # quote for escape transliteration (tr/// or y///)
4992             #
4993             sub q_tr {
4994 0     0 0   my($charclass) = @_;
4995              
4996             # quote character class
4997 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4998 0           return e_q('', "'", "'", $charclass); # --> q' '
4999             }
5000             elsif ($charclass !~ /\//oxms) {
5001 0           return e_q('q', '/', '/', $charclass); # --> q/ /
5002             }
5003             elsif ($charclass !~ /\#/oxms) {
5004 0           return e_q('q', '#', '#', $charclass); # --> q# #
5005             }
5006             elsif ($charclass !~ /[\<\>]/oxms) {
5007 0           return e_q('q', '<', '>', $charclass); # --> q< >
5008             }
5009             elsif ($charclass !~ /[\(\)]/oxms) {
5010 0           return e_q('q', '(', ')', $charclass); # --> q( )
5011             }
5012             elsif ($charclass !~ /[\{\}]/oxms) {
5013 0           return e_q('q', '{', '}', $charclass); # --> q{ }
5014             }
5015             else {
5016 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5017 0 0         if ($charclass !~ /\Q$char\E/xms) {
5018 0           return e_q('q', $char, $char, $charclass);
5019             }
5020             }
5021             }
5022              
5023 0           return e_q('q', '{', '}', $charclass);
5024             }
5025              
5026             #
5027             # escape q string (q//, '')
5028             #
5029             sub e_q {
5030 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5031              
5032 0           $slash = 'div';
5033              
5034 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5035             }
5036              
5037             #
5038             # escape qq string (qq//, "", qx//, ``)
5039             #
5040             sub e_qq {
5041 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5042              
5043 0           $slash = 'div';
5044              
5045 0           my $left_e = 0;
5046 0           my $right_e = 0;
5047              
5048             # split regexp
5049 0           my @char = $string =~ /\G((?>
5050             [^\\\$] |
5051             \\x\{ (?>[0-9A-Fa-f]+) \} |
5052             \\o\{ (?>[0-7]+) \} |
5053             \\N\{ (?>[^0-9\}][^\}]*) \} |
5054             \\ $q_char |
5055             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5056             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5057             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5058             \$ (?>\s* [0-9]+) |
5059             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5060             \$ \$ (?![\w\{]) |
5061             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5062             $q_char
5063             ))/oxmsg;
5064              
5065 0           for (my $i=0; $i <= $#char; $i++) {
5066              
5067             # "\L\u" --> "\u\L"
5068 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5069 0           @char[$i,$i+1] = @char[$i+1,$i];
5070             }
5071              
5072             # "\U\l" --> "\l\U"
5073             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5074 0           @char[$i,$i+1] = @char[$i+1,$i];
5075             }
5076              
5077             # octal escape sequence
5078             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5079 0           $char[$i] = Elatin7::octchr($1);
5080             }
5081              
5082             # hexadecimal escape sequence
5083             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5084 0           $char[$i] = Elatin7::hexchr($1);
5085             }
5086              
5087             # \N{CHARNAME} --> N{CHARNAME}
5088             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5089 0           $char[$i] = $1;
5090             }
5091              
5092 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5093             }
5094              
5095             # \F
5096             #
5097             # P.69 Table 2-6. Translation escapes
5098             # in Chapter 2: Bits and Pieces
5099             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5100             # (and so on)
5101              
5102             # \u \l \U \L \F \Q \E
5103 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5104 0 0         if ($right_e < $left_e) {
5105 0           $char[$i] = '\\' . $char[$i];
5106             }
5107             }
5108             elsif ($char[$i] eq '\u') {
5109              
5110             # "STRING @{[ LIST EXPR ]} MORE STRING"
5111              
5112             # P.257 Other Tricks You Can Do with Hard References
5113             # in Chapter 8: References
5114             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5115              
5116             # P.353 Other Tricks You Can Do with Hard References
5117             # in Chapter 8: References
5118             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5119              
5120             # (and so on)
5121              
5122 0           $char[$i] = '@{[Elatin7::ucfirst qq<';
5123 0           $left_e++;
5124             }
5125             elsif ($char[$i] eq '\l') {
5126 0           $char[$i] = '@{[Elatin7::lcfirst qq<';
5127 0           $left_e++;
5128             }
5129             elsif ($char[$i] eq '\U') {
5130 0           $char[$i] = '@{[Elatin7::uc qq<';
5131 0           $left_e++;
5132             }
5133             elsif ($char[$i] eq '\L') {
5134 0           $char[$i] = '@{[Elatin7::lc qq<';
5135 0           $left_e++;
5136             }
5137             elsif ($char[$i] eq '\F') {
5138 0           $char[$i] = '@{[Elatin7::fc qq<';
5139 0           $left_e++;
5140             }
5141             elsif ($char[$i] eq '\Q') {
5142 0           $char[$i] = '@{[CORE::quotemeta qq<';
5143 0           $left_e++;
5144             }
5145             elsif ($char[$i] eq '\E') {
5146 0 0         if ($right_e < $left_e) {
5147 0           $char[$i] = '>]}';
5148 0           $right_e++;
5149             }
5150             else {
5151 0           $char[$i] = '';
5152             }
5153             }
5154             elsif ($char[$i] eq '\Q') {
5155 0           while (1) {
5156 0 0         if (++$i > $#char) {
5157 0           last;
5158             }
5159 0 0         if ($char[$i] eq '\E') {
5160 0           last;
5161             }
5162             }
5163             }
5164             elsif ($char[$i] eq '\E') {
5165             }
5166              
5167             # $0 --> $0
5168             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5169             }
5170             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5171             }
5172              
5173             # $$ --> $$
5174             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5175             }
5176              
5177             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5178             # $1, $2, $3 --> $1, $2, $3 otherwise
5179             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5180 0           $char[$i] = e_capture($1);
5181             }
5182             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5183 0           $char[$i] = e_capture($1);
5184             }
5185              
5186             # $$foo[ ... ] --> $ $foo->[ ... ]
5187             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5188 0           $char[$i] = e_capture($1.'->'.$2);
5189             }
5190              
5191             # $$foo{ ... } --> $ $foo->{ ... }
5192             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5193 0           $char[$i] = e_capture($1.'->'.$2);
5194             }
5195              
5196             # $$foo
5197             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5198 0           $char[$i] = e_capture($1);
5199             }
5200              
5201             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
5202             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5203 0           $char[$i] = '@{[Elatin7::PREMATCH()]}';
5204             }
5205              
5206             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5207             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5208 0           $char[$i] = '@{[Elatin7::MATCH()]}';
5209             }
5210              
5211             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5212             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5213 0           $char[$i] = '@{[Elatin7::POSTMATCH()]}';
5214             }
5215              
5216             # ${ foo } --> ${ foo }
5217             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5218             }
5219              
5220             # ${ ... }
5221             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5222 0           $char[$i] = e_capture($1);
5223             }
5224             }
5225              
5226             # return string
5227 0 0         if ($left_e > $right_e) {
5228 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5229             }
5230 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5231             }
5232              
5233             #
5234             # escape qw string (qw//)
5235             #
5236             sub e_qw {
5237 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5238              
5239 0           $slash = 'div';
5240              
5241             # choice again delimiter
5242 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5243 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5244 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5245             }
5246             elsif (not $octet{')'}) {
5247 0           return join '', $ope, '(', $string, ')';
5248             }
5249             elsif (not $octet{'}'}) {
5250 0           return join '', $ope, '{', $string, '}';
5251             }
5252             elsif (not $octet{']'}) {
5253 0           return join '', $ope, '[', $string, ']';
5254             }
5255             elsif (not $octet{'>'}) {
5256 0           return join '', $ope, '<', $string, '>';
5257             }
5258             else {
5259 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5260 0 0         if (not $octet{$char}) {
5261 0           return join '', $ope, $char, $string, $char;
5262             }
5263             }
5264             }
5265              
5266             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5267 0           my @string = CORE::split(/\s+/, $string);
5268 0           for my $string (@string) {
5269 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5270 0           for my $octet (@octet) {
5271 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5272 0           $octet = '\\' . $1;
5273             }
5274             }
5275 0           $string = join '', @octet;
5276             }
5277 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5278             }
5279              
5280             #
5281             # escape here document (<<"HEREDOC", <
5282             #
5283             sub e_heredoc {
5284 0     0 0   my($string) = @_;
5285              
5286 0           $slash = 'm//';
5287              
5288 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5289              
5290 0           my $left_e = 0;
5291 0           my $right_e = 0;
5292              
5293             # split regexp
5294 0           my @char = $string =~ /\G((?>
5295             [^\\\$] |
5296             \\x\{ (?>[0-9A-Fa-f]+) \} |
5297             \\o\{ (?>[0-7]+) \} |
5298             \\N\{ (?>[^0-9\}][^\}]*) \} |
5299             \\ $q_char |
5300             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5301             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5302             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5303             \$ (?>\s* [0-9]+) |
5304             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5305             \$ \$ (?![\w\{]) |
5306             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5307             $q_char
5308             ))/oxmsg;
5309              
5310 0           for (my $i=0; $i <= $#char; $i++) {
5311              
5312             # "\L\u" --> "\u\L"
5313 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5314 0           @char[$i,$i+1] = @char[$i+1,$i];
5315             }
5316              
5317             # "\U\l" --> "\l\U"
5318             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5319 0           @char[$i,$i+1] = @char[$i+1,$i];
5320             }
5321              
5322             # octal escape sequence
5323             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5324 0           $char[$i] = Elatin7::octchr($1);
5325             }
5326              
5327             # hexadecimal escape sequence
5328             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5329 0           $char[$i] = Elatin7::hexchr($1);
5330             }
5331              
5332             # \N{CHARNAME} --> N{CHARNAME}
5333             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5334 0           $char[$i] = $1;
5335             }
5336              
5337 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5338             }
5339              
5340             # \u \l \U \L \F \Q \E
5341 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5342 0 0         if ($right_e < $left_e) {
5343 0           $char[$i] = '\\' . $char[$i];
5344             }
5345             }
5346             elsif ($char[$i] eq '\u') {
5347 0           $char[$i] = '@{[Elatin7::ucfirst qq<';
5348 0           $left_e++;
5349             }
5350             elsif ($char[$i] eq '\l') {
5351 0           $char[$i] = '@{[Elatin7::lcfirst qq<';
5352 0           $left_e++;
5353             }
5354             elsif ($char[$i] eq '\U') {
5355 0           $char[$i] = '@{[Elatin7::uc qq<';
5356 0           $left_e++;
5357             }
5358             elsif ($char[$i] eq '\L') {
5359 0           $char[$i] = '@{[Elatin7::lc qq<';
5360 0           $left_e++;
5361             }
5362             elsif ($char[$i] eq '\F') {
5363 0           $char[$i] = '@{[Elatin7::fc qq<';
5364 0           $left_e++;
5365             }
5366             elsif ($char[$i] eq '\Q') {
5367 0           $char[$i] = '@{[CORE::quotemeta qq<';
5368 0           $left_e++;
5369             }
5370             elsif ($char[$i] eq '\E') {
5371 0 0         if ($right_e < $left_e) {
5372 0           $char[$i] = '>]}';
5373 0           $right_e++;
5374             }
5375             else {
5376 0           $char[$i] = '';
5377             }
5378             }
5379             elsif ($char[$i] eq '\Q') {
5380 0           while (1) {
5381 0 0         if (++$i > $#char) {
5382 0           last;
5383             }
5384 0 0         if ($char[$i] eq '\E') {
5385 0           last;
5386             }
5387             }
5388             }
5389             elsif ($char[$i] eq '\E') {
5390             }
5391              
5392             # $0 --> $0
5393             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5394             }
5395             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5396             }
5397              
5398             # $$ --> $$
5399             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5400             }
5401              
5402             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5403             # $1, $2, $3 --> $1, $2, $3 otherwise
5404             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5405 0           $char[$i] = e_capture($1);
5406             }
5407             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5408 0           $char[$i] = e_capture($1);
5409             }
5410              
5411             # $$foo[ ... ] --> $ $foo->[ ... ]
5412             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5413 0           $char[$i] = e_capture($1.'->'.$2);
5414             }
5415              
5416             # $$foo{ ... } --> $ $foo->{ ... }
5417             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5418 0           $char[$i] = e_capture($1.'->'.$2);
5419             }
5420              
5421             # $$foo
5422             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5423 0           $char[$i] = e_capture($1);
5424             }
5425              
5426             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
5427             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5428 0           $char[$i] = '@{[Elatin7::PREMATCH()]}';
5429             }
5430              
5431             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5432             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5433 0           $char[$i] = '@{[Elatin7::MATCH()]}';
5434             }
5435              
5436             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5437             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5438 0           $char[$i] = '@{[Elatin7::POSTMATCH()]}';
5439             }
5440              
5441             # ${ foo } --> ${ foo }
5442             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5443             }
5444              
5445             # ${ ... }
5446             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5447 0           $char[$i] = e_capture($1);
5448             }
5449             }
5450              
5451             # return string
5452 0 0         if ($left_e > $right_e) {
5453 0           return join '', @char, '>]}' x ($left_e - $right_e);
5454             }
5455 0           return join '', @char;
5456             }
5457              
5458             #
5459             # escape regexp (m//, qr//)
5460             #
5461             sub e_qr {
5462 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5463 0   0       $modifier ||= '';
5464              
5465 0           $modifier =~ tr/p//d;
5466 0 0         if ($modifier =~ /([adlu])/oxms) {
5467 0           my $line = 0;
5468 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5469 0 0         if ($filename ne __FILE__) {
5470 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5471 0           last;
5472             }
5473             }
5474 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5475             }
5476              
5477 0           $slash = 'div';
5478              
5479             # literal null string pattern
5480 0 0         if ($string eq '') {
    0          
5481 0           $modifier =~ tr/bB//d;
5482 0           $modifier =~ tr/i//d;
5483 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5484             }
5485              
5486             # /b /B modifier
5487             elsif ($modifier =~ tr/bB//d) {
5488              
5489             # choice again delimiter
5490 0 0         if ($delimiter =~ / [\@:] /oxms) {
5491 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5492 0           my %octet = map {$_ => 1} @char;
  0            
5493 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5494 0           $delimiter = '(';
5495 0           $end_delimiter = ')';
5496             }
5497             elsif (not $octet{'}'}) {
5498 0           $delimiter = '{';
5499 0           $end_delimiter = '}';
5500             }
5501             elsif (not $octet{']'}) {
5502 0           $delimiter = '[';
5503 0           $end_delimiter = ']';
5504             }
5505             elsif (not $octet{'>'}) {
5506 0           $delimiter = '<';
5507 0           $end_delimiter = '>';
5508             }
5509             else {
5510 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5511 0 0         if (not $octet{$char}) {
5512 0           $delimiter = $char;
5513 0           $end_delimiter = $char;
5514 0           last;
5515             }
5516             }
5517             }
5518             }
5519              
5520 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5521 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5522             }
5523             else {
5524 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5525             }
5526             }
5527              
5528 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5529 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5530              
5531             # split regexp
5532 0           my @char = $string =~ /\G((?>
5533             [^\\\$\@\[\(] |
5534             \\x (?>[0-9A-Fa-f]{1,2}) |
5535             \\ (?>[0-7]{2,3}) |
5536             \\c [\x40-\x5F] |
5537             \\x\{ (?>[0-9A-Fa-f]+) \} |
5538             \\o\{ (?>[0-7]+) \} |
5539             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5540             \\ $q_char |
5541             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5542             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5543             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5544             [\$\@] $qq_variable |
5545             \$ (?>\s* [0-9]+) |
5546             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5547             \$ \$ (?![\w\{]) |
5548             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5549             \[\^ |
5550             \[\: (?>[a-z]+) :\] |
5551             \[\:\^ (?>[a-z]+) :\] |
5552             \(\? |
5553             $q_char
5554             ))/oxmsg;
5555              
5556             # choice again delimiter
5557 0 0         if ($delimiter =~ / [\@:] /oxms) {
5558 0           my %octet = map {$_ => 1} @char;
  0            
5559 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5560 0           $delimiter = '(';
5561 0           $end_delimiter = ')';
5562             }
5563             elsif (not $octet{'}'}) {
5564 0           $delimiter = '{';
5565 0           $end_delimiter = '}';
5566             }
5567             elsif (not $octet{']'}) {
5568 0           $delimiter = '[';
5569 0           $end_delimiter = ']';
5570             }
5571             elsif (not $octet{'>'}) {
5572 0           $delimiter = '<';
5573 0           $end_delimiter = '>';
5574             }
5575             else {
5576 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5577 0 0         if (not $octet{$char}) {
5578 0           $delimiter = $char;
5579 0           $end_delimiter = $char;
5580 0           last;
5581             }
5582             }
5583             }
5584             }
5585              
5586 0           my $left_e = 0;
5587 0           my $right_e = 0;
5588 0           for (my $i=0; $i <= $#char; $i++) {
5589              
5590             # "\L\u" --> "\u\L"
5591 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
5592 0           @char[$i,$i+1] = @char[$i+1,$i];
5593             }
5594              
5595             # "\U\l" --> "\l\U"
5596             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5597 0           @char[$i,$i+1] = @char[$i+1,$i];
5598             }
5599              
5600             # octal escape sequence
5601             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5602 0           $char[$i] = Elatin7::octchr($1);
5603             }
5604              
5605             # hexadecimal escape sequence
5606             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5607 0           $char[$i] = Elatin7::hexchr($1);
5608             }
5609              
5610             # \b{...} --> b\{...}
5611             # \B{...} --> B\{...}
5612             # \N{CHARNAME} --> N\{CHARNAME}
5613             # \p{PROPERTY} --> p\{PROPERTY}
5614             # \P{PROPERTY} --> P\{PROPERTY}
5615             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5616 0           $char[$i] = $1 . '\\' . $2;
5617             }
5618              
5619             # \p, \P, \X --> p, P, X
5620             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5621 0           $char[$i] = $1;
5622             }
5623              
5624 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5625             }
5626              
5627             # join separated multiple-octet
5628 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5629 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
5630 0           $char[$i] .= join '', splice @char, $i+1, 3;
5631             }
5632             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
5633 0           $char[$i] .= join '', splice @char, $i+1, 2;
5634             }
5635             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
5636 0           $char[$i] .= join '', splice @char, $i+1, 1;
5637             }
5638             }
5639              
5640             # open character class [...]
5641             elsif ($char[$i] eq '[') {
5642 0           my $left = $i;
5643              
5644             # [] make die "Unmatched [] in regexp ...\n"
5645             # (and so on)
5646              
5647 0 0         if ($char[$i+1] eq ']') {
5648 0           $i++;
5649             }
5650              
5651 0           while (1) {
5652 0 0         if (++$i > $#char) {
5653 0           die __FILE__, ": Unmatched [] in regexp\n";
5654             }
5655 0 0         if ($char[$i] eq ']') {
5656 0           my $right = $i;
5657              
5658             # [...]
5659 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5660 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5661             }
5662             else {
5663 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
5664             }
5665              
5666 0           $i = $left;
5667 0           last;
5668             }
5669             }
5670             }
5671              
5672             # open character class [^...]
5673             elsif ($char[$i] eq '[^') {
5674 0           my $left = $i;
5675              
5676             # [^] make die "Unmatched [] in regexp ...\n"
5677             # (and so on)
5678              
5679 0 0         if ($char[$i+1] eq ']') {
5680 0           $i++;
5681             }
5682              
5683 0           while (1) {
5684 0 0         if (++$i > $#char) {
5685 0           die __FILE__, ": Unmatched [] in regexp\n";
5686             }
5687 0 0         if ($char[$i] eq ']') {
5688 0           my $right = $i;
5689              
5690             # [^...]
5691 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5692 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5693             }
5694             else {
5695 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5696             }
5697              
5698 0           $i = $left;
5699 0           last;
5700             }
5701             }
5702             }
5703              
5704             # rewrite character class or escape character
5705             elsif (my $char = character_class($char[$i],$modifier)) {
5706 0           $char[$i] = $char;
5707             }
5708              
5709             # /i modifier
5710             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
5711 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
5712 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
5713             }
5714             else {
5715 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
5716             }
5717             }
5718              
5719             # \u \l \U \L \F \Q \E
5720             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5721 0 0         if ($right_e < $left_e) {
5722 0           $char[$i] = '\\' . $char[$i];
5723             }
5724             }
5725             elsif ($char[$i] eq '\u') {
5726 0           $char[$i] = '@{[Elatin7::ucfirst qq<';
5727 0           $left_e++;
5728             }
5729             elsif ($char[$i] eq '\l') {
5730 0           $char[$i] = '@{[Elatin7::lcfirst qq<';
5731 0           $left_e++;
5732             }
5733             elsif ($char[$i] eq '\U') {
5734 0           $char[$i] = '@{[Elatin7::uc qq<';
5735 0           $left_e++;
5736             }
5737             elsif ($char[$i] eq '\L') {
5738 0           $char[$i] = '@{[Elatin7::lc qq<';
5739 0           $left_e++;
5740             }
5741             elsif ($char[$i] eq '\F') {
5742 0           $char[$i] = '@{[Elatin7::fc qq<';
5743 0           $left_e++;
5744             }
5745             elsif ($char[$i] eq '\Q') {
5746 0           $char[$i] = '@{[CORE::quotemeta qq<';
5747 0           $left_e++;
5748             }
5749             elsif ($char[$i] eq '\E') {
5750 0 0         if ($right_e < $left_e) {
5751 0           $char[$i] = '>]}';
5752 0           $right_e++;
5753             }
5754             else {
5755 0           $char[$i] = '';
5756             }
5757             }
5758             elsif ($char[$i] eq '\Q') {
5759 0           while (1) {
5760 0 0         if (++$i > $#char) {
5761 0           last;
5762             }
5763 0 0         if ($char[$i] eq '\E') {
5764 0           last;
5765             }
5766             }
5767             }
5768             elsif ($char[$i] eq '\E') {
5769             }
5770              
5771             # $0 --> $0
5772             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5773 0 0         if ($ignorecase) {
5774 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5775             }
5776             }
5777             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5778 0 0         if ($ignorecase) {
5779 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5780             }
5781             }
5782              
5783             # $$ --> $$
5784             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5785             }
5786              
5787             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5788             # $1, $2, $3 --> $1, $2, $3 otherwise
5789             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5790 0           $char[$i] = e_capture($1);
5791 0 0         if ($ignorecase) {
5792 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5793             }
5794             }
5795             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5796 0           $char[$i] = e_capture($1);
5797 0 0         if ($ignorecase) {
5798 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5799             }
5800             }
5801              
5802             # $$foo[ ... ] --> $ $foo->[ ... ]
5803             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5804 0           $char[$i] = e_capture($1.'->'.$2);
5805 0 0         if ($ignorecase) {
5806 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5807             }
5808             }
5809              
5810             # $$foo{ ... } --> $ $foo->{ ... }
5811             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5812 0           $char[$i] = e_capture($1.'->'.$2);
5813 0 0         if ($ignorecase) {
5814 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5815             }
5816             }
5817              
5818             # $$foo
5819             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5820 0           $char[$i] = e_capture($1);
5821 0 0         if ($ignorecase) {
5822 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5823             }
5824             }
5825              
5826             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
5827             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5828 0 0         if ($ignorecase) {
5829 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
5830             }
5831             else {
5832 0           $char[$i] = '@{[Elatin7::PREMATCH()]}';
5833             }
5834             }
5835              
5836             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
5837             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5838 0 0         if ($ignorecase) {
5839 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
5840             }
5841             else {
5842 0           $char[$i] = '@{[Elatin7::MATCH()]}';
5843             }
5844             }
5845              
5846             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
5847             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5848 0 0         if ($ignorecase) {
5849 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
5850             }
5851             else {
5852 0           $char[$i] = '@{[Elatin7::POSTMATCH()]}';
5853             }
5854             }
5855              
5856             # ${ foo }
5857             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5858 0 0         if ($ignorecase) {
5859 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5860             }
5861             }
5862              
5863             # ${ ... }
5864             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5865 0           $char[$i] = e_capture($1);
5866 0 0         if ($ignorecase) {
5867 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5868             }
5869             }
5870              
5871             # $scalar or @array
5872             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5873 0           $char[$i] = e_string($char[$i]);
5874 0 0         if ($ignorecase) {
5875 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
5876             }
5877             }
5878              
5879             # quote character before ? + * {
5880             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5881 0 0 0       if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5882             }
5883             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5884 0           my $char = $char[$i-1];
5885 0 0         if ($char[$i] eq '{') {
5886 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5887             }
5888             else {
5889 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5890             }
5891             }
5892             else {
5893 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5894             }
5895             }
5896             }
5897              
5898             # make regexp string
5899 0           $modifier =~ tr/i//d;
5900 0 0         if ($left_e > $right_e) {
5901 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5902 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5903             }
5904             else {
5905 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5906             }
5907             }
5908 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5909 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5910             }
5911             else {
5912 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5913             }
5914             }
5915              
5916             #
5917             # double quote stuff
5918             #
5919             sub qq_stuff {
5920 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5921              
5922             # scalar variable or array variable
5923 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5924 0           return $stuff;
5925             }
5926              
5927             # quote by delimiter
5928 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5929 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5930 0 0         next if $char eq $delimiter;
5931 0 0         next if $char eq $end_delimiter;
5932 0 0         if (not $octet{$char}) {
5933 0           return join '', 'qq', $char, $stuff, $char;
5934             }
5935             }
5936 0           return join '', 'qq', '<', $stuff, '>';
5937             }
5938              
5939             #
5940             # escape regexp (m'', qr'', and m''b, qr''b)
5941             #
5942             sub e_qr_q {
5943 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5944 0   0       $modifier ||= '';
5945              
5946 0           $modifier =~ tr/p//d;
5947 0 0         if ($modifier =~ /([adlu])/oxms) {
5948 0           my $line = 0;
5949 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5950 0 0         if ($filename ne __FILE__) {
5951 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5952 0           last;
5953             }
5954             }
5955 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5956             }
5957              
5958 0           $slash = 'div';
5959              
5960             # literal null string pattern
5961 0 0         if ($string eq '') {
    0          
5962 0           $modifier =~ tr/bB//d;
5963 0           $modifier =~ tr/i//d;
5964 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5965             }
5966              
5967             # with /b /B modifier
5968             elsif ($modifier =~ tr/bB//d) {
5969 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5970             }
5971              
5972             # without /b /B modifier
5973             else {
5974 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5975             }
5976             }
5977              
5978             #
5979             # escape regexp (m'', qr'')
5980             #
5981             sub e_qr_qt {
5982 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5983              
5984 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5985              
5986             # split regexp
5987 0           my @char = $string =~ /\G((?>
5988             [^\\\[\$\@\/] |
5989             [\x00-\xFF] |
5990             \[\^ |
5991             \[\: (?>[a-z]+) \:\] |
5992             \[\:\^ (?>[a-z]+) \:\] |
5993             [\$\@\/] |
5994             \\ (?:$q_char) |
5995             (?:$q_char)
5996             ))/oxmsg;
5997              
5998             # unescape character
5999 0           for (my $i=0; $i <= $#char; $i++) {
6000 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6001             }
6002              
6003             # open character class [...]
6004 0           elsif ($char[$i] eq '[') {
6005 0           my $left = $i;
6006 0 0         if ($char[$i+1] eq ']') {
6007 0           $i++;
6008             }
6009 0           while (1) {
6010 0 0         if (++$i > $#char) {
6011 0           die __FILE__, ": Unmatched [] in regexp\n";
6012             }
6013 0 0         if ($char[$i] eq ']') {
6014 0           my $right = $i;
6015              
6016             # [...]
6017 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6018              
6019 0           $i = $left;
6020 0           last;
6021             }
6022             }
6023             }
6024              
6025             # open character class [^...]
6026             elsif ($char[$i] eq '[^') {
6027 0           my $left = $i;
6028 0 0         if ($char[$i+1] eq ']') {
6029 0           $i++;
6030             }
6031 0           while (1) {
6032 0 0         if (++$i > $#char) {
6033 0           die __FILE__, ": Unmatched [] in regexp\n";
6034             }
6035 0 0         if ($char[$i] eq ']') {
6036 0           my $right = $i;
6037              
6038             # [^...]
6039 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6040              
6041 0           $i = $left;
6042 0           last;
6043             }
6044             }
6045             }
6046              
6047             # escape $ @ / and \
6048             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6049 0           $char[$i] = '\\' . $char[$i];
6050             }
6051              
6052             # rewrite character class or escape character
6053             elsif (my $char = character_class($char[$i],$modifier)) {
6054 0           $char[$i] = $char;
6055             }
6056              
6057             # /i modifier
6058             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6059 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6060 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6061             }
6062             else {
6063 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
6064             }
6065             }
6066              
6067             # quote character before ? + * {
6068             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6069 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6070             }
6071             else {
6072 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6073             }
6074             }
6075             }
6076              
6077 0           $delimiter = '/';
6078 0           $end_delimiter = '/';
6079              
6080 0           $modifier =~ tr/i//d;
6081 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6082             }
6083              
6084             #
6085             # escape regexp (m''b, qr''b)
6086             #
6087             sub e_qr_qb {
6088 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6089              
6090             # split regexp
6091 0           my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6092              
6093             # unescape character
6094 0           for (my $i=0; $i <= $#char; $i++) {
6095 0 0         if (0) {
    0          
6096             }
6097              
6098             # remain \\
6099 0           elsif ($char[$i] eq '\\\\') {
6100             }
6101              
6102             # escape $ @ / and \
6103             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6104 0           $char[$i] = '\\' . $char[$i];
6105             }
6106             }
6107              
6108 0           $delimiter = '/';
6109 0           $end_delimiter = '/';
6110 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6111             }
6112              
6113             #
6114             # escape regexp (s/here//)
6115             #
6116             sub e_s1 {
6117 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6118 0   0       $modifier ||= '';
6119              
6120 0           $modifier =~ tr/p//d;
6121 0 0         if ($modifier =~ /([adlu])/oxms) {
6122 0           my $line = 0;
6123 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6124 0 0         if ($filename ne __FILE__) {
6125 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6126 0           last;
6127             }
6128             }
6129 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6130             }
6131              
6132 0           $slash = 'div';
6133              
6134             # literal null string pattern
6135 0 0         if ($string eq '') {
    0          
6136 0           $modifier =~ tr/bB//d;
6137 0           $modifier =~ tr/i//d;
6138 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6139             }
6140              
6141             # /b /B modifier
6142             elsif ($modifier =~ tr/bB//d) {
6143              
6144             # choice again delimiter
6145 0 0         if ($delimiter =~ / [\@:] /oxms) {
6146 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6147 0           my %octet = map {$_ => 1} @char;
  0            
6148 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6149 0           $delimiter = '(';
6150 0           $end_delimiter = ')';
6151             }
6152             elsif (not $octet{'}'}) {
6153 0           $delimiter = '{';
6154 0           $end_delimiter = '}';
6155             }
6156             elsif (not $octet{']'}) {
6157 0           $delimiter = '[';
6158 0           $end_delimiter = ']';
6159             }
6160             elsif (not $octet{'>'}) {
6161 0           $delimiter = '<';
6162 0           $end_delimiter = '>';
6163             }
6164             else {
6165 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6166 0 0         if (not $octet{$char}) {
6167 0           $delimiter = $char;
6168 0           $end_delimiter = $char;
6169 0           last;
6170             }
6171             }
6172             }
6173             }
6174              
6175 0           my $prematch = '';
6176 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6177             }
6178              
6179 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6180 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6181              
6182             # split regexp
6183 0           my @char = $string =~ /\G((?>
6184             [^\\\$\@\[\(] |
6185             \\ (?>[1-9][0-9]*) |
6186             \\g (?>\s*) (?>[1-9][0-9]*) |
6187             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6188             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6189             \\x (?>[0-9A-Fa-f]{1,2}) |
6190             \\ (?>[0-7]{2,3}) |
6191             \\c [\x40-\x5F] |
6192             \\x\{ (?>[0-9A-Fa-f]+) \} |
6193             \\o\{ (?>[0-7]+) \} |
6194             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6195             \\ $q_char |
6196             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6197             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6198             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6199             [\$\@] $qq_variable |
6200             \$ (?>\s* [0-9]+) |
6201             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6202             \$ \$ (?![\w\{]) |
6203             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6204             \[\^ |
6205             \[\: (?>[a-z]+) :\] |
6206             \[\:\^ (?>[a-z]+) :\] |
6207             \(\? |
6208             $q_char
6209             ))/oxmsg;
6210              
6211             # choice again delimiter
6212 0 0         if ($delimiter =~ / [\@:] /oxms) {
6213 0           my %octet = map {$_ => 1} @char;
  0            
6214 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6215 0           $delimiter = '(';
6216 0           $end_delimiter = ')';
6217             }
6218             elsif (not $octet{'}'}) {
6219 0           $delimiter = '{';
6220 0           $end_delimiter = '}';
6221             }
6222             elsif (not $octet{']'}) {
6223 0           $delimiter = '[';
6224 0           $end_delimiter = ']';
6225             }
6226             elsif (not $octet{'>'}) {
6227 0           $delimiter = '<';
6228 0           $end_delimiter = '>';
6229             }
6230             else {
6231 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6232 0 0         if (not $octet{$char}) {
6233 0           $delimiter = $char;
6234 0           $end_delimiter = $char;
6235 0           last;
6236             }
6237             }
6238             }
6239             }
6240              
6241             # count '('
6242 0           my $parens = grep { $_ eq '(' } @char;
  0            
6243              
6244 0           my $left_e = 0;
6245 0           my $right_e = 0;
6246 0           for (my $i=0; $i <= $#char; $i++) {
6247              
6248             # "\L\u" --> "\u\L"
6249 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
6250 0           @char[$i,$i+1] = @char[$i+1,$i];
6251             }
6252              
6253             # "\U\l" --> "\l\U"
6254             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6255 0           @char[$i,$i+1] = @char[$i+1,$i];
6256             }
6257              
6258             # octal escape sequence
6259             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6260 0           $char[$i] = Elatin7::octchr($1);
6261             }
6262              
6263             # hexadecimal escape sequence
6264             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6265 0           $char[$i] = Elatin7::hexchr($1);
6266             }
6267              
6268             # \b{...} --> b\{...}
6269             # \B{...} --> B\{...}
6270             # \N{CHARNAME} --> N\{CHARNAME}
6271             # \p{PROPERTY} --> p\{PROPERTY}
6272             # \P{PROPERTY} --> P\{PROPERTY}
6273             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6274 0           $char[$i] = $1 . '\\' . $2;
6275             }
6276              
6277             # \p, \P, \X --> p, P, X
6278             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6279 0           $char[$i] = $1;
6280             }
6281              
6282 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6283             }
6284              
6285             # join separated multiple-octet
6286 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6287 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6288 0           $char[$i] .= join '', splice @char, $i+1, 3;
6289             }
6290             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
6291 0           $char[$i] .= join '', splice @char, $i+1, 2;
6292             }
6293             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
6294 0           $char[$i] .= join '', splice @char, $i+1, 1;
6295             }
6296             }
6297              
6298             # open character class [...]
6299             elsif ($char[$i] eq '[') {
6300 0           my $left = $i;
6301 0 0         if ($char[$i+1] eq ']') {
6302 0           $i++;
6303             }
6304 0           while (1) {
6305 0 0         if (++$i > $#char) {
6306 0           die __FILE__, ": Unmatched [] in regexp\n";
6307             }
6308 0 0         if ($char[$i] eq ']') {
6309 0           my $right = $i;
6310              
6311             # [...]
6312 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6313 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6314             }
6315             else {
6316 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6317             }
6318              
6319 0           $i = $left;
6320 0           last;
6321             }
6322             }
6323             }
6324              
6325             # open character class [^...]
6326             elsif ($char[$i] eq '[^') {
6327 0           my $left = $i;
6328 0 0         if ($char[$i+1] eq ']') {
6329 0           $i++;
6330             }
6331 0           while (1) {
6332 0 0         if (++$i > $#char) {
6333 0           die __FILE__, ": Unmatched [] in regexp\n";
6334             }
6335 0 0         if ($char[$i] eq ']') {
6336 0           my $right = $i;
6337              
6338             # [^...]
6339 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6340 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6341             }
6342             else {
6343 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6344             }
6345              
6346 0           $i = $left;
6347 0           last;
6348             }
6349             }
6350             }
6351              
6352             # rewrite character class or escape character
6353             elsif (my $char = character_class($char[$i],$modifier)) {
6354 0           $char[$i] = $char;
6355             }
6356              
6357             # /i modifier
6358             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6359 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6360 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6361             }
6362             else {
6363 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
6364             }
6365             }
6366              
6367             # \u \l \U \L \F \Q \E
6368             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6369 0 0         if ($right_e < $left_e) {
6370 0           $char[$i] = '\\' . $char[$i];
6371             }
6372             }
6373             elsif ($char[$i] eq '\u') {
6374 0           $char[$i] = '@{[Elatin7::ucfirst qq<';
6375 0           $left_e++;
6376             }
6377             elsif ($char[$i] eq '\l') {
6378 0           $char[$i] = '@{[Elatin7::lcfirst qq<';
6379 0           $left_e++;
6380             }
6381             elsif ($char[$i] eq '\U') {
6382 0           $char[$i] = '@{[Elatin7::uc qq<';
6383 0           $left_e++;
6384             }
6385             elsif ($char[$i] eq '\L') {
6386 0           $char[$i] = '@{[Elatin7::lc qq<';
6387 0           $left_e++;
6388             }
6389             elsif ($char[$i] eq '\F') {
6390 0           $char[$i] = '@{[Elatin7::fc qq<';
6391 0           $left_e++;
6392             }
6393             elsif ($char[$i] eq '\Q') {
6394 0           $char[$i] = '@{[CORE::quotemeta qq<';
6395 0           $left_e++;
6396             }
6397             elsif ($char[$i] eq '\E') {
6398 0 0         if ($right_e < $left_e) {
6399 0           $char[$i] = '>]}';
6400 0           $right_e++;
6401             }
6402             else {
6403 0           $char[$i] = '';
6404             }
6405             }
6406             elsif ($char[$i] eq '\Q') {
6407 0           while (1) {
6408 0 0         if (++$i > $#char) {
6409 0           last;
6410             }
6411 0 0         if ($char[$i] eq '\E') {
6412 0           last;
6413             }
6414             }
6415             }
6416             elsif ($char[$i] eq '\E') {
6417             }
6418              
6419             # \0 --> \0
6420             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6421             }
6422              
6423             # \g{N}, \g{-N}
6424              
6425             # P.108 Using Simple Patterns
6426             # in Chapter 7: In the World of Regular Expressions
6427             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6428              
6429             # P.221 Capturing
6430             # in Chapter 5: Pattern Matching
6431             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6432              
6433             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6434             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6435             }
6436              
6437             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6438             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6439             }
6440              
6441             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6442             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6443             }
6444              
6445             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6446             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6447             }
6448              
6449             # $0 --> $0
6450             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6451 0 0         if ($ignorecase) {
6452 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6453             }
6454             }
6455             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6456 0 0         if ($ignorecase) {
6457 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6458             }
6459             }
6460              
6461             # $$ --> $$
6462             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6463             }
6464              
6465             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6466             # $1, $2, $3 --> $1, $2, $3 otherwise
6467             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6468 0           $char[$i] = e_capture($1);
6469 0 0         if ($ignorecase) {
6470 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6471             }
6472             }
6473             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6474 0           $char[$i] = e_capture($1);
6475 0 0         if ($ignorecase) {
6476 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6477             }
6478             }
6479              
6480             # $$foo[ ... ] --> $ $foo->[ ... ]
6481             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6482 0           $char[$i] = e_capture($1.'->'.$2);
6483 0 0         if ($ignorecase) {
6484 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6485             }
6486             }
6487              
6488             # $$foo{ ... } --> $ $foo->{ ... }
6489             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6490 0           $char[$i] = e_capture($1.'->'.$2);
6491 0 0         if ($ignorecase) {
6492 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6493             }
6494             }
6495              
6496             # $$foo
6497             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6498 0           $char[$i] = e_capture($1);
6499 0 0         if ($ignorecase) {
6500 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6501             }
6502             }
6503              
6504             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
6505             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6506 0 0         if ($ignorecase) {
6507 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
6508             }
6509             else {
6510 0           $char[$i] = '@{[Elatin7::PREMATCH()]}';
6511             }
6512             }
6513              
6514             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
6515             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6516 0 0         if ($ignorecase) {
6517 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
6518             }
6519             else {
6520 0           $char[$i] = '@{[Elatin7::MATCH()]}';
6521             }
6522             }
6523              
6524             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
6525             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6526 0 0         if ($ignorecase) {
6527 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
6528             }
6529             else {
6530 0           $char[$i] = '@{[Elatin7::POSTMATCH()]}';
6531             }
6532             }
6533              
6534             # ${ foo }
6535             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6536 0 0         if ($ignorecase) {
6537 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6538             }
6539             }
6540              
6541             # ${ ... }
6542             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6543 0           $char[$i] = e_capture($1);
6544 0 0         if ($ignorecase) {
6545 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6546             }
6547             }
6548              
6549             # $scalar or @array
6550             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6551 0           $char[$i] = e_string($char[$i]);
6552 0 0         if ($ignorecase) {
6553 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
6554             }
6555             }
6556              
6557             # quote character before ? + * {
6558             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6559 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6560             }
6561             else {
6562 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6563             }
6564             }
6565             }
6566              
6567             # make regexp string
6568 0           my $prematch = '';
6569 0           $modifier =~ tr/i//d;
6570 0 0         if ($left_e > $right_e) {
6571 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6572             }
6573 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6574             }
6575              
6576             #
6577             # escape regexp (s'here'' or s'here''b)
6578             #
6579             sub e_s1_q {
6580 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6581 0   0       $modifier ||= '';
6582              
6583 0           $modifier =~ tr/p//d;
6584 0 0         if ($modifier =~ /([adlu])/oxms) {
6585 0           my $line = 0;
6586 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6587 0 0         if ($filename ne __FILE__) {
6588 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6589 0           last;
6590             }
6591             }
6592 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6593             }
6594              
6595 0           $slash = 'div';
6596              
6597             # literal null string pattern
6598 0 0         if ($string eq '') {
    0          
6599 0           $modifier =~ tr/bB//d;
6600 0           $modifier =~ tr/i//d;
6601 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6602             }
6603              
6604             # with /b /B modifier
6605             elsif ($modifier =~ tr/bB//d) {
6606 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6607             }
6608              
6609             # without /b /B modifier
6610             else {
6611 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6612             }
6613             }
6614              
6615             #
6616             # escape regexp (s'here'')
6617             #
6618             sub e_s1_qt {
6619 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6620              
6621 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6622              
6623             # split regexp
6624 0           my @char = $string =~ /\G((?>
6625             [^\\\[\$\@\/] |
6626             [\x00-\xFF] |
6627             \[\^ |
6628             \[\: (?>[a-z]+) \:\] |
6629             \[\:\^ (?>[a-z]+) \:\] |
6630             [\$\@\/] |
6631             \\ (?:$q_char) |
6632             (?:$q_char)
6633             ))/oxmsg;
6634              
6635             # unescape character
6636 0           for (my $i=0; $i <= $#char; $i++) {
6637 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6638             }
6639              
6640             # open character class [...]
6641 0           elsif ($char[$i] eq '[') {
6642 0           my $left = $i;
6643 0 0         if ($char[$i+1] eq ']') {
6644 0           $i++;
6645             }
6646 0           while (1) {
6647 0 0         if (++$i > $#char) {
6648 0           die __FILE__, ": Unmatched [] in regexp\n";
6649             }
6650 0 0         if ($char[$i] eq ']') {
6651 0           my $right = $i;
6652              
6653             # [...]
6654 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
6655              
6656 0           $i = $left;
6657 0           last;
6658             }
6659             }
6660             }
6661              
6662             # open character class [^...]
6663             elsif ($char[$i] eq '[^') {
6664 0           my $left = $i;
6665 0 0         if ($char[$i+1] eq ']') {
6666 0           $i++;
6667             }
6668 0           while (1) {
6669 0 0         if (++$i > $#char) {
6670 0           die __FILE__, ": Unmatched [] in regexp\n";
6671             }
6672 0 0         if ($char[$i] eq ']') {
6673 0           my $right = $i;
6674              
6675             # [^...]
6676 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6677              
6678 0           $i = $left;
6679 0           last;
6680             }
6681             }
6682             }
6683              
6684             # escape $ @ / and \
6685             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6686 0           $char[$i] = '\\' . $char[$i];
6687             }
6688              
6689             # rewrite character class or escape character
6690             elsif (my $char = character_class($char[$i],$modifier)) {
6691 0           $char[$i] = $char;
6692             }
6693              
6694             # /i modifier
6695             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
6696 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
6697 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
6698             }
6699             else {
6700 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
6701             }
6702             }
6703              
6704             # quote character before ? + * {
6705             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6706 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6707             }
6708             else {
6709 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6710             }
6711             }
6712             }
6713              
6714 0           $modifier =~ tr/i//d;
6715 0           $delimiter = '/';
6716 0           $end_delimiter = '/';
6717 0           my $prematch = '';
6718 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6719             }
6720              
6721             #
6722             # escape regexp (s'here''b)
6723             #
6724             sub e_s1_qb {
6725 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6726              
6727             # split regexp
6728 0           my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6729              
6730             # unescape character
6731 0           for (my $i=0; $i <= $#char; $i++) {
6732 0 0         if (0) {
    0          
6733             }
6734              
6735             # remain \\
6736 0           elsif ($char[$i] eq '\\\\') {
6737             }
6738              
6739             # escape $ @ / and \
6740             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6741 0           $char[$i] = '\\' . $char[$i];
6742             }
6743             }
6744              
6745 0           $delimiter = '/';
6746 0           $end_delimiter = '/';
6747 0           my $prematch = '';
6748 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6749             }
6750              
6751             #
6752             # escape regexp (s''here')
6753             #
6754             sub e_s2_q {
6755 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6756              
6757 0           $slash = 'div';
6758              
6759 0           my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6760 0           for (my $i=0; $i <= $#char; $i++) {
6761 0 0         if (0) {
    0          
6762             }
6763              
6764             # not escape \\
6765 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6766             }
6767              
6768             # escape $ @ / and \
6769             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6770 0           $char[$i] = '\\' . $char[$i];
6771             }
6772             }
6773              
6774 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6775             }
6776              
6777             #
6778             # escape regexp (s/here/and here/modifier)
6779             #
6780             sub e_sub {
6781 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6782 0   0       $modifier ||= '';
6783              
6784 0           $modifier =~ tr/p//d;
6785 0 0         if ($modifier =~ /([adlu])/oxms) {
6786 0           my $line = 0;
6787 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6788 0 0         if ($filename ne __FILE__) {
6789 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6790 0           last;
6791             }
6792             }
6793 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6794             }
6795              
6796 0 0         if ($variable eq '') {
6797 0           $variable = '$_';
6798 0           $bind_operator = ' =~ ';
6799             }
6800              
6801 0           $slash = 'div';
6802              
6803             # P.128 Start of match (or end of previous match): \G
6804             # P.130 Advanced Use of \G with Perl
6805             # in Chapter 3: Overview of Regular Expression Features and Flavors
6806             # P.312 Iterative Matching: Scalar Context, with /g
6807             # in Chapter 7: Perl
6808             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6809              
6810             # P.181 Where You Left Off: The \G Assertion
6811             # in Chapter 5: Pattern Matching
6812             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6813              
6814             # P.220 Where You Left Off: The \G Assertion
6815             # in Chapter 5: Pattern Matching
6816             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6817              
6818 0           my $e_modifier = $modifier =~ tr/e//d;
6819 0           my $r_modifier = $modifier =~ tr/r//d;
6820              
6821 0           my $my = '';
6822 0 0         if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6823 0           $my = $variable;
6824 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6825 0           $variable =~ s/ = .+ \z//oxms;
6826             }
6827              
6828 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6829 0           $variable_basename =~ s/ \s+ \z//oxms;
6830              
6831             # quote replacement string
6832 0           my $e_replacement = '';
6833 0 0         if ($e_modifier >= 1) {
6834 0           $e_replacement = e_qq('', '', '', $replacement);
6835 0           $e_modifier--;
6836             }
6837             else {
6838 0 0         if ($delimiter2 eq "'") {
6839 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6840             }
6841             else {
6842 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6843             }
6844             }
6845              
6846 0           my $sub = '';
6847              
6848             # with /r
6849 0 0         if ($r_modifier) {
6850 0 0         if (0) {
6851             }
6852              
6853             # s///gr without multibyte anchoring
6854 0           elsif ($modifier =~ /g/oxms) {
6855 0 0         $sub = sprintf(
6856             # 1 2 3 4 5
6857             q,
6858              
6859             $variable, # 1
6860             ($delimiter1 eq "'") ? # 2
6861             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6862             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6863             $s_matched, # 3
6864             $e_replacement, # 4
6865             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 5
6866             );
6867             }
6868              
6869             # s///r
6870             else {
6871              
6872 0           my $prematch = q{$`};
6873              
6874 0 0         $sub = sprintf(
6875             # 1 2 3 4 5 6 7
6876             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin7::re_r=%s; %s"%s$Latin7::re_r$'" } : %s>,
6877              
6878             $variable, # 1
6879             ($delimiter1 eq "'") ? # 2
6880             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6881             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6882             $s_matched, # 3
6883             $e_replacement, # 4
6884             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 5
6885             $prematch, # 6
6886             $variable, # 7
6887             );
6888             }
6889              
6890             # $var !~ s///r doesn't make sense
6891 0 0         if ($bind_operator =~ / !~ /oxms) {
6892 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6893             }
6894             }
6895              
6896             # without /r
6897             else {
6898 0 0         if (0) {
6899             }
6900              
6901             # s///g without multibyte anchoring
6902 0           elsif ($modifier =~ /g/oxms) {
6903 0 0         $sub = sprintf(
    0          
6904             # 1 2 3 4 5 6 7 8
6905             q,
6906              
6907             $variable, # 1
6908             ($delimiter1 eq "'") ? # 2
6909             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6910             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6911             $s_matched, # 3
6912             $e_replacement, # 4
6913             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 5
6914             $variable, # 6
6915             $variable, # 7
6916             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6917             );
6918             }
6919              
6920             # s///
6921             else {
6922              
6923 0           my $prematch = q{$`};
6924              
6925 0 0         $sub = sprintf(
    0          
6926              
6927             ($bind_operator =~ / =~ /oxms) ?
6928              
6929             # 1 2 3 4 5 6 7 8
6930             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin7::re_r=%s; %s%s="%s$Latin7::re_r$'"; 1 } : undef> :
6931              
6932             # 1 2 3 4 5 6 7 8
6933             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin7::re_r=%s; %s%s="%s$Latin7::re_r$'"; undef }>,
6934              
6935             $variable, # 1
6936             $bind_operator, # 2
6937             ($delimiter1 eq "'") ? # 3
6938             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6939             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6940             $s_matched, # 4
6941             $e_replacement, # 5
6942             '$Latin7::re_r=CORE::eval $Latin7::re_r; ' x $e_modifier, # 6
6943             $variable, # 7
6944             $prematch, # 8
6945             );
6946             }
6947             }
6948              
6949             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6950 0 0         if ($my ne '') {
6951 0           $sub = "($my, $sub)[1]";
6952             }
6953              
6954             # clear s/// variable
6955 0           $sub_variable = '';
6956 0           $bind_operator = '';
6957              
6958 0           return $sub;
6959             }
6960              
6961             #
6962             # escape regexp of split qr//
6963             #
6964             sub e_split {
6965 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6966 0   0       $modifier ||= '';
6967              
6968 0           $modifier =~ tr/p//d;
6969 0 0         if ($modifier =~ /([adlu])/oxms) {
6970 0           my $line = 0;
6971 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6972 0 0         if ($filename ne __FILE__) {
6973 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6974 0           last;
6975             }
6976             }
6977 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6978             }
6979              
6980 0           $slash = 'div';
6981              
6982             # /b /B modifier
6983 0 0         if ($modifier =~ tr/bB//d) {
6984 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6985             }
6986              
6987 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6988 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6989              
6990             # split regexp
6991 0           my @char = $string =~ /\G((?>
6992             [^\\\$\@\[\(] |
6993             \\x (?>[0-9A-Fa-f]{1,2}) |
6994             \\ (?>[0-7]{2,3}) |
6995             \\c [\x40-\x5F] |
6996             \\x\{ (?>[0-9A-Fa-f]+) \} |
6997             \\o\{ (?>[0-7]+) \} |
6998             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6999             \\ $q_char |
7000             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7001             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7002             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7003             [\$\@] $qq_variable |
7004             \$ (?>\s* [0-9]+) |
7005             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7006             \$ \$ (?![\w\{]) |
7007             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7008             \[\^ |
7009             \[\: (?>[a-z]+) :\] |
7010             \[\:\^ (?>[a-z]+) :\] |
7011             \(\? |
7012             $q_char
7013             ))/oxmsg;
7014              
7015 0           my $left_e = 0;
7016 0           my $right_e = 0;
7017 0           for (my $i=0; $i <= $#char; $i++) {
7018              
7019             # "\L\u" --> "\u\L"
7020 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
7021 0           @char[$i,$i+1] = @char[$i+1,$i];
7022             }
7023              
7024             # "\U\l" --> "\l\U"
7025             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7026 0           @char[$i,$i+1] = @char[$i+1,$i];
7027             }
7028              
7029             # octal escape sequence
7030             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7031 0           $char[$i] = Elatin7::octchr($1);
7032             }
7033              
7034             # hexadecimal escape sequence
7035             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7036 0           $char[$i] = Elatin7::hexchr($1);
7037             }
7038              
7039             # \b{...} --> b\{...}
7040             # \B{...} --> B\{...}
7041             # \N{CHARNAME} --> N\{CHARNAME}
7042             # \p{PROPERTY} --> p\{PROPERTY}
7043             # \P{PROPERTY} --> P\{PROPERTY}
7044             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7045 0           $char[$i] = $1 . '\\' . $2;
7046             }
7047              
7048             # \p, \P, \X --> p, P, X
7049             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7050 0           $char[$i] = $1;
7051             }
7052              
7053 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7054             }
7055              
7056             # join separated multiple-octet
7057 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7058 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
7059 0           $char[$i] .= join '', splice @char, $i+1, 3;
7060             }
7061             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
7062 0           $char[$i] .= join '', splice @char, $i+1, 2;
7063             }
7064             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
7065 0           $char[$i] .= join '', splice @char, $i+1, 1;
7066             }
7067             }
7068              
7069             # open character class [...]
7070             elsif ($char[$i] eq '[') {
7071 0           my $left = $i;
7072 0 0         if ($char[$i+1] eq ']') {
7073 0           $i++;
7074             }
7075 0           while (1) {
7076 0 0         if (++$i > $#char) {
7077 0           die __FILE__, ": Unmatched [] in regexp\n";
7078             }
7079 0 0         if ($char[$i] eq ']') {
7080 0           my $right = $i;
7081              
7082             # [...]
7083 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7084 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7085             }
7086             else {
7087 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7088             }
7089              
7090 0           $i = $left;
7091 0           last;
7092             }
7093             }
7094             }
7095              
7096             # open character class [^...]
7097             elsif ($char[$i] eq '[^') {
7098 0           my $left = $i;
7099 0 0         if ($char[$i+1] eq ']') {
7100 0           $i++;
7101             }
7102 0           while (1) {
7103 0 0         if (++$i > $#char) {
7104 0           die __FILE__, ": Unmatched [] in regexp\n";
7105             }
7106 0 0         if ($char[$i] eq ']') {
7107 0           my $right = $i;
7108              
7109             # [^...]
7110 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7111 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin7::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7112             }
7113             else {
7114 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7115             }
7116              
7117 0           $i = $left;
7118 0           last;
7119             }
7120             }
7121             }
7122              
7123             # rewrite character class or escape character
7124             elsif (my $char = character_class($char[$i],$modifier)) {
7125 0           $char[$i] = $char;
7126             }
7127              
7128             # P.794 29.2.161. split
7129             # in Chapter 29: Functions
7130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7131              
7132             # P.951 split
7133             # in Chapter 27: Functions
7134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7135              
7136             # said "The //m modifier is assumed when you split on the pattern /^/",
7137             # but perl5.008 is not so. Therefore, this software adds //m.
7138             # (and so on)
7139              
7140             # split(m/^/) --> split(m/^/m)
7141             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7142 0           $modifier .= 'm';
7143             }
7144              
7145             # /i modifier
7146             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
7147 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
7148 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
7149             }
7150             else {
7151 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
7152             }
7153             }
7154              
7155             # \u \l \U \L \F \Q \E
7156             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7157 0 0         if ($right_e < $left_e) {
7158 0           $char[$i] = '\\' . $char[$i];
7159             }
7160             }
7161             elsif ($char[$i] eq '\u') {
7162 0           $char[$i] = '@{[Elatin7::ucfirst qq<';
7163 0           $left_e++;
7164             }
7165             elsif ($char[$i] eq '\l') {
7166 0           $char[$i] = '@{[Elatin7::lcfirst qq<';
7167 0           $left_e++;
7168             }
7169             elsif ($char[$i] eq '\U') {
7170 0           $char[$i] = '@{[Elatin7::uc qq<';
7171 0           $left_e++;
7172             }
7173             elsif ($char[$i] eq '\L') {
7174 0           $char[$i] = '@{[Elatin7::lc qq<';
7175 0           $left_e++;
7176             }
7177             elsif ($char[$i] eq '\F') {
7178 0           $char[$i] = '@{[Elatin7::fc qq<';
7179 0           $left_e++;
7180             }
7181             elsif ($char[$i] eq '\Q') {
7182 0           $char[$i] = '@{[CORE::quotemeta qq<';
7183 0           $left_e++;
7184             }
7185             elsif ($char[$i] eq '\E') {
7186 0 0         if ($right_e < $left_e) {
7187 0           $char[$i] = '>]}';
7188 0           $right_e++;
7189             }
7190             else {
7191 0           $char[$i] = '';
7192             }
7193             }
7194             elsif ($char[$i] eq '\Q') {
7195 0           while (1) {
7196 0 0         if (++$i > $#char) {
7197 0           last;
7198             }
7199 0 0         if ($char[$i] eq '\E') {
7200 0           last;
7201             }
7202             }
7203             }
7204             elsif ($char[$i] eq '\E') {
7205             }
7206              
7207             # $0 --> $0
7208             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7209 0 0         if ($ignorecase) {
7210 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7211             }
7212             }
7213             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7214 0 0         if ($ignorecase) {
7215 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7216             }
7217             }
7218              
7219             # $$ --> $$
7220             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7221             }
7222              
7223             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7224             # $1, $2, $3 --> $1, $2, $3 otherwise
7225             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7226 0           $char[$i] = e_capture($1);
7227 0 0         if ($ignorecase) {
7228 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7229             }
7230             }
7231             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7232 0           $char[$i] = e_capture($1);
7233 0 0         if ($ignorecase) {
7234 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7235             }
7236             }
7237              
7238             # $$foo[ ... ] --> $ $foo->[ ... ]
7239             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7240 0           $char[$i] = e_capture($1.'->'.$2);
7241 0 0         if ($ignorecase) {
7242 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7243             }
7244             }
7245              
7246             # $$foo{ ... } --> $ $foo->{ ... }
7247             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7248 0           $char[$i] = e_capture($1.'->'.$2);
7249 0 0         if ($ignorecase) {
7250 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7251             }
7252             }
7253              
7254             # $$foo
7255             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7256 0           $char[$i] = e_capture($1);
7257 0 0         if ($ignorecase) {
7258 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7259             }
7260             }
7261              
7262             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin7::PREMATCH()
7263             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7264 0 0         if ($ignorecase) {
7265 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::PREMATCH())]}';
7266             }
7267             else {
7268 0           $char[$i] = '@{[Elatin7::PREMATCH()]}';
7269             }
7270             }
7271              
7272             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin7::MATCH()
7273             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7274 0 0         if ($ignorecase) {
7275 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::MATCH())]}';
7276             }
7277             else {
7278 0           $char[$i] = '@{[Elatin7::MATCH()]}';
7279             }
7280             }
7281              
7282             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin7::POSTMATCH()
7283             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7284 0 0         if ($ignorecase) {
7285 0           $char[$i] = '@{[Elatin7::ignorecase(Elatin7::POSTMATCH())]}';
7286             }
7287             else {
7288 0           $char[$i] = '@{[Elatin7::POSTMATCH()]}';
7289             }
7290             }
7291              
7292             # ${ foo }
7293             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7294 0 0         if ($ignorecase) {
7295 0           $char[$i] = '@{[Elatin7::ignorecase(' . $1 . ')]}';
7296             }
7297             }
7298              
7299             # ${ ... }
7300             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7301 0           $char[$i] = e_capture($1);
7302 0 0         if ($ignorecase) {
7303 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7304             }
7305             }
7306              
7307             # $scalar or @array
7308             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7309 0           $char[$i] = e_string($char[$i]);
7310 0 0         if ($ignorecase) {
7311 0           $char[$i] = '@{[Elatin7::ignorecase(' . $char[$i] . ')]}';
7312             }
7313             }
7314              
7315             # quote character before ? + * {
7316             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7317 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7318             }
7319             else {
7320 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7321             }
7322             }
7323             }
7324              
7325             # make regexp string
7326 0           $modifier =~ tr/i//d;
7327 0 0         if ($left_e > $right_e) {
7328 0           return join '', 'Elatin7::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7329             }
7330 0           return join '', 'Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7331             }
7332              
7333             #
7334             # escape regexp of split qr''
7335             #
7336             sub e_split_q {
7337 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7338 0   0       $modifier ||= '';
7339              
7340 0           $modifier =~ tr/p//d;
7341 0 0         if ($modifier =~ /([adlu])/oxms) {
7342 0           my $line = 0;
7343 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7344 0 0         if ($filename ne __FILE__) {
7345 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7346 0           last;
7347             }
7348             }
7349 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7350             }
7351              
7352 0           $slash = 'div';
7353              
7354             # /b /B modifier
7355 0 0         if ($modifier =~ tr/bB//d) {
7356 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7357             }
7358              
7359 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7360              
7361             # split regexp
7362 0           my @char = $string =~ /\G((?>
7363             [^\\\[] |
7364             [\x00-\xFF] |
7365             \[\^ |
7366             \[\: (?>[a-z]+) \:\] |
7367             \[\:\^ (?>[a-z]+) \:\] |
7368             \\ (?:$q_char) |
7369             (?:$q_char)
7370             ))/oxmsg;
7371              
7372             # unescape character
7373 0           for (my $i=0; $i <= $#char; $i++) {
7374 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7375             }
7376              
7377             # open character class [...]
7378 0           elsif ($char[$i] eq '[') {
7379 0           my $left = $i;
7380 0 0         if ($char[$i+1] eq ']') {
7381 0           $i++;
7382             }
7383 0           while (1) {
7384 0 0         if (++$i > $#char) {
7385 0           die __FILE__, ": Unmatched [] in regexp\n";
7386             }
7387 0 0         if ($char[$i] eq ']') {
7388 0           my $right = $i;
7389              
7390             # [...]
7391 0           splice @char, $left, $right-$left+1, Elatin7::charlist_qr(@char[$left+1..$right-1], $modifier);
7392              
7393 0           $i = $left;
7394 0           last;
7395             }
7396             }
7397             }
7398              
7399             # open character class [^...]
7400             elsif ($char[$i] eq '[^') {
7401 0           my $left = $i;
7402 0 0         if ($char[$i+1] eq ']') {
7403 0           $i++;
7404             }
7405 0           while (1) {
7406 0 0         if (++$i > $#char) {
7407 0           die __FILE__, ": Unmatched [] in regexp\n";
7408             }
7409 0 0         if ($char[$i] eq ']') {
7410 0           my $right = $i;
7411              
7412             # [^...]
7413 0           splice @char, $left, $right-$left+1, Elatin7::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7414              
7415 0           $i = $left;
7416 0           last;
7417             }
7418             }
7419             }
7420              
7421             # rewrite character class or escape character
7422             elsif (my $char = character_class($char[$i],$modifier)) {
7423 0           $char[$i] = $char;
7424             }
7425              
7426             # split(m/^/) --> split(m/^/m)
7427             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7428 0           $modifier .= 'm';
7429             }
7430              
7431             # /i modifier
7432             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin7::uc($char[$i]) ne Elatin7::fc($char[$i]))) {
7433 0 0         if (CORE::length(Elatin7::fc($char[$i])) == 1) {
7434 0           $char[$i] = '[' . Elatin7::uc($char[$i]) . Elatin7::fc($char[$i]) . ']';
7435             }
7436             else {
7437 0           $char[$i] = '(?:' . Elatin7::uc($char[$i]) . '|' . Elatin7::fc($char[$i]) . ')';
7438             }
7439             }
7440              
7441             # quote character before ? + * {
7442             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7443 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7444             }
7445             else {
7446 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7447             }
7448             }
7449             }
7450              
7451 0           $modifier =~ tr/i//d;
7452 0           return join '', 'Elatin7::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7453             }
7454              
7455             #
7456             # instead of Carp::carp
7457             #
7458             sub carp {
7459 0     0 0   my($package,$filename,$line) = caller(1);
7460 0           print STDERR "@_ at $filename line $line.\n";
7461             }
7462              
7463             #
7464             # instead of Carp::croak
7465             #
7466             sub croak {
7467 0     0 0   my($package,$filename,$line) = caller(1);
7468 0           print STDERR "@_ at $filename line $line.\n";
7469 0           die "\n";
7470             }
7471              
7472             #
7473             # instead of Carp::cluck
7474             #
7475             sub cluck {
7476 0     0 0   my $i = 0;
7477 0           my @cluck = ();
7478 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7479 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7480 0           $i++;
7481             }
7482 0           print STDERR CORE::reverse @cluck;
7483 0           print STDERR "\n";
7484 0           carp @_;
7485             }
7486              
7487             #
7488             # instead of Carp::confess
7489             #
7490             sub confess {
7491 0     0 0   my $i = 0;
7492 0           my @confess = ();
7493 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7494 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7495 0           $i++;
7496             }
7497 0           print STDERR CORE::reverse @confess;
7498 0           print STDERR "\n";
7499 0           croak @_;
7500             }
7501              
7502             1;
7503              
7504             __END__