File Coverage

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


line stmt bran cond sub pod time code
1             package Elatin9;
2             ######################################################################
3             #
4             # Elatin9 - Run-time routines for Latin9.pm
5             #
6             # http://search.cpan.org/dist/Char-Latin9/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3081 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         491  
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   11645 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1157  
  200         290  
  200         25608  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1037 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         243 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         22751 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   11406 CORE::eval q{
  200     200   911  
  200     70   269  
  200         20689  
  56         4738  
  47         3791  
  50         3903  
  47         3826  
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       89118 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65 0         0 BEGIN {
66 200     200   448 my $genpkg = "Symbol::";
67 200         8183 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) && (Elatin9::index($name, '::') == -1) && (Elatin9::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   327 if (CORE::eval { local $@; CORE::require strict }) {
  200         286  
  200         1795  
115 200         19472 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   12858 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   896  
  200         250  
  200         10283  
145 200     200   10798 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   866  
  200         262  
  200         10717  
146 200     200   10113 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   803  
  200         271  
  200         11995  
147              
148             #
149             # Latin-9 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   10874 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   984  
  200         248  
  200         293305  
157              
158             #
159             # Latin-9 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 Elatin9 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-15 | iec[- ]?8859-15 | latin-?9 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\xA6" => "\xA8", # LATIN LETTER S WITH CARON
183             "\xB4" => "\xB8", # LATIN LETTER Z WITH CARON
184             "\xBC" => "\xBD", # LATIN LIGATURE OE
185             "\xBE" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
186             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
187             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
188             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
189             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
190             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
191             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
192             "\xC6" => "\xE6", # LATIN LETTER AE
193             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
194             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
195             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
196             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
197             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
198             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
199             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
200             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
201             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
202             "\xD0" => "\xF0", # LATIN LETTER ETH
203             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
204             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
205             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
206             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
207             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
208             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
209             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
210             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
211             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
212             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
213             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
214             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
215             "\xDE" => "\xFE", # LATIN LETTER THORN
216             );
217              
218             %uc = (%uc,
219             "\xA8" => "\xA6", # LATIN LETTER S WITH CARON
220             "\xB8" => "\xB4", # LATIN LETTER Z WITH CARON
221             "\xBD" => "\xBC", # LATIN LIGATURE OE
222             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
223             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
224             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
225             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
226             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
227             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
228             "\xE6" => "\xC6", # LATIN LETTER AE
229             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
230             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
231             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
232             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
233             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
234             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
235             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
236             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
237             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
238             "\xF0" => "\xD0", # LATIN LETTER ETH
239             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
240             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
241             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
242             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
243             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
244             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
245             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
246             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
247             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
248             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
249             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
250             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
251             "\xFE" => "\xDE", # LATIN LETTER THORN
252             "\xFF" => "\xBE", # LATIN LETTER Y WITH DIAERESIS
253             );
254              
255             %fc = (%fc,
256             "\xA6" => "\xA8", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
257             "\xB4" => "\xB8", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
258             "\xBC" => "\xBD", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
259             "\xBE" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
260             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
261             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
262             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
263             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
264             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
265             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
266             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
267             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
268             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
269             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
270             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
271             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
272             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
273             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
274             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
275             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
276             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
277             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
278             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
279             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
280             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
281             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
282             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
283             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
284             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
285             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
286             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
287             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
288             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
289             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
290             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
291             );
292             }
293              
294             else {
295             croak "Don't know my package name '@{[__PACKAGE__]}'";
296             }
297              
298             #
299             # @ARGV wildcard globbing
300             #
301             sub import {
302              
303 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
304 0         0 my @argv = ();
305 0         0 for (@ARGV) {
306              
307             # has space
308 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
309 0 0       0 if (my @glob = Elatin9::glob(qq{"$_"})) {
310 0         0 push @argv, @glob;
311             }
312             else {
313 0         0 push @argv, $_;
314             }
315             }
316              
317             # has wildcard metachar
318             elsif (/\A (?:$q_char)*? [*?] /oxms) {
319 0 0       0 if (my @glob = Elatin9::glob($_)) {
320 0         0 push @argv, @glob;
321             }
322             else {
323 0         0 push @argv, $_;
324             }
325             }
326              
327             # no wildcard globbing
328             else {
329 0         0 push @argv, $_;
330             }
331             }
332 0         0 @ARGV = @argv;
333             }
334              
335 0         0 *Char::ord = \&Latin9::ord;
336 0         0 *Char::ord_ = \&Latin9::ord_;
337 0         0 *Char::reverse = \&Latin9::reverse;
338 0         0 *Char::getc = \&Latin9::getc;
339 0         0 *Char::length = \&Latin9::length;
340 0         0 *Char::substr = \&Latin9::substr;
341 0         0 *Char::index = \&Latin9::index;
342 0         0 *Char::rindex = \&Latin9::rindex;
343 0         0 *Char::eval = \&Latin9::eval;
344 0         0 *Char::escape = \&Latin9::escape;
345 0         0 *Char::escape_token = \&Latin9::escape_token;
346 0         0 *Char::escape_script = \&Latin9::escape_script;
347             }
348              
349             # P.230 Care with Prototypes
350             # in Chapter 6: Subroutines
351             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
352             #
353             # If you aren't careful, you can get yourself into trouble with prototypes.
354             # But if you are careful, you can do a lot of neat things with them. This is
355             # all very powerful, of course, and should only be used in moderation to make
356             # the world a better place.
357              
358             # P.332 Care with Prototypes
359             # in Chapter 7: Subroutines
360             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
361             #
362             # If you aren't careful, you can get yourself into trouble with prototypes.
363             # But if you are careful, you can do a lot of neat things with them. This is
364             # all very powerful, of course, and should only be used in moderation to make
365             # the world a better place.
366              
367             #
368             # Prototypes of subroutines
369             #
370       0     sub unimport {}
371             sub Elatin9::split(;$$$);
372             sub Elatin9::tr($$$$;$);
373             sub Elatin9::chop(@);
374             sub Elatin9::index($$;$);
375             sub Elatin9::rindex($$;$);
376             sub Elatin9::lcfirst(@);
377             sub Elatin9::lcfirst_();
378             sub Elatin9::lc(@);
379             sub Elatin9::lc_();
380             sub Elatin9::ucfirst(@);
381             sub Elatin9::ucfirst_();
382             sub Elatin9::uc(@);
383             sub Elatin9::uc_();
384             sub Elatin9::fc(@);
385             sub Elatin9::fc_();
386             sub Elatin9::ignorecase;
387             sub Elatin9::classic_character_class;
388             sub Elatin9::capture;
389             sub Elatin9::chr(;$);
390             sub Elatin9::chr_();
391             sub Elatin9::glob($);
392             sub Elatin9::glob_();
393              
394             sub Latin9::ord(;$);
395             sub Latin9::ord_();
396             sub Latin9::reverse(@);
397             sub Latin9::getc(;*@);
398             sub Latin9::length(;$);
399             sub Latin9::substr($$;$$);
400             sub Latin9::index($$;$);
401             sub Latin9::rindex($$;$);
402             sub Latin9::escape(;$);
403              
404             #
405             # Regexp work
406             #
407 200     200   13155 BEGIN { CORE::eval q{ use vars qw(
  200     200   997  
  200         289  
  200         65935  
408             $Latin9::re_a
409             $Latin9::re_t
410             $Latin9::re_n
411             $Latin9::re_r
412             ) } }
413              
414             #
415             # Character class
416             #
417 200     200   13517 BEGIN { CORE::eval q{ use vars qw(
  200     200   905  
  200         288  
  200         2182525  
418             $dot
419             $dot_s
420             $eD
421             $eS
422             $eW
423             $eH
424             $eV
425             $eR
426             $eN
427             $not_alnum
428             $not_alpha
429             $not_ascii
430             $not_blank
431             $not_cntrl
432             $not_digit
433             $not_graph
434             $not_lower
435             $not_lower_i
436             $not_print
437             $not_punct
438             $not_space
439             $not_upper
440             $not_upper_i
441             $not_word
442             $not_xdigit
443             $eb
444             $eB
445             ) } }
446              
447             ${Elatin9::dot} = qr{(?>[^\x0A])};
448             ${Elatin9::dot_s} = qr{(?>[\x00-\xFF])};
449             ${Elatin9::eD} = qr{(?>[^0-9])};
450              
451             # Vertical tabs are now whitespace
452             # \s in a regex now matches a vertical tab in all circumstances.
453             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
454             # ${Elatin9::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
455             # ${Elatin9::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
456             ${Elatin9::eS} = qr{(?>[^\s])};
457              
458             ${Elatin9::eW} = qr{(?>[^0-9A-Z_a-z])};
459             ${Elatin9::eH} = qr{(?>[^\x09\x20])};
460             ${Elatin9::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
461             ${Elatin9::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
462             ${Elatin9::eN} = qr{(?>[^\x0A])};
463             ${Elatin9::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
464             ${Elatin9::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
465             ${Elatin9::not_ascii} = qr{(?>[^\x00-\x7F])};
466             ${Elatin9::not_blank} = qr{(?>[^\x09\x20])};
467             ${Elatin9::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
468             ${Elatin9::not_digit} = qr{(?>[^\x30-\x39])};
469             ${Elatin9::not_graph} = qr{(?>[^\x21-\x7F])};
470             ${Elatin9::not_lower} = qr{(?>[^\x61-\x7A])};
471             ${Elatin9::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
472             # ${Elatin9::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
473             ${Elatin9::not_print} = qr{(?>[^\x20-\x7F])};
474             ${Elatin9::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
475             ${Elatin9::not_space} = qr{(?>[^\s\x0B])};
476             ${Elatin9::not_upper} = qr{(?>[^\x41-\x5A])};
477             ${Elatin9::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
478             # ${Elatin9::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
479             ${Elatin9::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
480             ${Elatin9::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
481             ${Elatin9::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))};
482             ${Elatin9::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]))};
483              
484             # avoid: Name "Elatin9::foo" used only once: possible typo at here.
485             ${Elatin9::dot} = ${Elatin9::dot};
486             ${Elatin9::dot_s} = ${Elatin9::dot_s};
487             ${Elatin9::eD} = ${Elatin9::eD};
488             ${Elatin9::eS} = ${Elatin9::eS};
489             ${Elatin9::eW} = ${Elatin9::eW};
490             ${Elatin9::eH} = ${Elatin9::eH};
491             ${Elatin9::eV} = ${Elatin9::eV};
492             ${Elatin9::eR} = ${Elatin9::eR};
493             ${Elatin9::eN} = ${Elatin9::eN};
494             ${Elatin9::not_alnum} = ${Elatin9::not_alnum};
495             ${Elatin9::not_alpha} = ${Elatin9::not_alpha};
496             ${Elatin9::not_ascii} = ${Elatin9::not_ascii};
497             ${Elatin9::not_blank} = ${Elatin9::not_blank};
498             ${Elatin9::not_cntrl} = ${Elatin9::not_cntrl};
499             ${Elatin9::not_digit} = ${Elatin9::not_digit};
500             ${Elatin9::not_graph} = ${Elatin9::not_graph};
501             ${Elatin9::not_lower} = ${Elatin9::not_lower};
502             ${Elatin9::not_lower_i} = ${Elatin9::not_lower_i};
503             ${Elatin9::not_print} = ${Elatin9::not_print};
504             ${Elatin9::not_punct} = ${Elatin9::not_punct};
505             ${Elatin9::not_space} = ${Elatin9::not_space};
506             ${Elatin9::not_upper} = ${Elatin9::not_upper};
507             ${Elatin9::not_upper_i} = ${Elatin9::not_upper_i};
508             ${Elatin9::not_word} = ${Elatin9::not_word};
509             ${Elatin9::not_xdigit} = ${Elatin9::not_xdigit};
510             ${Elatin9::eb} = ${Elatin9::eb};
511             ${Elatin9::eB} = ${Elatin9::eB};
512              
513             #
514             # Latin-9 split
515             #
516             sub Elatin9::split(;$$$) {
517              
518             # P.794 29.2.161. split
519             # in Chapter 29: Functions
520             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
521              
522             # P.951 split
523             # in Chapter 27: Functions
524             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
525              
526 0     0 0 0 my $pattern = $_[0];
527 0         0 my $string = $_[1];
528 0         0 my $limit = $_[2];
529              
530             # if $pattern is also omitted or is the literal space, " "
531 0 0       0 if (not defined $pattern) {
532 0         0 $pattern = ' ';
533             }
534              
535             # if $string is omitted, the function splits the $_ string
536 0 0       0 if (not defined $string) {
537 0 0       0 if (defined $_) {
538 0         0 $string = $_;
539             }
540             else {
541 0         0 $string = '';
542             }
543             }
544              
545 0         0 my @split = ();
546              
547             # when string is empty
548 0 0       0 if ($string eq '') {
    0          
549              
550             # resulting list value in list context
551 0 0       0 if (wantarray) {
552 0         0 return @split;
553             }
554              
555             # count of substrings in scalar context
556             else {
557 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
558 0         0 @_ = @split;
559 0         0 return scalar @_;
560             }
561             }
562              
563             # split's first argument is more consistently interpreted
564             #
565             # After some changes earlier in v5.17, split's behavior has been simplified:
566             # if the PATTERN argument evaluates to a string containing one space, it is
567             # treated the way that a literal string containing one space once was.
568             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
569              
570             # if $pattern is also omitted or is the literal space, " ", the function splits
571             # on whitespace, /\s+/, after skipping any leading whitespace
572             # (and so on)
573              
574             elsif ($pattern eq ' ') {
575 0 0       0 if (not defined $limit) {
576 0         0 return CORE::split(' ', $string);
577             }
578             else {
579 0         0 return CORE::split(' ', $string, $limit);
580             }
581             }
582              
583             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
584 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
585              
586             # a pattern capable of matching either the null string or something longer than the
587             # null string will split the value of $string into separate characters wherever it
588             # matches the null string between characters
589             # (and so on)
590              
591 0 0       0 if ('' =~ / \A $pattern \z /xms) {
592 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
593 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
594              
595             # P.1024 Appendix W.10 Multibyte Processing
596             # of ISBN 1-56592-224-7 CJKV Information Processing
597             # (and so on)
598              
599             # the //m modifier is assumed when you split on the pattern /^/
600             # (and so on)
601              
602             # V
603 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
604              
605             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
606             # is included in the resulting list, interspersed with the fields that are ordinarily returned
607             # (and so on)
608              
609 0         0 local $@;
610 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
611 0         0 push @split, CORE::eval('$' . $digit);
612             }
613             }
614             }
615              
616             else {
617 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
618              
619             # V
620 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
621 0         0 local $@;
622 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
623 0         0 push @split, CORE::eval('$' . $digit);
624             }
625             }
626             }
627             }
628              
629             elsif ($limit > 0) {
630 0 0       0 if ('' =~ / \A $pattern \z /xms) {
631 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
632 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
633              
634             # V
635 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
636 0         0 local $@;
637 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
638 0         0 push @split, CORE::eval('$' . $digit);
639             }
640             }
641             }
642             }
643             else {
644 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
645 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
646              
647             # V
648 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
649 0         0 local $@;
650 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
651 0         0 push @split, CORE::eval('$' . $digit);
652             }
653             }
654             }
655             }
656             }
657              
658 0 0       0 if (CORE::length($string) > 0) {
659 0         0 push @split, $string;
660             }
661              
662             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
663 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
664 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
665 0         0 pop @split;
666             }
667             }
668              
669             # resulting list value in list context
670 0 0       0 if (wantarray) {
671 0         0 return @split;
672             }
673              
674             # count of substrings in scalar context
675             else {
676 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
677 0         0 @_ = @split;
678 0         0 return scalar @_;
679             }
680             }
681              
682             #
683             # get last subexpression offsets
684             #
685             sub _last_subexpression_offsets {
686 0     0   0 my $pattern = $_[0];
687              
688             # remove comment
689 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
690              
691 0         0 my $modifier = '';
692 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
693 0         0 $modifier = $1;
694 0         0 $modifier =~ s/-[A-Za-z]*//;
695             }
696              
697             # with /x modifier
698 0         0 my @char = ();
699 0 0       0 if ($modifier =~ /x/oxms) {
700 0         0 @char = $pattern =~ /\G((?>
701             [^\\\#\[\(] |
702             \\ $q_char |
703             \# (?>[^\n]*) $ |
704             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
705             \(\? |
706             $q_char
707             ))/oxmsg;
708             }
709              
710             # without /x modifier
711             else {
712 0         0 @char = $pattern =~ /\G((?>
713             [^\\\[\(] |
714             \\ $q_char |
715             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
716             \(\? |
717             $q_char
718             ))/oxmsg;
719             }
720              
721 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
722             }
723              
724             #
725             # Latin-9 transliteration (tr///)
726             #
727             sub Elatin9::tr($$$$;$) {
728              
729 0     0 0 0 my $bind_operator = $_[1];
730 0         0 my $searchlist = $_[2];
731 0         0 my $replacementlist = $_[3];
732 0   0     0 my $modifier = $_[4] || '';
733              
734 0 0       0 if ($modifier =~ /r/oxms) {
735 0 0       0 if ($bind_operator =~ / !~ /oxms) {
736 0         0 croak "Using !~ with tr///r doesn't make sense";
737             }
738             }
739              
740 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
741 0         0 my @searchlist = _charlist_tr($searchlist);
742 0         0 my @replacementlist = _charlist_tr($replacementlist);
743              
744 0         0 my %tr = ();
745 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
746 0 0       0 if (not exists $tr{$searchlist[$i]}) {
747 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
748 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
749             }
750             elsif ($modifier =~ /d/oxms) {
751 0         0 $tr{$searchlist[$i]} = '';
752             }
753             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
754 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
755             }
756             else {
757 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
758             }
759             }
760             }
761              
762 0         0 my $tr = 0;
763 0         0 my $replaced = '';
764 0 0       0 if ($modifier =~ /c/oxms) {
765 0         0 while (defined(my $char = shift @char)) {
766 0 0       0 if (not exists $tr{$char}) {
767 0 0       0 if (defined $replacementlist[0]) {
768 0         0 $replaced .= $replacementlist[0];
769             }
770 0         0 $tr++;
771 0 0       0 if ($modifier =~ /s/oxms) {
772 0   0     0 while (@char and (not exists $tr{$char[0]})) {
773 0         0 shift @char;
774 0         0 $tr++;
775             }
776             }
777             }
778             else {
779 0         0 $replaced .= $char;
780             }
781             }
782             }
783             else {
784 0         0 while (defined(my $char = shift @char)) {
785 0 0       0 if (exists $tr{$char}) {
786 0         0 $replaced .= $tr{$char};
787 0         0 $tr++;
788 0 0       0 if ($modifier =~ /s/oxms) {
789 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
790 0         0 shift @char;
791 0         0 $tr++;
792             }
793             }
794             }
795             else {
796 0         0 $replaced .= $char;
797             }
798             }
799             }
800              
801 0 0       0 if ($modifier =~ /r/oxms) {
802 0         0 return $replaced;
803             }
804             else {
805 0         0 $_[0] = $replaced;
806 0 0       0 if ($bind_operator =~ / !~ /oxms) {
807 0         0 return not $tr;
808             }
809             else {
810 0         0 return $tr;
811             }
812             }
813             }
814              
815             #
816             # Latin-9 chop
817             #
818             sub Elatin9::chop(@) {
819              
820 0     0 0 0 my $chop;
821 0 0       0 if (@_ == 0) {
822 0         0 my @char = /\G (?>$q_char) /oxmsg;
823 0         0 $chop = pop @char;
824 0         0 $_ = join '', @char;
825             }
826             else {
827 0         0 for (@_) {
828 0         0 my @char = /\G (?>$q_char) /oxmsg;
829 0         0 $chop = pop @char;
830 0         0 $_ = join '', @char;
831             }
832             }
833 0         0 return $chop;
834             }
835              
836             #
837             # Latin-9 index by octet
838             #
839             sub Elatin9::index($$;$) {
840              
841 0     0 1 0 my($str,$substr,$position) = @_;
842 0   0     0 $position ||= 0;
843 0         0 my $pos = 0;
844              
845 0         0 while ($pos < CORE::length($str)) {
846 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
847 0 0       0 if ($pos >= $position) {
848 0         0 return $pos;
849             }
850             }
851 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
852 0         0 $pos += CORE::length($1);
853             }
854             else {
855 0         0 $pos += 1;
856             }
857             }
858 0         0 return -1;
859             }
860              
861             #
862             # Latin-9 reverse index
863             #
864             sub Elatin9::rindex($$;$) {
865              
866 0     0 0 0 my($str,$substr,$position) = @_;
867 0   0     0 $position ||= CORE::length($str) - 1;
868 0         0 my $pos = 0;
869 0         0 my $rindex = -1;
870              
871 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
872 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
873 0         0 $rindex = $pos;
874             }
875 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
876 0         0 $pos += CORE::length($1);
877             }
878             else {
879 0         0 $pos += 1;
880             }
881             }
882 0         0 return $rindex;
883             }
884              
885             #
886             # Latin-9 lower case first with parameter
887             #
888             sub Elatin9::lcfirst(@) {
889 0 0   0 0 0 if (@_) {
890 0         0 my $s = shift @_;
891 0 0 0     0 if (@_ and wantarray) {
892 0         0 return Elatin9::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
893             }
894             else {
895 0         0 return Elatin9::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
896             }
897             }
898             else {
899 0         0 return Elatin9::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
900             }
901             }
902              
903             #
904             # Latin-9 lower case first without parameter
905             #
906             sub Elatin9::lcfirst_() {
907 0     0 0 0 return Elatin9::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
908             }
909              
910             #
911             # Latin-9 lower case with parameter
912             #
913             sub Elatin9::lc(@) {
914 0 0   0 0 0 if (@_) {
915 0         0 my $s = shift @_;
916 0 0 0     0 if (@_ and wantarray) {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
918             }
919             else {
920 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
921             }
922             }
923             else {
924 0         0 return Elatin9::lc_();
925             }
926             }
927              
928             #
929             # Latin-9 lower case without parameter
930             #
931             sub Elatin9::lc_() {
932 0     0 0 0 my $s = $_;
933 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
934             }
935              
936             #
937             # Latin-9 upper case first with parameter
938             #
939             sub Elatin9::ucfirst(@) {
940 0 0   0 0 0 if (@_) {
941 0         0 my $s = shift @_;
942 0 0 0     0 if (@_ and wantarray) {
943 0         0 return Elatin9::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
944             }
945             else {
946 0         0 return Elatin9::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
947             }
948             }
949             else {
950 0         0 return Elatin9::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
951             }
952             }
953              
954             #
955             # Latin-9 upper case first without parameter
956             #
957             sub Elatin9::ucfirst_() {
958 0     0 0 0 return Elatin9::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
959             }
960              
961             #
962             # Latin-9 upper case with parameter
963             #
964             sub Elatin9::uc(@) {
965 174 50   174 0 227 if (@_) {
966 174         176 my $s = shift @_;
967 174 50 33     338 if (@_ and wantarray) {
968 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
969             }
970             else {
971 174 100       550 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         593  
972             }
973             }
974             else {
975 0         0 return Elatin9::uc_();
976             }
977             }
978              
979             #
980             # Latin-9 upper case without parameter
981             #
982             sub Elatin9::uc_() {
983 0     0 0 0 my $s = $_;
984 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
985             }
986              
987             #
988             # Latin-9 fold case with parameter
989             #
990             sub Elatin9::fc(@) {
991 197 50   197 0 228 if (@_) {
992 197         157 my $s = shift @_;
993 197 50 33     340 if (@_ and wantarray) {
994 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
995             }
996             else {
997 197 100       453 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         1079  
998             }
999             }
1000             else {
1001 0         0 return Elatin9::fc_();
1002             }
1003             }
1004              
1005             #
1006             # Latin-9 fold case without parameter
1007             #
1008             sub Elatin9::fc_() {
1009 0     0 0 0 my $s = $_;
1010 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1011             }
1012              
1013             #
1014             # Latin-9 regexp capture
1015             #
1016             {
1017             sub Elatin9::capture {
1018 0     0 1 0 return $_[0];
1019             }
1020             }
1021              
1022             #
1023             # Latin-9 regexp ignore case modifier
1024             #
1025             sub Elatin9::ignorecase {
1026              
1027 0     0 0 0 my @string = @_;
1028 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1029              
1030             # ignore case of $scalar or @array
1031 0         0 for my $string (@string) {
1032              
1033             # split regexp
1034 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1035              
1036             # unescape character
1037 0         0 for (my $i=0; $i <= $#char; $i++) {
1038 0 0       0 next if not defined $char[$i];
1039              
1040             # open character class [...]
1041 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1042 0         0 my $left = $i;
1043              
1044             # [] make die "unmatched [] in regexp ...\n"
1045              
1046 0 0       0 if ($char[$i+1] eq ']') {
1047 0         0 $i++;
1048             }
1049              
1050 0         0 while (1) {
1051 0 0       0 if (++$i > $#char) {
1052 0         0 croak "Unmatched [] in regexp";
1053             }
1054 0 0       0 if ($char[$i] eq ']') {
1055 0         0 my $right = $i;
1056 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1057              
1058             # escape character
1059 0         0 for my $char (@charlist) {
1060 0 0       0 if (0) {
1061             }
1062              
1063 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1064 0         0 $char = '\\' . $char;
1065             }
1066             }
1067              
1068             # [...]
1069 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1070              
1071 0         0 $i = $left;
1072 0         0 last;
1073             }
1074             }
1075             }
1076              
1077             # open character class [^...]
1078             elsif ($char[$i] eq '[^') {
1079 0         0 my $left = $i;
1080              
1081             # [^] make die "unmatched [] in regexp ...\n"
1082              
1083 0 0       0 if ($char[$i+1] eq ']') {
1084 0         0 $i++;
1085             }
1086              
1087 0         0 while (1) {
1088 0 0       0 if (++$i > $#char) {
1089 0         0 croak "Unmatched [] in regexp";
1090             }
1091 0 0       0 if ($char[$i] eq ']') {
1092 0         0 my $right = $i;
1093 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1094              
1095             # escape character
1096 0         0 for my $char (@charlist) {
1097 0 0       0 if (0) {
1098             }
1099              
1100 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1101 0         0 $char = '\\' . $char;
1102             }
1103             }
1104              
1105             # [^...]
1106 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1107              
1108 0         0 $i = $left;
1109 0         0 last;
1110             }
1111             }
1112             }
1113              
1114             # rewrite classic character class or escape character
1115             elsif (my $char = classic_character_class($char[$i])) {
1116 0         0 $char[$i] = $char;
1117             }
1118              
1119             # with /i modifier
1120             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1121 0         0 my $uc = Elatin9::uc($char[$i]);
1122 0         0 my $fc = Elatin9::fc($char[$i]);
1123 0 0       0 if ($uc ne $fc) {
1124 0 0       0 if (CORE::length($fc) == 1) {
1125 0         0 $char[$i] = '[' . $uc . $fc . ']';
1126             }
1127             else {
1128 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1129             }
1130             }
1131             }
1132             }
1133              
1134             # characterize
1135 0         0 for (my $i=0; $i <= $#char; $i++) {
1136 0 0       0 next if not defined $char[$i];
1137              
1138 0 0       0 if (0) {
1139             }
1140              
1141             # quote character before ? + * {
1142 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1143 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1144 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1145             }
1146             }
1147             }
1148              
1149 0         0 $string = join '', @char;
1150             }
1151              
1152             # make regexp string
1153 0         0 return @string;
1154             }
1155              
1156             #
1157             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1158             #
1159             sub Elatin9::classic_character_class {
1160 1862     1862 0 1696 my($char) = @_;
1161              
1162             return {
1163             '\D' => '${Elatin9::eD}',
1164             '\S' => '${Elatin9::eS}',
1165             '\W' => '${Elatin9::eW}',
1166             '\d' => '[0-9]',
1167              
1168             # Before Perl 5.6, \s only matched the five whitespace characters
1169             # tab, newline, form-feed, carriage return, and the space character
1170             # itself, which, taken together, is the character class [\t\n\f\r ].
1171              
1172             # Vertical tabs are now whitespace
1173             # \s in a regex now matches a vertical tab in all circumstances.
1174             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1175             # \t \n \v \f \r space
1176             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1177             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1178             '\s' => '\s',
1179              
1180             '\w' => '[0-9A-Z_a-z]',
1181             '\C' => '[\x00-\xFF]',
1182             '\X' => 'X',
1183              
1184             # \h \v \H \V
1185              
1186             # P.114 Character Class Shortcuts
1187             # in Chapter 7: In the World of Regular Expressions
1188             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1189              
1190             # P.357 13.2.3 Whitespace
1191             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1192             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1193             #
1194             # 0x00009 CHARACTER TABULATION h s
1195             # 0x0000a LINE FEED (LF) vs
1196             # 0x0000b LINE TABULATION v
1197             # 0x0000c FORM FEED (FF) vs
1198             # 0x0000d CARRIAGE RETURN (CR) vs
1199             # 0x00020 SPACE h s
1200              
1201             # P.196 Table 5-9. Alphanumeric regex metasymbols
1202             # in Chapter 5. Pattern Matching
1203             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1204              
1205             # (and so on)
1206              
1207             '\H' => '${Elatin9::eH}',
1208             '\V' => '${Elatin9::eV}',
1209             '\h' => '[\x09\x20]',
1210             '\v' => '[\x0A\x0B\x0C\x0D]',
1211             '\R' => '${Elatin9::eR}',
1212              
1213             # \N
1214             #
1215             # http://perldoc.perl.org/perlre.html
1216             # Character Classes and other Special Escapes
1217             # Any character but \n (experimental). Not affected by /s modifier
1218              
1219             '\N' => '${Elatin9::eN}',
1220              
1221             # \b \B
1222              
1223             # P.180 Boundaries: The \b and \B Assertions
1224             # in Chapter 5: Pattern Matching
1225             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1226              
1227             # P.219 Boundaries: The \b and \B Assertions
1228             # in Chapter 5: Pattern Matching
1229             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1230              
1231             # \b really means (?:(?<=\w)(?!\w)|(?
1232             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1233             '\b' => '${Elatin9::eb}',
1234              
1235             # \B really means (?:(?<=\w)(?=\w)|(?
1236             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1237             '\B' => '${Elatin9::eB}',
1238              
1239 1862   100     74448 }->{$char} || '';
1240             }
1241              
1242             #
1243             # prepare Latin-9 characters per length
1244             #
1245              
1246             # 1 octet characters
1247             my @chars1 = ();
1248             sub chars1 {
1249 0 0   0 0 0 if (@chars1) {
1250 0         0 return @chars1;
1251             }
1252 0 0       0 if (exists $range_tr{1}) {
1253 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1254 0         0 while (my @range = splice(@ranges,0,1)) {
1255 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1256 0         0 push @chars1, pack 'C', $oct0;
1257             }
1258             }
1259             }
1260 0         0 return @chars1;
1261             }
1262              
1263             # 2 octets characters
1264             my @chars2 = ();
1265             sub chars2 {
1266 0 0   0 0 0 if (@chars2) {
1267 0         0 return @chars2;
1268             }
1269 0 0       0 if (exists $range_tr{2}) {
1270 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1271 0         0 while (my @range = splice(@ranges,0,2)) {
1272 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1273 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1274 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1275             }
1276             }
1277             }
1278             }
1279 0         0 return @chars2;
1280             }
1281              
1282             # 3 octets characters
1283             my @chars3 = ();
1284             sub chars3 {
1285 0 0   0 0 0 if (@chars3) {
1286 0         0 return @chars3;
1287             }
1288 0 0       0 if (exists $range_tr{3}) {
1289 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1290 0         0 while (my @range = splice(@ranges,0,3)) {
1291 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1292 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1293 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1294 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1295             }
1296             }
1297             }
1298             }
1299             }
1300 0         0 return @chars3;
1301             }
1302              
1303             # 4 octets characters
1304             my @chars4 = ();
1305             sub chars4 {
1306 0 0   0 0 0 if (@chars4) {
1307 0         0 return @chars4;
1308             }
1309 0 0       0 if (exists $range_tr{4}) {
1310 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1311 0         0 while (my @range = splice(@ranges,0,4)) {
1312 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1313 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1314 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1315 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1316 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1317             }
1318             }
1319             }
1320             }
1321             }
1322             }
1323 0         0 return @chars4;
1324             }
1325              
1326             #
1327             # Latin-9 open character list for tr
1328             #
1329             sub _charlist_tr {
1330              
1331 0     0   0 local $_ = shift @_;
1332              
1333             # unescape character
1334 0         0 my @char = ();
1335 0         0 while (not /\G \z/oxmsgc) {
1336 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1337 0         0 push @char, '\-';
1338             }
1339             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(oct $1);
1341             }
1342             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1343 0         0 push @char, CORE::chr(hex $1);
1344             }
1345             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1346 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1347             }
1348             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1349             push @char, {
1350             '\0' => "\0",
1351             '\n' => "\n",
1352             '\r' => "\r",
1353             '\t' => "\t",
1354             '\f' => "\f",
1355             '\b' => "\x08", # \b means backspace in character class
1356             '\a' => "\a",
1357             '\e' => "\e",
1358 0         0 }->{$1};
1359             }
1360             elsif (/\G \\ ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             elsif (/\G ($q_char) /oxmsgc) {
1364 0         0 push @char, $1;
1365             }
1366             }
1367              
1368             # join separated multiple-octet
1369 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1370              
1371             # unescape '-'
1372 0         0 my @i = ();
1373 0         0 for my $i (0 .. $#char) {
1374 0 0       0 if ($char[$i] eq '\-') {
    0          
1375 0         0 $char[$i] = '-';
1376             }
1377             elsif ($char[$i] eq '-') {
1378 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1379 0         0 push @i, $i;
1380             }
1381             }
1382             }
1383              
1384             # open character list (reverse for splice)
1385 0         0 for my $i (CORE::reverse @i) {
1386 0         0 my @range = ();
1387              
1388             # range error
1389 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1390 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1391             }
1392              
1393             # range of multiple-octet code
1394 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1395 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1396 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1397             }
1398             elsif (CORE::length($char[$i+1]) == 2) {
1399 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1400 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1401             }
1402             elsif (CORE::length($char[$i+1]) == 3) {
1403 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1404 0         0 push @range, chars2();
1405 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1406             }
1407             elsif (CORE::length($char[$i+1]) == 4) {
1408 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1409 0         0 push @range, chars2();
1410 0         0 push @range, chars3();
1411 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1412             }
1413             else {
1414 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1415             }
1416             }
1417             elsif (CORE::length($char[$i-1]) == 2) {
1418 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1419 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1420             }
1421             elsif (CORE::length($char[$i+1]) == 3) {
1422 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 4) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1427 0         0 push @range, chars3();
1428 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1429             }
1430             else {
1431 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1432             }
1433             }
1434             elsif (CORE::length($char[$i-1]) == 3) {
1435 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1436 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1437             }
1438             elsif (CORE::length($char[$i+1]) == 4) {
1439 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1440 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1441             }
1442             else {
1443 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1444             }
1445             }
1446             elsif (CORE::length($char[$i-1]) == 4) {
1447 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1448 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1449             }
1450             else {
1451 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1452             }
1453             }
1454             else {
1455 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1456             }
1457              
1458 0         0 splice @char, $i-1, 3, @range;
1459             }
1460              
1461 0         0 return @char;
1462             }
1463              
1464             #
1465             # Latin-9 open character class
1466             #
1467             sub _cc {
1468 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1469 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1470             }
1471             elsif (scalar(@_) == 1) {
1472 0         0 return sprintf('\x%02X',$_[0]);
1473             }
1474             elsif (scalar(@_) == 2) {
1475 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1476 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1477             }
1478             elsif ($_[0] == $_[1]) {
1479 0         0 return sprintf('\x%02X',$_[0]);
1480             }
1481             elsif (($_[0]+1) == $_[1]) {
1482 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1483             }
1484             else {
1485 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1486             }
1487             }
1488             else {
1489 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1490             }
1491             }
1492              
1493             #
1494             # Latin-9 octet range
1495             #
1496             sub _octets {
1497 182     182   258 my $length = shift @_;
1498              
1499 182 50       349 if ($length == 1) {
1500 182         518 my($a1) = unpack 'C', $_[0];
1501 182         290 my($z1) = unpack 'C', $_[1];
1502              
1503 182 50       357 if ($a1 > $z1) {
1504 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1505             }
1506              
1507 182 50       459 if ($a1 == $z1) {
    50          
1508 0         0 return sprintf('\x%02X',$a1);
1509             }
1510             elsif (($a1+1) == $z1) {
1511 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1512             }
1513             else {
1514 182         1265 return sprintf('\x%02X-\x%02X',$a1,$z1);
1515             }
1516             }
1517             else {
1518 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1519             }
1520             }
1521              
1522             #
1523             # Latin-9 range regexp
1524             #
1525             sub _range_regexp {
1526 182     182   269 my($length,$first,$last) = @_;
1527              
1528 182         221 my @range_regexp = ();
1529 182 50       475 if (not exists $range_tr{$length}) {
1530 0         0 return @range_regexp;
1531             }
1532              
1533 182         175 my @ranges = @{ $range_tr{$length} };
  182         583  
1534 182         687 while (my @range = splice(@ranges,0,$length)) {
1535 182         210 my $min = '';
1536 182         173 my $max = '';
1537 182         425 for (my $i=0; $i < $length; $i++) {
1538 182         752 $min .= pack 'C', $range[$i][0];
1539 182         465 $max .= pack 'C', $range[$i][-1];
1540             }
1541              
1542             # min___max
1543             # FIRST_____________LAST
1544             # (nothing)
1545              
1546 182 50 33     2257 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1547             }
1548              
1549             # **********
1550             # min_________max
1551             # FIRST_____________LAST
1552             # **********
1553              
1554             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1555 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1556             }
1557              
1558             # **********************
1559             # min________________max
1560             # FIRST_____________LAST
1561             # **********************
1562              
1563             elsif (($min eq $first) and ($max eq $last)) {
1564 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1565             }
1566              
1567             # *********
1568             # min___max
1569             # FIRST_____________LAST
1570             # *********
1571              
1572             elsif (($first le $min) and ($max le $last)) {
1573 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1574             }
1575              
1576             # **********************
1577             # min__________________________max
1578             # FIRST_____________LAST
1579             # **********************
1580              
1581             elsif (($min le $first) and ($last le $max)) {
1582 182         412 push @range_regexp, _octets($length,$first,$last,$min,$max);
1583             }
1584              
1585             # *********
1586             # min________max
1587             # FIRST_____________LAST
1588             # *********
1589              
1590             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1591 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1592             }
1593              
1594             # min___max
1595             # FIRST_____________LAST
1596             # (nothing)
1597              
1598             elsif ($last lt $min) {
1599             }
1600              
1601             else {
1602 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1603             }
1604             }
1605              
1606 182         359 return @range_regexp;
1607             }
1608              
1609             #
1610             # Latin-9 open character list for qr and not qr
1611             #
1612             sub _charlist {
1613              
1614 358     358   480 my $modifier = pop @_;
1615 358         628 my @char = @_;
1616              
1617 358 100       722 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1618              
1619             # unescape character
1620 358         950 for (my $i=0; $i <= $#char; $i++) {
1621              
1622             # escape - to ...
1623 1125 100 100     9085 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1624 206 100 100     938 if ((0 < $i) and ($i < $#char)) {
1625 182         387 $char[$i] = '...';
1626             }
1627             }
1628              
1629             # octal escape sequence
1630             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1631 0         0 $char[$i] = octchr($1);
1632             }
1633              
1634             # hexadecimal escape sequence
1635             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1636 0         0 $char[$i] = hexchr($1);
1637             }
1638              
1639             # \b{...} --> b\{...}
1640             # \B{...} --> B\{...}
1641             # \N{CHARNAME} --> N\{CHARNAME}
1642             # \p{PROPERTY} --> p\{PROPERTY}
1643             # \P{PROPERTY} --> P\{PROPERTY}
1644             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1645 0         0 $char[$i] = $1 . '\\' . $2;
1646             }
1647              
1648             # \p, \P, \X --> p, P, X
1649             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1650 0         0 $char[$i] = $1;
1651             }
1652              
1653             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr oct $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1657 22         108 $char[$i] = CORE::chr hex $1;
1658             }
1659             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1660 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1661             }
1662             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1663             $char[$i] = {
1664             '\0' => "\0",
1665             '\n' => "\n",
1666             '\r' => "\r",
1667             '\t' => "\t",
1668             '\f' => "\f",
1669             '\b' => "\x08", # \b means backspace in character class
1670             '\a' => "\a",
1671             '\e' => "\e",
1672             '\d' => '[0-9]',
1673              
1674             # Vertical tabs are now whitespace
1675             # \s in a regex now matches a vertical tab in all circumstances.
1676             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1677             # \t \n \v \f \r space
1678             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1679             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1680             '\s' => '\s',
1681              
1682             '\w' => '[0-9A-Z_a-z]',
1683             '\D' => '${Elatin9::eD}',
1684             '\S' => '${Elatin9::eS}',
1685             '\W' => '${Elatin9::eW}',
1686              
1687             '\H' => '${Elatin9::eH}',
1688             '\V' => '${Elatin9::eV}',
1689             '\h' => '[\x09\x20]',
1690             '\v' => '[\x0A\x0B\x0C\x0D]',
1691             '\R' => '${Elatin9::eR}',
1692              
1693 25         353 }->{$1};
1694             }
1695              
1696             # POSIX-style character classes
1697             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1698             $char[$i] = {
1699              
1700             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1701             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1702             '[:^lower:]' => '${Elatin9::not_lower_i}',
1703             '[:^upper:]' => '${Elatin9::not_upper_i}',
1704              
1705 8         60 }->{$1};
1706             }
1707             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1708             $char[$i] = {
1709              
1710             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1711             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1712             '[:ascii:]' => '[\x00-\x7F]',
1713             '[:blank:]' => '[\x09\x20]',
1714             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1715             '[:digit:]' => '[\x30-\x39]',
1716             '[:graph:]' => '[\x21-\x7F]',
1717             '[:lower:]' => '[\x61-\x7A]',
1718             '[:print:]' => '[\x20-\x7F]',
1719             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1720              
1721             # P.174 POSIX-Style Character Classes
1722             # in Chapter 5: Pattern Matching
1723             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1724              
1725             # P.311 11.2.4 Character Classes and other Special Escapes
1726             # in Chapter 11: perlre: Perl regular expressions
1727             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1728              
1729             # P.210 POSIX-Style Character Classes
1730             # in Chapter 5: Pattern Matching
1731             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1732              
1733             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1734              
1735             '[:upper:]' => '[\x41-\x5A]',
1736             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1737             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1738             '[:^alnum:]' => '${Elatin9::not_alnum}',
1739             '[:^alpha:]' => '${Elatin9::not_alpha}',
1740             '[:^ascii:]' => '${Elatin9::not_ascii}',
1741             '[:^blank:]' => '${Elatin9::not_blank}',
1742             '[:^cntrl:]' => '${Elatin9::not_cntrl}',
1743             '[:^digit:]' => '${Elatin9::not_digit}',
1744             '[:^graph:]' => '${Elatin9::not_graph}',
1745             '[:^lower:]' => '${Elatin9::not_lower}',
1746             '[:^print:]' => '${Elatin9::not_print}',
1747             '[:^punct:]' => '${Elatin9::not_punct}',
1748             '[:^space:]' => '${Elatin9::not_space}',
1749             '[:^upper:]' => '${Elatin9::not_upper}',
1750             '[:^word:]' => '${Elatin9::not_word}',
1751             '[:^xdigit:]' => '${Elatin9::not_xdigit}',
1752              
1753 70         1183 }->{$1};
1754             }
1755             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1756 7         33 $char[$i] = $1;
1757             }
1758             }
1759              
1760             # open character list
1761 358         513 my @singleoctet = ();
1762 358         386 my @multipleoctet = ();
1763 358         804 for (my $i=0; $i <= $#char; ) {
1764              
1765             # escaped -
1766 943 100 100     4117 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1767 182         186 $i += 1;
1768 182         349 next;
1769             }
1770              
1771             # make range regexp
1772             elsif ($char[$i] eq '...') {
1773              
1774             # range error
1775 182 50       744 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1776 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1777             }
1778             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1779 182 50       458 if ($char[$i-1] gt $char[$i+1]) {
1780 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]);
1781             }
1782             }
1783              
1784             # make range regexp per length
1785 182         558 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1786 182         225 my @regexp = ();
1787              
1788             # is first and last
1789 182 50 33     822 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1790 182         499 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1791             }
1792              
1793             # is first
1794             elsif ($length == CORE::length($char[$i-1])) {
1795 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1796             }
1797              
1798             # is inside in first and last
1799             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1800 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1801             }
1802              
1803             # is last
1804             elsif ($length == CORE::length($char[$i+1])) {
1805 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1806             }
1807              
1808             else {
1809 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1810             }
1811              
1812 182 50       406 if ($length == 1) {
1813 182         357 push @singleoctet, @regexp;
1814             }
1815             else {
1816 0         0 push @multipleoctet, @regexp;
1817             }
1818             }
1819              
1820 182         394 $i += 2;
1821             }
1822              
1823             # with /i modifier
1824             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1825 493 100       583 if ($modifier =~ /i/oxms) {
1826 24         51 my $uc = Elatin9::uc($char[$i]);
1827 24         71 my $fc = Elatin9::fc($char[$i]);
1828 24 100       35 if ($uc ne $fc) {
1829 12 50       20 if (CORE::length($fc) == 1) {
1830 12         15 push @singleoctet, $uc, $fc;
1831             }
1832             else {
1833 0         0 push @singleoctet, $uc;
1834 0         0 push @multipleoctet, $fc;
1835             }
1836             }
1837             else {
1838 12         19 push @singleoctet, $char[$i];
1839             }
1840             }
1841             else {
1842 469         536 push @singleoctet, $char[$i];
1843             }
1844 493         691 $i += 1;
1845             }
1846              
1847             # single character of single octet code
1848             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1849 0         0 push @singleoctet, "\t", "\x20";
1850 0         0 $i += 1;
1851             }
1852             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1853 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1854 0         0 $i += 1;
1855             }
1856             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1857 2         5 push @singleoctet, $char[$i];
1858 2         5 $i += 1;
1859             }
1860              
1861             # single character of multiple-octet code
1862             else {
1863 84         120 push @multipleoctet, $char[$i];
1864 84         148 $i += 1;
1865             }
1866             }
1867              
1868             # quote metachar
1869 358         655 for (@singleoctet) {
1870 689 50       3041 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1871 0         0 $_ = '-';
1872             }
1873             elsif (/\A \n \z/oxms) {
1874 8         16 $_ = '\n';
1875             }
1876             elsif (/\A \r \z/oxms) {
1877 8         12 $_ = '\r';
1878             }
1879             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1880 60         183 $_ = sprintf('\x%02X', CORE::ord $1);
1881             }
1882             elsif (/\A [\x00-\xFF] \z/oxms) {
1883 429         488 $_ = quotemeta $_;
1884             }
1885             }
1886              
1887             # return character list
1888 358         964 return \@singleoctet, \@multipleoctet;
1889             }
1890              
1891             #
1892             # Latin-9 octal escape sequence
1893             #
1894             sub octchr {
1895 5     5 0 10 my($octdigit) = @_;
1896              
1897 5         7 my @binary = ();
1898 5         15 for my $octal (split(//,$octdigit)) {
1899             push @binary, {
1900             '0' => '000',
1901             '1' => '001',
1902             '2' => '010',
1903             '3' => '011',
1904             '4' => '100',
1905             '5' => '101',
1906             '6' => '110',
1907             '7' => '111',
1908 50         136 }->{$octal};
1909             }
1910 5         11 my $binary = join '', @binary;
1911              
1912             my $octchr = {
1913             # 1234567
1914             1 => pack('B*', "0000000$binary"),
1915             2 => pack('B*', "000000$binary"),
1916             3 => pack('B*', "00000$binary"),
1917             4 => pack('B*', "0000$binary"),
1918             5 => pack('B*', "000$binary"),
1919             6 => pack('B*', "00$binary"),
1920             7 => pack('B*', "0$binary"),
1921             0 => pack('B*', "$binary"),
1922              
1923 5         59 }->{CORE::length($binary) % 8};
1924              
1925 5         19 return $octchr;
1926             }
1927              
1928             #
1929             # Latin-9 hexadecimal escape sequence
1930             #
1931             sub hexchr {
1932 5     5 0 12 my($hexdigit) = @_;
1933              
1934             my $hexchr = {
1935             1 => pack('H*', "0$hexdigit"),
1936             0 => pack('H*', "$hexdigit"),
1937              
1938 5         43 }->{CORE::length($_[0]) % 2};
1939              
1940 5         17 return $hexchr;
1941             }
1942              
1943             #
1944             # Latin-9 open character list for qr
1945             #
1946             sub charlist_qr {
1947              
1948 314     314 0 515 my $modifier = pop @_;
1949 314         670 my @char = @_;
1950              
1951 314         756 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1952 314         558 my @singleoctet = @$singleoctet;
1953 314         432 my @multipleoctet = @$multipleoctet;
1954              
1955             # return character list
1956 314 100       687 if (scalar(@singleoctet) >= 1) {
1957              
1958             # with /i modifier
1959 236 100       501 if ($modifier =~ m/i/oxms) {
1960 22         69 my %singleoctet_ignorecase = ();
1961 22         32 for (@singleoctet) {
1962 46   100     219 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1963 46         150 for my $ord (hex($1) .. hex($2)) {
1964 66         79 my $char = CORE::chr($ord);
1965 66         93 my $uc = Elatin9::uc($char);
1966 66         110 my $fc = Elatin9::fc($char);
1967 66 100       102 if ($uc eq $fc) {
1968 12         87 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1969             }
1970             else {
1971 54 50       79 if (CORE::length($fc) == 1) {
1972 54         113 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1973 54         244 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1974             }
1975             else {
1976 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1977 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1978             }
1979             }
1980             }
1981             }
1982 46 50       93 if ($_ ne '') {
1983 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1984             }
1985             }
1986 22         26 my $i = 0;
1987 22         26 my @singleoctet_ignorecase = ();
1988 22         38 for my $ord (0 .. 255) {
1989 5632 100       5403 if (exists $singleoctet_ignorecase{$ord}) {
1990 96         66 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         204  
1991             }
1992             else {
1993 5536         3988 $i++;
1994             }
1995             }
1996 22         51 @singleoctet = ();
1997 22         72 for my $range (@singleoctet_ignorecase) {
1998 3648 100       5293 if (ref $range) {
1999 56 100       43 if (scalar(@{$range}) == 1) {
  56 50       108  
2000 36         27 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         132  
2001             }
2002 20         30 elsif (scalar(@{$range}) == 2) {
2003 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2004             }
2005             else {
2006 20         25 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         41  
  20         120  
2007             }
2008             }
2009             }
2010             }
2011              
2012 236         294 my $not_anchor = '';
2013              
2014 236         590 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2015             }
2016 314 100       588 if (scalar(@multipleoctet) >= 2) {
2017 6         26 return '(?:' . join('|', @multipleoctet) . ')';
2018             }
2019             else {
2020 308         1269 return $multipleoctet[0];
2021             }
2022             }
2023              
2024             #
2025             # Latin-9 open character list for not qr
2026             #
2027             sub charlist_not_qr {
2028              
2029 44     44 0 65 my $modifier = pop @_;
2030 44         86 my @char = @_;
2031              
2032 44         117 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2033 44         85 my @singleoctet = @$singleoctet;
2034 44         56 my @multipleoctet = @$multipleoctet;
2035              
2036             # with /i modifier
2037 44 100       97 if ($modifier =~ m/i/oxms) {
2038 10         12 my %singleoctet_ignorecase = ();
2039 10         14 for (@singleoctet) {
2040 10   66     39 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2041 10         29 for my $ord (hex($1) .. hex($2)) {
2042 30         30 my $char = CORE::chr($ord);
2043 30         40 my $uc = Elatin9::uc($char);
2044 30         37 my $fc = Elatin9::fc($char);
2045 30 50       50 if ($uc eq $fc) {
2046 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2047             }
2048             else {
2049 30 50       33 if (CORE::length($fc) == 1) {
2050 30         53 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2051 30         88 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2052             }
2053             else {
2054 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2055 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2056             }
2057             }
2058             }
2059             }
2060 10 50       21 if ($_ ne '') {
2061 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2062             }
2063             }
2064 10         10 my $i = 0;
2065 10         11 my @singleoctet_ignorecase = ();
2066 10         12 for my $ord (0 .. 255) {
2067 2560 100       2205 if (exists $singleoctet_ignorecase{$ord}) {
2068 60         33 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         83  
2069             }
2070             else {
2071 2500         1598 $i++;
2072             }
2073             }
2074 10         19 @singleoctet = ();
2075 10         24 for my $range (@singleoctet_ignorecase) {
2076 960 100       1633 if (ref $range) {
2077 20 50       11 if (scalar(@{$range}) == 1) {
  20 50       29  
2078 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2079             }
2080 20         25 elsif (scalar(@{$range}) == 2) {
2081 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2082             }
2083             else {
2084 20         15 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         18  
  20         83  
2085             }
2086             }
2087             }
2088             }
2089              
2090             # return character list
2091 44 50       82 if (scalar(@multipleoctet) >= 1) {
2092 0 0       0 if (scalar(@singleoctet) >= 1) {
2093              
2094             # any character other than multiple-octet and single octet character class
2095 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2096             }
2097             else {
2098              
2099             # any character other than multiple-octet character class
2100 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2101             }
2102             }
2103             else {
2104 44 50       78 if (scalar(@singleoctet) >= 1) {
2105              
2106             # any character other than single octet character class
2107 44         503 return '(?:[^' . join('', @singleoctet) . '])';
2108             }
2109             else {
2110              
2111             # any character
2112 0         0 return "(?:$your_char)";
2113             }
2114             }
2115             }
2116              
2117             #
2118             # open file in read mode
2119             #
2120             sub _open_r {
2121 400     400   948 my(undef,$file) = @_;
2122 400         2537 $file =~ s#\A (\s) #./$1#oxms;
2123 400   33     32541 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2124             open($_[0],"< $file\0");
2125             }
2126              
2127             #
2128             # open file in write mode
2129             #
2130             sub _open_w {
2131 0     0   0 my(undef,$file) = @_;
2132 0         0 $file =~ s#\A (\s) #./$1#oxms;
2133 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2134             open($_[0],"> $file\0");
2135             }
2136              
2137             #
2138             # open file in append mode
2139             #
2140             sub _open_a {
2141 0     0   0 my(undef,$file) = @_;
2142 0         0 $file =~ s#\A (\s) #./$1#oxms;
2143 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2144             open($_[0],">> $file\0");
2145             }
2146              
2147             #
2148             # safe system
2149             #
2150             sub _systemx {
2151              
2152             # P.707 29.2.33. exec
2153             # in Chapter 29: Functions
2154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2155             #
2156             # Be aware that in older releases of Perl, exec (and system) did not flush
2157             # your output buffer, so you needed to enable command buffering by setting $|
2158             # on one or more filehandles to avoid lost output in the case of exec, or
2159             # misordererd output in the case of system. This situation was largely remedied
2160             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2161              
2162             # P.855 exec
2163             # in Chapter 27: Functions
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165             #
2166             # In very old release of Perl (before v5.6), exec (and system) did not flush
2167             # your output buffer, so you needed to enable command buffering by setting $|
2168             # on one or more filehandles to avoid lost output with exec or misordered
2169             # output with system.
2170              
2171 200     200   780 $| = 1;
2172              
2173             # P.565 23.1.2. Cleaning Up Your Environment
2174             # in Chapter 23: Security
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176              
2177             # P.656 Cleaning Up Your Environment
2178             # in Chapter 20: Security
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180              
2181             # local $ENV{'PATH'} = '.';
2182 200         1792 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2183              
2184             # P.707 29.2.33. exec
2185             # in Chapter 29: Functions
2186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2187             #
2188             # As we mentioned earlier, exec treats a discrete list of arguments as an
2189             # indication that it should bypass shell processing. However, there is one
2190             # place where you might still get tripped up. The exec call (and system, too)
2191             # will not distinguish between a single scalar argument and an array containing
2192             # only one element.
2193             #
2194             # @args = ("echo surprise"); # just one element in list
2195             # exec @args # still subject to shell escapes
2196             # or die "exec: $!"; # because @args == 1
2197             #
2198             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2199             # first argument as the pathname, which forces the rest of the arguments to be
2200             # interpreted as a list, even if there is only one of them:
2201             #
2202             # exec { $args[0] } @args # safe even with one-argument list
2203             # or die "can't exec @args: $!";
2204              
2205             # P.855 exec
2206             # in Chapter 27: Functions
2207             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as a
2210             # directive to bypass shell processing. However, there is one place where
2211             # you might still get tripped up. The exec call (and system, too) cannot
2212             # distinguish between a single scalar argument and an array containing
2213             # only one element.
2214             #
2215             # @args = ("echo surprise"); # just one element in list
2216             # exec @args # still subject to shell escapes
2217             # || die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2220             # argument as the pathname, which forces the rest of the arguments to be
2221             # interpreted as a list, even if there is only one of them:
2222             #
2223             # exec { $args[0] } @args # safe even with one-argument list
2224             # || die "can't exec @args: $!";
2225              
2226 200         342 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         15247057  
2227             }
2228              
2229             #
2230             # Latin-9 order to character (with parameter)
2231             #
2232             sub Elatin9::chr(;$) {
2233              
2234 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2235              
2236 0 0       0 if ($c == 0x00) {
2237 0         0 return "\x00";
2238             }
2239             else {
2240 0         0 my @chr = ();
2241 0         0 while ($c > 0) {
2242 0         0 unshift @chr, ($c % 0x100);
2243 0         0 $c = int($c / 0x100);
2244             }
2245 0         0 return pack 'C*', @chr;
2246             }
2247             }
2248              
2249             #
2250             # Latin-9 order to character (without parameter)
2251             #
2252             sub Elatin9::chr_() {
2253              
2254 0     0 0 0 my $c = $_;
2255              
2256 0 0       0 if ($c == 0x00) {
2257 0         0 return "\x00";
2258             }
2259             else {
2260 0         0 my @chr = ();
2261 0         0 while ($c > 0) {
2262 0         0 unshift @chr, ($c % 0x100);
2263 0         0 $c = int($c / 0x100);
2264             }
2265 0         0 return pack 'C*', @chr;
2266             }
2267             }
2268              
2269             #
2270             # Latin-9 path globbing (with parameter)
2271             #
2272             sub Elatin9::glob($) {
2273              
2274 0 0   0 0 0 if (wantarray) {
2275 0         0 my @glob = _DOS_like_glob(@_);
2276 0         0 for my $glob (@glob) {
2277 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2278             }
2279 0         0 return @glob;
2280             }
2281             else {
2282 0         0 my $glob = _DOS_like_glob(@_);
2283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2284 0         0 return $glob;
2285             }
2286             }
2287              
2288             #
2289             # Latin-9 path globbing (without parameter)
2290             #
2291             sub Elatin9::glob_() {
2292              
2293 0 0   0 0 0 if (wantarray) {
2294 0         0 my @glob = _DOS_like_glob();
2295 0         0 for my $glob (@glob) {
2296 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2297             }
2298 0         0 return @glob;
2299             }
2300             else {
2301 0         0 my $glob = _DOS_like_glob();
2302 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2303 0         0 return $glob;
2304             }
2305             }
2306              
2307             #
2308             # Latin-9 path globbing via File::DosGlob 1.10
2309             #
2310             # Often I confuse "_dosglob" and "_doglob".
2311             # So, I renamed "_dosglob" to "_DOS_like_glob".
2312             #
2313             my %iter;
2314             my %entries;
2315             sub _DOS_like_glob {
2316              
2317             # context (keyed by second cxix argument provided by core)
2318 0     0   0 my($expr,$cxix) = @_;
2319              
2320             # glob without args defaults to $_
2321 0 0       0 $expr = $_ if not defined $expr;
2322              
2323             # represents the current user's home directory
2324             #
2325             # 7.3. Expanding Tildes in Filenames
2326             # in Chapter 7. File Access
2327             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2328             #
2329             # and File::HomeDir, File::HomeDir::Windows module
2330              
2331             # DOS-like system
2332 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2333 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2334 0         0 { my_home_MSWin32() }oxmse;
2335             }
2336              
2337             # UNIX-like system
2338             else {
2339 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2340 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2341             }
2342              
2343             # assume global context if not provided one
2344 0 0       0 $cxix = '_G_' if not defined $cxix;
2345 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2346              
2347             # if we're just beginning, do it all first
2348 0 0       0 if ($iter{$cxix} == 0) {
2349 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2350             }
2351              
2352             # chuck it all out, quick or slow
2353 0 0       0 if (wantarray) {
2354 0         0 delete $iter{$cxix};
2355 0         0 return @{delete $entries{$cxix}};
  0         0  
2356             }
2357             else {
2358 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2359 0         0 return shift @{$entries{$cxix}};
  0         0  
2360             }
2361             else {
2362             # return undef for EOL
2363 0         0 delete $iter{$cxix};
2364 0         0 delete $entries{$cxix};
2365 0         0 return undef;
2366             }
2367             }
2368             }
2369              
2370             #
2371             # Latin-9 path globbing subroutine
2372             #
2373             sub _do_glob {
2374              
2375 0     0   0 my($cond,@expr) = @_;
2376 0         0 my @glob = ();
2377 0         0 my $fix_drive_relative_paths = 0;
2378              
2379             OUTER:
2380 0         0 for my $expr (@expr) {
2381 0 0       0 next OUTER if not defined $expr;
2382 0 0       0 next OUTER if $expr eq '';
2383              
2384 0         0 my @matched = ();
2385 0         0 my @globdir = ();
2386 0         0 my $head = '.';
2387 0         0 my $pathsep = '/';
2388 0         0 my $tail;
2389              
2390             # if argument is within quotes strip em and do no globbing
2391 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2392 0         0 $expr = $1;
2393 0 0       0 if ($cond eq 'd') {
2394 0 0       0 if (-d $expr) {
2395 0         0 push @glob, $expr;
2396             }
2397             }
2398             else {
2399 0 0       0 if (-e $expr) {
2400 0         0 push @glob, $expr;
2401             }
2402             }
2403 0         0 next OUTER;
2404             }
2405              
2406             # wildcards with a drive prefix such as h:*.pm must be changed
2407             # to h:./*.pm to expand correctly
2408 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2409 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2410 0         0 $fix_drive_relative_paths = 1;
2411             }
2412             }
2413              
2414 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2415 0 0       0 if ($tail eq '') {
2416 0         0 push @glob, $expr;
2417 0         0 next OUTER;
2418             }
2419 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2420 0 0       0 if (@globdir = _do_glob('d', $head)) {
2421 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2422 0         0 next OUTER;
2423             }
2424             }
2425 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2426 0         0 $head .= $pathsep;
2427             }
2428 0         0 $expr = $tail;
2429             }
2430              
2431             # If file component has no wildcards, we can avoid opendir
2432 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2433 0 0       0 if ($head eq '.') {
2434 0         0 $head = '';
2435             }
2436 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2437 0         0 $head .= $pathsep;
2438             }
2439 0         0 $head .= $expr;
2440 0 0       0 if ($cond eq 'd') {
2441 0 0       0 if (-d $head) {
2442 0         0 push @glob, $head;
2443             }
2444             }
2445             else {
2446 0 0       0 if (-e $head) {
2447 0         0 push @glob, $head;
2448             }
2449             }
2450 0         0 next OUTER;
2451             }
2452 0 0       0 opendir(*DIR, $head) or next OUTER;
2453 0         0 my @leaf = readdir DIR;
2454 0         0 closedir DIR;
2455              
2456 0 0       0 if ($head eq '.') {
2457 0         0 $head = '';
2458             }
2459 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2460 0         0 $head .= $pathsep;
2461             }
2462              
2463 0         0 my $pattern = '';
2464 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2465 0         0 my $char = $1;
2466              
2467             # 6.9. Matching Shell Globs as Regular Expressions
2468             # in Chapter 6. Pattern Matching
2469             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2470             # (and so on)
2471              
2472 0 0       0 if ($char eq '*') {
    0          
    0          
2473 0         0 $pattern .= "(?:$your_char)*",
2474             }
2475             elsif ($char eq '?') {
2476 0         0 $pattern .= "(?:$your_char)?", # DOS style
2477             # $pattern .= "(?:$your_char)", # UNIX style
2478             }
2479             elsif ((my $fc = Elatin9::fc($char)) ne $char) {
2480 0         0 $pattern .= $fc;
2481             }
2482             else {
2483 0         0 $pattern .= quotemeta $char;
2484             }
2485             }
2486 0     0   0 my $matchsub = sub { Elatin9::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2487              
2488             # if ($@) {
2489             # print STDERR "$0: $@\n";
2490             # next OUTER;
2491             # }
2492              
2493             INNER:
2494 0         0 for my $leaf (@leaf) {
2495 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2496 0         0 next INNER;
2497             }
2498 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2499 0         0 next INNER;
2500             }
2501              
2502 0 0       0 if (&$matchsub($leaf)) {
2503 0         0 push @matched, "$head$leaf";
2504 0         0 next INNER;
2505             }
2506              
2507             # [DOS compatibility special case]
2508             # Failed, add a trailing dot and try again, but only...
2509              
2510 0 0 0     0 if (Elatin9::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2511             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2512             Elatin9::index($pattern,'\\.') != -1 # pattern has a dot.
2513             ) {
2514 0 0       0 if (&$matchsub("$leaf.")) {
2515 0         0 push @matched, "$head$leaf";
2516 0         0 next INNER;
2517             }
2518             }
2519             }
2520 0 0       0 if (@matched) {
2521 0         0 push @glob, @matched;
2522             }
2523             }
2524 0 0       0 if ($fix_drive_relative_paths) {
2525 0         0 for my $glob (@glob) {
2526 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2527             }
2528             }
2529 0         0 return @glob;
2530             }
2531              
2532             #
2533             # Latin-9 parse line
2534             #
2535             sub _parse_line {
2536              
2537 0     0   0 my($line) = @_;
2538              
2539 0         0 $line .= ' ';
2540 0         0 my @piece = ();
2541 0         0 while ($line =~ /
2542             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2543             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2544             /oxmsg
2545             ) {
2546 0 0       0 push @piece, defined($1) ? $1 : $2;
2547             }
2548 0         0 return @piece;
2549             }
2550              
2551             #
2552             # Latin-9 parse path
2553             #
2554             sub _parse_path {
2555              
2556 0     0   0 my($path,$pathsep) = @_;
2557              
2558 0         0 $path .= '/';
2559 0         0 my @subpath = ();
2560 0         0 while ($path =~ /
2561             ((?: [^\/\\] )+?) [\/\\]
2562             /oxmsg
2563             ) {
2564 0         0 push @subpath, $1;
2565             }
2566              
2567 0         0 my $tail = pop @subpath;
2568 0         0 my $head = join $pathsep, @subpath;
2569 0         0 return $head, $tail;
2570             }
2571              
2572             #
2573             # via File::HomeDir::Windows 1.00
2574             #
2575             sub my_home_MSWin32 {
2576              
2577             # A lot of unix people and unix-derived tools rely on
2578             # the ability to overload HOME. We will support it too
2579             # so that they can replace raw HOME calls with File::HomeDir.
2580 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2581 0         0 return $ENV{'HOME'};
2582             }
2583              
2584             # Do we have a user profile?
2585             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2586 0         0 return $ENV{'USERPROFILE'};
2587             }
2588              
2589             # Some Windows use something like $ENV{'HOME'}
2590             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2591 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2592             }
2593              
2594 0         0 return undef;
2595             }
2596              
2597             #
2598             # via File::HomeDir::Unix 1.00
2599             #
2600             sub my_home {
2601 0     0 0 0 my $home;
2602              
2603 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2604 0         0 $home = $ENV{'HOME'};
2605             }
2606              
2607             # This is from the original code, but I'm guessing
2608             # it means "login directory" and exists on some Unixes.
2609             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2610 0         0 $home = $ENV{'LOGDIR'};
2611             }
2612              
2613             ### More-desperate methods
2614              
2615             # Light desperation on any (Unixish) platform
2616             else {
2617 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2618             }
2619              
2620             # On Unix in general, a non-existant home means "no home"
2621             # For example, "nobody"-like users might use /nonexistant
2622 0 0 0     0 if (defined $home and ! -d($home)) {
2623 0         0 $home = undef;
2624             }
2625 0         0 return $home;
2626             }
2627              
2628             #
2629             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2630             #
2631             sub Elatin9::PREMATCH {
2632 0     0 0 0 return $`;
2633             }
2634              
2635             #
2636             # ${^MATCH}, $MATCH, $& the string that matched
2637             #
2638             sub Elatin9::MATCH {
2639 0     0 0 0 return $&;
2640             }
2641              
2642             #
2643             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2644             #
2645             sub Elatin9::POSTMATCH {
2646 0     0 0 0 return $';
2647             }
2648              
2649             #
2650             # Latin-9 character to order (with parameter)
2651             #
2652             sub Latin9::ord(;$) {
2653              
2654 0 0   0 1 0 local $_ = shift if @_;
2655              
2656 0 0       0 if (/\A ($q_char) /oxms) {
2657 0         0 my @ord = unpack 'C*', $1;
2658 0         0 my $ord = 0;
2659 0         0 while (my $o = shift @ord) {
2660 0         0 $ord = $ord * 0x100 + $o;
2661             }
2662 0         0 return $ord;
2663             }
2664             else {
2665 0         0 return CORE::ord $_;
2666             }
2667             }
2668              
2669             #
2670             # Latin-9 character to order (without parameter)
2671             #
2672             sub Latin9::ord_() {
2673              
2674 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2675 0         0 my @ord = unpack 'C*', $1;
2676 0         0 my $ord = 0;
2677 0         0 while (my $o = shift @ord) {
2678 0         0 $ord = $ord * 0x100 + $o;
2679             }
2680 0         0 return $ord;
2681             }
2682             else {
2683 0         0 return CORE::ord $_;
2684             }
2685             }
2686              
2687             #
2688             # Latin-9 reverse
2689             #
2690             sub Latin9::reverse(@) {
2691              
2692 0 0   0 0 0 if (wantarray) {
2693 0         0 return CORE::reverse @_;
2694             }
2695             else {
2696              
2697             # One of us once cornered Larry in an elevator and asked him what
2698             # problem he was solving with this, but he looked as far off into
2699             # the distance as he could in an elevator and said, "It seemed like
2700             # a good idea at the time."
2701              
2702 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2703             }
2704             }
2705              
2706             #
2707             # Latin-9 getc (with parameter, without parameter)
2708             #
2709             sub Latin9::getc(;*@) {
2710              
2711 0     0 0 0 my($package) = caller;
2712 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2713 0 0 0     0 croak 'Too many arguments for Latin9::getc' if @_ and not wantarray;
2714              
2715 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2716 0         0 my $getc = '';
2717 0         0 for my $length ($length[0] .. $length[-1]) {
2718 0         0 $getc .= CORE::getc($fh);
2719 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2720 0 0       0 if ($getc =~ /\A ${Elatin9::dot_s} \z/oxms) {
2721 0 0       0 return wantarray ? ($getc,@_) : $getc;
2722             }
2723             }
2724             }
2725 0 0       0 return wantarray ? ($getc,@_) : $getc;
2726             }
2727              
2728             #
2729             # Latin-9 length by character
2730             #
2731             sub Latin9::length(;$) {
2732              
2733 0 0   0 1 0 local $_ = shift if @_;
2734              
2735 0         0 local @_ = /\G ($q_char) /oxmsg;
2736 0         0 return scalar @_;
2737             }
2738              
2739             #
2740             # Latin-9 substr by character
2741             #
2742             BEGIN {
2743              
2744             # P.232 The lvalue Attribute
2745             # in Chapter 6: Subroutines
2746             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2747              
2748             # P.336 The lvalue Attribute
2749             # in Chapter 7: Subroutines
2750             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2751              
2752             # P.144 8.4 Lvalue subroutines
2753             # in Chapter 8: perlsub: Perl subroutines
2754             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2755              
2756 200 50 0 200 1 105159 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2757             # vv----------------------*******
2758             sub Latin9::substr($$;$$) %s {
2759              
2760             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2761              
2762             # If the substring is beyond either end of the string, substr() returns the undefined
2763             # value and produces a warning. When used as an lvalue, specifying a substring that
2764             # is entirely outside the string raises an exception.
2765             # http://perldoc.perl.org/functions/substr.html
2766              
2767             # A return with no argument returns the scalar value undef in scalar context,
2768             # an empty list () in list context, and (naturally) nothing at all in void
2769             # context.
2770              
2771             my $offset = $_[1];
2772             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2773             return;
2774             }
2775              
2776             # substr($string,$offset,$length,$replacement)
2777             if (@_ == 4) {
2778             my(undef,undef,$length,$replacement) = @_;
2779             my $substr = join '', splice(@char, $offset, $length, $replacement);
2780             $_[0] = join '', @char;
2781              
2782             # return $substr; this doesn't work, don't say "return"
2783             $substr;
2784             }
2785              
2786             # substr($string,$offset,$length)
2787             elsif (@_ == 3) {
2788             my(undef,undef,$length) = @_;
2789             my $octet_offset = 0;
2790             my $octet_length = 0;
2791             if ($offset == 0) {
2792             $octet_offset = 0;
2793             }
2794             elsif ($offset > 0) {
2795             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2796             }
2797             else {
2798             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2799             }
2800             if ($length == 0) {
2801             $octet_length = 0;
2802             }
2803             elsif ($length > 0) {
2804             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2805             }
2806             else {
2807             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset, $octet_length);
2810             }
2811              
2812             # substr($string,$offset)
2813             else {
2814             my $octet_offset = 0;
2815             if ($offset == 0) {
2816             $octet_offset = 0;
2817             }
2818             elsif ($offset > 0) {
2819             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2820             }
2821             else {
2822             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset);
2825             }
2826             }
2827             END
2828             }
2829              
2830             #
2831             # Latin-9 index by character
2832             #
2833             sub Latin9::index($$;$) {
2834              
2835 0     0 1 0 my $index;
2836 0 0       0 if (@_ == 3) {
2837 0         0 $index = Elatin9::index($_[0], $_[1], CORE::length(Latin9::substr($_[0], 0, $_[2])));
2838             }
2839             else {
2840 0         0 $index = Elatin9::index($_[0], $_[1]);
2841             }
2842              
2843 0 0       0 if ($index == -1) {
2844 0         0 return -1;
2845             }
2846             else {
2847 0         0 return Latin9::length(CORE::substr $_[0], 0, $index);
2848             }
2849             }
2850              
2851             #
2852             # Latin-9 rindex by character
2853             #
2854             sub Latin9::rindex($$;$) {
2855              
2856 0     0 1 0 my $rindex;
2857 0 0       0 if (@_ == 3) {
2858 0         0 $rindex = Elatin9::rindex($_[0], $_[1], CORE::length(Latin9::substr($_[0], 0, $_[2])));
2859             }
2860             else {
2861 0         0 $rindex = Elatin9::rindex($_[0], $_[1]);
2862             }
2863              
2864 0 0       0 if ($rindex == -1) {
2865 0         0 return -1;
2866             }
2867             else {
2868 0         0 return Latin9::length(CORE::substr $_[0], 0, $rindex);
2869             }
2870             }
2871              
2872             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2873             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2874 200     200   14120 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1493  
  200         319  
  200         12626  
2875              
2876             # ord() to ord() or Latin9::ord()
2877 200     200   10692 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   948  
  200         356  
  200         10033  
2878              
2879             # ord to ord or Latin9::ord_
2880 200     200   10145 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   889  
  200         570  
  200         13172  
2881              
2882             # reverse to reverse or Latin9::reverse
2883 200     200   10267 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   962  
  200         342  
  200         9845  
2884              
2885             # getc to getc or Latin9::getc
2886 200     200   9545 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   854  
  200         334  
  200         10122  
2887              
2888             # P.1023 Appendix W.9 Multibyte Anchoring
2889             # of ISBN 1-56592-224-7 CJKV Information Processing
2890              
2891             my $anchor = '';
2892              
2893 200     200   10217 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   837  
  200         317  
  200         7804236  
2894              
2895             # regexp of nested parens in qqXX
2896              
2897             # P.340 Matching Nested Constructs with Embedded Code
2898             # in Chapter 7: Perl
2899             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2900              
2901             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2902             [^\\()] |
2903             \( (?{$nest++}) |
2904             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2905             \\ [^c] |
2906             \\c[\x40-\x5F] |
2907             [\x00-\xFF]
2908             }xms;
2909              
2910             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2911             [^\\{}] |
2912             \{ (?{$nest++}) |
2913             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2914             \\ [^c] |
2915             \\c[\x40-\x5F] |
2916             [\x00-\xFF]
2917             }xms;
2918              
2919             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2920             [^\\\[\]] |
2921             \[ (?{$nest++}) |
2922             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2923             \\ [^c] |
2924             \\c[\x40-\x5F] |
2925             [\x00-\xFF]
2926             }xms;
2927              
2928             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2929             [^\\<>] |
2930             \< (?{$nest++}) |
2931             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2932             \\ [^c] |
2933             \\c[\x40-\x5F] |
2934             [\x00-\xFF]
2935             }xms;
2936              
2937             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2938             (?: ::)? (?:
2939             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2940             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2941             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2942             ))
2943             }xms;
2944              
2945             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2946             (?: ::)? (?:
2947             (?>[0-9]+) |
2948             [^a-zA-Z_0-9\[\]] |
2949             ^[A-Z] |
2950             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2951             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2952             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2953             ))
2954             }xms;
2955              
2956             my $qq_substr = qr{(?> Char::substr | Latin9::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2957             }xms;
2958              
2959             # regexp of nested parens in qXX
2960             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2961             [^()] |
2962             \( (?{$nest++}) |
2963             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2964             [\x00-\xFF]
2965             }xms;
2966              
2967             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2968             [^\{\}] |
2969             \{ (?{$nest++}) |
2970             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2971             [\x00-\xFF]
2972             }xms;
2973              
2974             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2975             [^\[\]] |
2976             \[ (?{$nest++}) |
2977             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2978             [\x00-\xFF]
2979             }xms;
2980              
2981             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2982             [^<>] |
2983             \< (?{$nest++}) |
2984             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2985             [\x00-\xFF]
2986             }xms;
2987              
2988             my $matched = '';
2989             my $s_matched = '';
2990              
2991             my $tr_variable = ''; # variable of tr///
2992             my $sub_variable = ''; # variable of s///
2993             my $bind_operator = ''; # =~ or !~
2994              
2995             my @heredoc = (); # here document
2996             my @heredoc_delimiter = ();
2997             my $here_script = ''; # here script
2998              
2999             #
3000             # escape Latin-9 script
3001             #
3002             sub Latin9::escape(;$) {
3003 200 50   200 0 663 local($_) = $_[0] if @_;
3004              
3005             # P.359 The Study Function
3006             # in Chapter 7: Perl
3007             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3008              
3009 200         383 study $_; # Yes, I studied study yesterday.
3010              
3011             # while all script
3012              
3013             # 6.14. Matching from Where the Last Pattern Left Off
3014             # in Chapter 6. Pattern Matching
3015             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3016             # (and so on)
3017              
3018             # one member of Tag-team
3019             #
3020             # P.128 Start of match (or end of previous match): \G
3021             # P.130 Advanced Use of \G with Perl
3022             # in Chapter 3: Overview of Regular Expression Features and Flavors
3023             # P.255 Use leading anchors
3024             # P.256 Expose ^ and \G at the front expressions
3025             # in Chapter 6: Crafting an Efficient Expression
3026             # P.315 "Tag-team" matching with /gc
3027             # in Chapter 7: Perl
3028             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3029              
3030 200         310 my $e_script = '';
3031 200         837 while (not /\G \z/oxgc) { # member
3032 71814         82983 $e_script .= Latin9::escape_token();
3033             }
3034              
3035 200         2369 return $e_script;
3036             }
3037              
3038             #
3039             # escape Latin-9 token of script
3040             #
3041             sub Latin9::escape_token {
3042              
3043             # \n output here document
3044              
3045 71814     71814 0 54826 my $ignore_modules = join('|', qw(
3046             utf8
3047             bytes
3048             charnames
3049             I18N::Japanese
3050             I18N::Collate
3051             I18N::JExt
3052             File::DosGlob
3053             Wild
3054             Wildcard
3055             Japanese
3056             ));
3057              
3058             # another member of Tag-team
3059             #
3060             # P.315 "Tag-team" matching with /gc
3061             # in Chapter 7: Perl
3062             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3063              
3064 71814 100 100     3596108 if (/\G ( \n ) /oxgc) { # another member (and so on)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3065 12067         9520 my $heredoc = '';
3066 12067 100       19537 if (scalar(@heredoc_delimiter) >= 1) {
3067 150         151 $slash = 'm//';
3068              
3069 150         251 $heredoc = join '', @heredoc;
3070 150         257 @heredoc = ();
3071              
3072             # skip here document
3073 150         241 for my $heredoc_delimiter (@heredoc_delimiter) {
3074 150         1033 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3075             }
3076 150         216 @heredoc_delimiter = ();
3077              
3078 150         172 $here_script = '';
3079             }
3080 12067         31008 return "\n" . $heredoc;
3081             }
3082              
3083             # ignore space, comment
3084 17232         44159 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3085              
3086             # if (, elsif (, unless (, while (, until (, given (, and when (
3087              
3088             # given, when
3089              
3090             # P.225 The given Statement
3091             # in Chapter 15: Smart Matching and given-when
3092             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3093              
3094             # P.133 The given Statement
3095             # in Chapter 4: Statements and Declarations
3096             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3097              
3098             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3099 1373         1535 $slash = 'm//';
3100 1373         3776 return $1;
3101             }
3102              
3103             # scalar variable ($scalar = ...) =~ tr///;
3104             # scalar variable ($scalar = ...) =~ s///;
3105              
3106             # state
3107              
3108             # P.68 Persistent, Private Variables
3109             # in Chapter 4: Subroutines
3110             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3111              
3112             # P.160 Persistent Lexically Scoped Variables: state
3113             # in Chapter 4: Statements and Declarations
3114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3115              
3116             # (and so on)
3117              
3118             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3119 85         137 my $e_string = e_string($1);
3120              
3121 85 50       1784 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3122 0         0 $tr_variable = $e_string . e_string($1);
3123 0         0 $bind_operator = $2;
3124 0         0 $slash = 'm//';
3125 0         0 return '';
3126             }
3127             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3128 0         0 $sub_variable = $e_string . e_string($1);
3129 0         0 $bind_operator = $2;
3130 0         0 $slash = 'm//';
3131 0         0 return '';
3132             }
3133             else {
3134 85         96 $slash = 'div';
3135 85         250 return $e_string;
3136             }
3137             }
3138              
3139             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin9::PREMATCH()
3140             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3141 4         6 $slash = 'div';
3142 4         14 return q{Elatin9::PREMATCH()};
3143             }
3144              
3145             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin9::MATCH()
3146             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3147 28         44 $slash = 'div';
3148 28         85 return q{Elatin9::MATCH()};
3149             }
3150              
3151             # $', ${'} --> $', ${'}
3152             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3153 1         3 $slash = 'div';
3154 1         5 return $1;
3155             }
3156              
3157             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin9::POSTMATCH()
3158             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3159 3         4 $slash = 'div';
3160 3         11 return q{Elatin9::POSTMATCH()};
3161             }
3162              
3163             # scalar variable $scalar =~ tr///;
3164             # scalar variable $scalar =~ s///;
3165             # substr() =~ tr///;
3166             # substr() =~ s///;
3167             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3168 1604         2814 my $scalar = e_string($1);
3169              
3170 1604 100       5851 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3171 1         3 $tr_variable = $scalar;
3172 1         2 $bind_operator = $1;
3173 1         2 $slash = 'm//';
3174 1         2 return '';
3175             }
3176             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3177 61         98 $sub_variable = $scalar;
3178 61         104 $bind_operator = $1;
3179 61         87 $slash = 'm//';
3180 61         159 return '';
3181             }
3182             else {
3183 1542         1573 $slash = 'div';
3184 1542         3746 return $scalar;
3185             }
3186             }
3187              
3188             # end of statement
3189             elsif (/\G ( [,;] ) /oxgc) {
3190 4562         4583 $slash = 'm//';
3191              
3192             # clear tr/// variable
3193 4562         3899 $tr_variable = '';
3194              
3195             # clear s/// variable
3196 4562         3517 $sub_variable = '';
3197              
3198 4562         3360 $bind_operator = '';
3199              
3200 4562         13805 return $1;
3201             }
3202              
3203             # bareword
3204             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3205 0         0 return $1;
3206             }
3207              
3208             # $0 --> $0
3209             elsif (/\G ( \$ 0 ) /oxmsgc) {
3210 2         5 $slash = 'div';
3211 2         11 return $1;
3212             }
3213             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3214 0         0 $slash = 'div';
3215 0         0 return $1;
3216             }
3217              
3218             # $$ --> $$
3219             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3220 1         2 $slash = 'div';
3221 1         3 return $1;
3222             }
3223              
3224             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3225             # $1, $2, $3 --> $1, $2, $3 otherwise
3226             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3227 4         6 $slash = 'div';
3228 4         12 return e_capture($1);
3229             }
3230             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3231 0         0 $slash = 'div';
3232 0         0 return e_capture($1);
3233             }
3234              
3235             # $$foo[ ... ] --> $ $foo->[ ... ]
3236             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3237 0         0 $slash = 'div';
3238 0         0 return e_capture($1.'->'.$2);
3239             }
3240              
3241             # $$foo{ ... } --> $ $foo->{ ... }
3242             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3243 0         0 $slash = 'div';
3244 0         0 return e_capture($1.'->'.$2);
3245             }
3246              
3247             # $$foo
3248             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3249 0         0 $slash = 'div';
3250 0         0 return e_capture($1);
3251             }
3252              
3253             # ${ foo }
3254             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3255 0         0 $slash = 'div';
3256 0         0 return '${' . $1 . '}';
3257             }
3258              
3259             # ${ ... }
3260             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3261 0         0 $slash = 'div';
3262 0         0 return e_capture($1);
3263             }
3264              
3265             # variable or function
3266             # $ @ % & * $ #
3267             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) {
3268 42         54 $slash = 'div';
3269 42         131 return $1;
3270             }
3271             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3272             # $ @ # \ ' " / ? ( ) [ ] < >
3273             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3274 60         86 $slash = 'div';
3275 60         173 return $1;
3276             }
3277              
3278             # while ()
3279             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3280 0         0 return $1;
3281             }
3282              
3283             # while () --- glob
3284              
3285             # avoid "Error: Runtime exception" of perl version 5.005_03
3286              
3287             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3288 0         0 return 'while ($_ = Elatin9::glob("' . $1 . '"))';
3289             }
3290              
3291             # while (glob)
3292             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3293 0         0 return 'while ($_ = Elatin9::glob_)';
3294             }
3295              
3296             # while (glob(WILDCARD))
3297             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3298 0         0 return 'while ($_ = Elatin9::glob';
3299             }
3300              
3301             # doit if, doit unless, doit while, doit until, doit for, doit when
3302 241         441 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         858  
3303              
3304             # subroutines of package Elatin9
3305 19         25 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         63  
3306 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3307 13         10 elsif (/\G \b Latin9::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         31  
3308 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3309 114         133 elsif (/\G \b Latin9::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Latin9::escape'; }
  114         306  
3310 2         2 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         6  
3311 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::chop'; }
  0         0  
3312 2         3 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         6  
3313 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3314 0         0 elsif (/\G \b Latin9::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin9::index'; }
  0         0  
3315 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::index'; }
  0         0  
3316 2         4 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
3317 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3318 0         0 elsif (/\G \b Latin9::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Latin9::rindex'; }
  0         0  
3319 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::rindex'; }
  0         0  
3320 1         3 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::lc'; }
  1         5  
3321 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::lcfirst'; }
  0         0  
3322 1         3 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::uc'; }
  1         3  
3323 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::ucfirst'; }
  0         0  
3324 6         5 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::fc'; }
  6         16  
3325              
3326             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3327 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3328 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3329 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3330 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3331 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3332 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3333 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3334              
3335 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3336 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3337 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3338 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3339 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3340 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3341 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3342              
3343             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3344 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3345 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3346 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3347 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3348              
3349 2         3 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         5  
3350 2         4 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         11  
3351 36         47 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::chr'; }
  36         94  
3352 2         4 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         5  
3353 8         12 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         27  
3354 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Elatin9::glob'; }
  0         0  
3355 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::lc_'; }
  0         0  
3356 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::lcfirst_'; }
  0         0  
3357 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::uc_'; }
  0         0  
3358 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::ucfirst_'; }
  0         0  
3359 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::fc_'; }
  0         0  
3360 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3361              
3362 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3363 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3364 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::chr_'; }
  0         0  
3365 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3366 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3367 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Elatin9::glob_'; }
  0         0  
3368 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3369 8         15 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         24  
3370             # split
3371             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3372 87         139 $slash = 'm//';
3373              
3374 87         119 my $e = '';
3375 87         335 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3376 85         334 $e .= $1;
3377             }
3378              
3379             # end of split
3380 87 100       7348 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin9::split' . $e; }
  2 100       16  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3381              
3382             # split scalar value
3383 1         3 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Elatin9::split' . $e . e_string($1); }
3384              
3385             # split literal space
3386 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Elatin9::split' . $e . qq {qq$1 $2}; }
3387 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin9::split' . $e . qq{$1qq$2 $3}; }
3388 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin9::split' . $e . qq{$1qq$2 $3}; }
3389 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin9::split' . $e . qq{$1qq$2 $3}; }
3390 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin9::split' . $e . qq{$1qq$2 $3}; }
3391 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin9::split' . $e . qq{$1qq$2 $3}; }
3392 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Elatin9::split' . $e . qq {q$1 $2}; }
3393 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Elatin9::split' . $e . qq {$1q$2 $3}; }
3394 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Elatin9::split' . $e . qq {$1q$2 $3}; }
3395 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Elatin9::split' . $e . qq {$1q$2 $3}; }
3396 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Elatin9::split' . $e . qq {$1q$2 $3}; }
3397 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Elatin9::split' . $e . qq {$1q$2 $3}; }
3398 10         31 elsif (/\G ' [ ] ' /oxgc) { return 'Elatin9::split' . $e . qq {' '}; }
3399 0         0 elsif (/\G " [ ] " /oxgc) { return 'Elatin9::split' . $e . qq {" "}; }
3400              
3401             # split qq//
3402             elsif (/\G \b (qq) \b /oxgc) {
3403 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3404             else {
3405 0         0 while (not /\G \z/oxgc) {
3406 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3407 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3408 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3409 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3410 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3411 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3412 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3413             }
3414 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3415             }
3416             }
3417              
3418             # split qr//
3419             elsif (/\G \b (qr) \b /oxgc) {
3420 12 50       483 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3421             else {
3422 12         57 while (not /\G \z/oxgc) {
3423 12 50       3132 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3424 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3425 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3426 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3427 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3428 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3429 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3430 12         66 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3431             }
3432 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3433             }
3434             }
3435              
3436             # split q//
3437             elsif (/\G \b (q) \b /oxgc) {
3438 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3439             else {
3440 0         0 while (not /\G \z/oxgc) {
3441 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3442 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3443 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3444 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3445 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3446 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3447 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3448             }
3449 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3450             }
3451             }
3452              
3453             # split m//
3454             elsif (/\G \b (m) \b /oxgc) {
3455 18 50       539 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3456             else {
3457 18         78 while (not /\G \z/oxgc) {
3458 18 50       3696 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3459 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3460 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3461 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3462 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3463 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3464 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3465 18         105 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3466             }
3467 0         0 die __FILE__, ": Search pattern not terminated\n";
3468             }
3469             }
3470              
3471             # split ''
3472             elsif (/\G (\') /oxgc) {
3473 0         0 my $q_string = '';
3474 0         0 while (not /\G \z/oxgc) {
3475 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3476 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3477 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3478 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3479             }
3480 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3481             }
3482              
3483             # split ""
3484             elsif (/\G (\") /oxgc) {
3485 0         0 my $qq_string = '';
3486 0         0 while (not /\G \z/oxgc) {
3487 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3488 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3489 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3490 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3491             }
3492 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3493             }
3494              
3495             # split //
3496             elsif (/\G (\/) /oxgc) {
3497 44         86 my $regexp = '';
3498 44         148 while (not /\G \z/oxgc) {
3499 381 50       1656 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3500 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3501 44         237 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3502 337         727 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3503             }
3504 0         0 die __FILE__, ": Search pattern not terminated\n";
3505             }
3506             }
3507              
3508             # tr/// or y///
3509              
3510             # about [cdsrbB]* (/B modifier)
3511             #
3512             # P.559 appendix C
3513             # of ISBN 4-89052-384-7 Programming perl
3514             # (Japanese title is: Perl puroguramingu)
3515              
3516             elsif (/\G \b ( tr | y ) \b /oxgc) {
3517 3         5 my $ope = $1;
3518              
3519             # $1 $2 $3 $4 $5 $6
3520 3 50       45 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3521 0         0 my @tr = ($tr_variable,$2);
3522 0         0 return e_tr(@tr,'',$4,$6);
3523             }
3524             else {
3525 3         5 my $e = '';
3526 3         9 while (not /\G \z/oxgc) {
3527 3 50       213 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3528             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3529 0         0 my @tr = ($tr_variable,$2);
3530 0         0 while (not /\G \z/oxgc) {
3531 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3532 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3533 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3534 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3535 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3536 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3537             }
3538 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3539             }
3540             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3541 0         0 my @tr = ($tr_variable,$2);
3542 0         0 while (not /\G \z/oxgc) {
3543 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3545 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3546 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3547 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3548 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3549             }
3550 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3551             }
3552             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3553 0         0 my @tr = ($tr_variable,$2);
3554 0         0 while (not /\G \z/oxgc) {
3555 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3556 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3557 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3558 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3559 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3560 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3561             }
3562 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3563             }
3564             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3565 0         0 my @tr = ($tr_variable,$2);
3566 0         0 while (not /\G \z/oxgc) {
3567 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3568 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3569 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3570 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3571 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3572 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3573             }
3574 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3575             }
3576             # $1 $2 $3 $4 $5 $6
3577             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3578 3         10 my @tr = ($tr_variable,$2);
3579 3         9 return e_tr(@tr,'',$4,$6);
3580             }
3581             }
3582 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3583             }
3584             }
3585              
3586             # qq//
3587             elsif (/\G \b (qq) \b /oxgc) {
3588 2130         3451 my $ope = $1;
3589              
3590             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3591 2130 50       3115 if (/\G (\#) /oxgc) { # qq# #
3592 0         0 my $qq_string = '';
3593 0         0 while (not /\G \z/oxgc) {
3594 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3595 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3596 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3597 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3598             }
3599 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3600             }
3601              
3602             else {
3603 2130         2263 my $e = '';
3604 2130         4349 while (not /\G \z/oxgc) {
3605 2130 50       7600 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3606              
3607             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3608             elsif (/\G (\() /oxgc) { # qq ( )
3609 0         0 my $qq_string = '';
3610 0         0 local $nest = 1;
3611 0         0 while (not /\G \z/oxgc) {
3612 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3613 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3614 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3615             elsif (/\G (\)) /oxgc) {
3616 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3617 0         0 else { $qq_string .= $1; }
3618             }
3619 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3620             }
3621 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3622             }
3623              
3624             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3625             elsif (/\G (\{) /oxgc) { # qq { }
3626 2100         1808 my $qq_string = '';
3627 2100         2337 local $nest = 1;
3628 2100         3800 while (not /\G \z/oxgc) {
3629 82644 100       251205 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1286  
    100          
    100          
    50          
3630 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3631 1103         1079 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1739  
3632             elsif (/\G (\}) /oxgc) {
3633 3203 100       3875 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         3803  
3634 1103         2094 else { $qq_string .= $1; }
3635             }
3636 77616         132203 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3637             }
3638 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3639             }
3640              
3641             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3642             elsif (/\G (\[) /oxgc) { # qq [ ]
3643 0         0 my $qq_string = '';
3644 0         0 local $nest = 1;
3645 0         0 while (not /\G \z/oxgc) {
3646 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3647 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3648 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3649             elsif (/\G (\]) /oxgc) {
3650 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3651 0         0 else { $qq_string .= $1; }
3652             }
3653 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3654             }
3655 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3656             }
3657              
3658             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3659             elsif (/\G (\<) /oxgc) { # qq < >
3660 30         47 my $qq_string = '';
3661 30         52 local $nest = 1;
3662 30         111 while (not /\G \z/oxgc) {
3663 1166 100       4773 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       68  
    50          
    100          
    50          
3664 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3665 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3666             elsif (/\G (\>) /oxgc) {
3667 30 50       76 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         85  
3668 0         0 else { $qq_string .= $1; }
3669             }
3670 1114         2458 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3671             }
3672 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3673             }
3674              
3675             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3676             elsif (/\G (\S) /oxgc) { # qq * *
3677 0         0 my $delimiter = $1;
3678 0         0 my $qq_string = '';
3679 0         0 while (not /\G \z/oxgc) {
3680 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3681 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3682 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3683 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3684             }
3685 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686             }
3687             }
3688 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3689             }
3690             }
3691              
3692             # qr//
3693             elsif (/\G \b (qr) \b /oxgc) {
3694 0         0 my $ope = $1;
3695 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3696 0         0 return e_qr($ope,$1,$3,$2,$4);
3697             }
3698             else {
3699 0         0 my $e = '';
3700 0         0 while (not /\G \z/oxgc) {
3701 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3702 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3703 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3704 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3705 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3706 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3707 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3708 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3709             }
3710 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3711             }
3712             }
3713              
3714             # qw//
3715             elsif (/\G \b (qw) \b /oxgc) {
3716 16         51 my $ope = $1;
3717 16 50       71 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3718 0         0 return e_qw($ope,$1,$3,$2);
3719             }
3720             else {
3721 16         27 my $e = '';
3722 16         55 while (not /\G \z/oxgc) {
3723 16 50       115 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3724              
3725 16         54 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3726 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3727              
3728 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3729 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3730              
3731 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3732 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3733              
3734 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3735 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3736              
3737 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3738 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3739             }
3740 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3741             }
3742             }
3743              
3744             # qx//
3745             elsif (/\G \b (qx) \b /oxgc) {
3746 0         0 my $ope = $1;
3747 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3748 0         0 return e_qq($ope,$1,$3,$2);
3749             }
3750             else {
3751 0         0 my $e = '';
3752 0         0 while (not /\G \z/oxgc) {
3753 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3754 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3755 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3756 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3757 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3758 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3759 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3760             }
3761 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3762             }
3763             }
3764              
3765             # q//
3766             elsif (/\G \b (q) \b /oxgc) {
3767 245         607 my $ope = $1;
3768              
3769             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3770              
3771             # avoid "Error: Runtime exception" of perl version 5.005_03
3772             # (and so on)
3773              
3774 245 50       885 if (/\G (\#) /oxgc) { # q# #
3775 0         0 my $q_string = '';
3776 0         0 while (not /\G \z/oxgc) {
3777 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3778 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3779 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3780 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3781             }
3782 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3783             }
3784              
3785             else {
3786 245         406 my $e = '';
3787 245         889 while (not /\G \z/oxgc) {
3788 245 50       1625 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3789              
3790             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3791             elsif (/\G (\() /oxgc) { # q ( )
3792 0         0 my $q_string = '';
3793 0         0 local $nest = 1;
3794 0         0 while (not /\G \z/oxgc) {
3795 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3796 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3797 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3798 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3799             elsif (/\G (\)) /oxgc) {
3800 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3801 0         0 else { $q_string .= $1; }
3802             }
3803 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3804             }
3805 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3806             }
3807              
3808             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3809             elsif (/\G (\{) /oxgc) { # q { }
3810 239         381 my $q_string = '';
3811 239         427 local $nest = 1;
3812 239         774 while (not /\G \z/oxgc) {
3813 3637 50       16559 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3814 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3815 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3816 107         139 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         182  
3817             elsif (/\G (\}) /oxgc) {
3818 346 100       1812 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         792  
3819 107         209 else { $q_string .= $1; }
3820             }
3821 3184         5704 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3822             }
3823 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3824             }
3825              
3826             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3827             elsif (/\G (\[) /oxgc) { # q [ ]
3828 0         0 my $q_string = '';
3829 0         0 local $nest = 1;
3830 0         0 while (not /\G \z/oxgc) {
3831 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3832 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3833 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3834 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3835             elsif (/\G (\]) /oxgc) {
3836 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3837 0         0 else { $q_string .= $1; }
3838             }
3839 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3840             }
3841 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3842             }
3843              
3844             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3845             elsif (/\G (\<) /oxgc) { # q < >
3846 5         10 my $q_string = '';
3847 5         8 local $nest = 1;
3848 5         57 while (not /\G \z/oxgc) {
3849 88 50       390 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3850 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3851 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3852 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3853             elsif (/\G (\>) /oxgc) {
3854 5 50       10 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         14  
3855 0         0 else { $q_string .= $1; }
3856             }
3857 83         136 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3858             }
3859 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3860             }
3861              
3862             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3863             elsif (/\G (\S) /oxgc) { # q * *
3864 1         3 my $delimiter = $1;
3865 1         1 my $q_string = '';
3866 1         3 while (not /\G \z/oxgc) {
3867 14 50       62 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3868 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3869 1         3 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3870 13         22 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3871             }
3872 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873             }
3874             }
3875 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3876             }
3877             }
3878              
3879             # m//
3880             elsif (/\G \b (m) \b /oxgc) {
3881 209         397 my $ope = $1;
3882 209 50       1845 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3883 0         0 return e_qr($ope,$1,$3,$2,$4);
3884             }
3885             else {
3886 209         249 my $e = '';
3887 209         547 while (not /\G \z/oxgc) {
3888 209 50       12683 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3889 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3890 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3891 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3892 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3893 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3894 10         24 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3895 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3896 199         565 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3897             }
3898 0         0 die __FILE__, ": Search pattern not terminated\n";
3899             }
3900             }
3901              
3902             # s///
3903              
3904             # about [cegimosxpradlunbB]* (/cg modifier)
3905             #
3906             # P.67 Pattern-Matching Operators
3907             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3908              
3909             elsif (/\G \b (s) \b /oxgc) {
3910 97         198 my $ope = $1;
3911              
3912             # $1 $2 $3 $4 $5 $6
3913 97 100       2094 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3914 1         4 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3915             }
3916             else {
3917 96         131 my $e = '';
3918 96         287 while (not /\G \z/oxgc) {
3919 96 50       11827 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3920             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3921 0         0 my @s = ($1,$2,$3);
3922 0         0 while (not /\G \z/oxgc) {
3923 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3924             # $1 $2 $3 $4
3925 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934             }
3935 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3936             }
3937             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3938 0         0 my @s = ($1,$2,$3);
3939 0         0 while (not /\G \z/oxgc) {
3940 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3941             # $1 $2 $3 $4
3942 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             }
3952 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3953             }
3954             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3955 0         0 my @s = ($1,$2,$3);
3956 0         0 while (not /\G \z/oxgc) {
3957 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3958             # $1 $2 $3 $4
3959 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             }
3967 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3968             }
3969             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3970 0         0 my @s = ($1,$2,$3);
3971 0         0 while (not /\G \z/oxgc) {
3972 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3973             # $1 $2 $3 $4
3974 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983             }
3984 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3985             }
3986             # $1 $2 $3 $4 $5 $6
3987             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3988 21         57 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3989             }
3990             # $1 $2 $3 $4 $5 $6
3991             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3992 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3993             }
3994             # $1 $2 $3 $4 $5 $6
3995             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3996 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3997             }
3998             # $1 $2 $3 $4 $5 $6
3999             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4000 75         295 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4001             }
4002             }
4003 0         0 die __FILE__, ": Substitution pattern not terminated\n";
4004             }
4005             }
4006              
4007             # require ignore module
4008 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4009 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4010 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4011              
4012             # use strict; --> use strict; no strict qw(refs);
4013 36         336 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4014 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4015 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4016              
4017             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4018             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4019 2 50 33     23 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4020 0         0 return "use $1; no strict qw(refs);";
4021             }
4022             else {
4023 2         10 return "use $1;";
4024             }
4025             }
4026             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4027 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4028 0         0 return "use $1; no strict qw(refs);";
4029             }
4030             else {
4031 0         0 return "use $1;";
4032             }
4033             }
4034              
4035             # ignore use module
4036 2         16 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4037 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4038 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4039              
4040             # ignore no module
4041 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4042 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4043 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4044              
4045             # use else
4046 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4047              
4048             # use else
4049 2         7 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4050              
4051             # ''
4052             elsif (/\G (?
4053 841         1129 my $q_string = '';
4054 841         1997 while (not /\G \z/oxgc) {
4055 8209 100       26197 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       9  
    100          
    50          
4056 48         91 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4057 841         1753 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4058 7316         13255 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4059             }
4060 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4061             }
4062              
4063             # ""
4064             elsif (/\G (\") /oxgc) {
4065 1747         2495 my $qq_string = '';
4066 1747         4017 while (not /\G \z/oxgc) {
4067 34324 100       98689 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       230  
    100          
    50          
4068 12         21 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4069 1747         3625 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4070 32498         59101 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4071             }
4072 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4073             }
4074              
4075             # ``
4076             elsif (/\G (\`) /oxgc) {
4077 1         3 my $qx_string = '';
4078 1         3 while (not /\G \z/oxgc) {
4079 19 50       85 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4080 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4081 1         2 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4082 18         25 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4083             }
4084 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4085             }
4086              
4087             # // --- not divide operator (num / num), not defined-or
4088             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4089 452         686 my $regexp = '';
4090 452         1196 while (not /\G \z/oxgc) {
4091 4490 50       14768 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4092 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4093 452         1461 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4094 4038         7183 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4095             }
4096 0         0 die __FILE__, ": Search pattern not terminated\n";
4097             }
4098              
4099             # ?? --- not conditional operator (condition ? then : else)
4100             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4101 0         0 my $regexp = '';
4102 0         0 while (not /\G \z/oxgc) {
4103 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4104 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4105 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4106 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4107             }
4108 0         0 die __FILE__, ": Search pattern not terminated\n";
4109             }
4110              
4111             # <<>> (a safer ARGV)
4112 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4113              
4114             # << (bit shift) --- not here document
4115 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4116              
4117             # <<'HEREDOC'
4118             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4119 72         84 $slash = 'm//';
4120 72         126 my $here_quote = $1;
4121 72         98 my $delimiter = $2;
4122              
4123             # get here document
4124 72 50       146 if ($here_script eq '') {
4125 72         344 $here_script = CORE::substr $_, pos $_;
4126 72         370 $here_script =~ s/.*?\n//oxm;
4127             }
4128 72 50       563 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4129 72         198 push @heredoc, $1 . qq{\n$delimiter\n};
4130 72         113 push @heredoc_delimiter, $delimiter;
4131             }
4132             else {
4133 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4134             }
4135 72         270 return $here_quote;
4136             }
4137              
4138             # <<\HEREDOC
4139              
4140             # P.66 2.6.6. "Here" Documents
4141             # in Chapter 2: Bits and Pieces
4142             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4143              
4144             # P.73 "Here" Documents
4145             # in Chapter 2: Bits and Pieces
4146             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4147              
4148             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4149 0         0 $slash = 'm//';
4150 0         0 my $here_quote = $1;
4151 0         0 my $delimiter = $2;
4152              
4153             # get here document
4154 0 0       0 if ($here_script eq '') {
4155 0         0 $here_script = CORE::substr $_, pos $_;
4156 0         0 $here_script =~ s/.*?\n//oxm;
4157             }
4158 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4159 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4160 0         0 push @heredoc_delimiter, $delimiter;
4161             }
4162             else {
4163 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4164             }
4165 0         0 return $here_quote;
4166             }
4167              
4168             # <<"HEREDOC"
4169             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4170 36         67 $slash = 'm//';
4171 36         70 my $here_quote = $1;
4172 36         433 my $delimiter = $2;
4173              
4174             # get here document
4175 36 50       93 if ($here_script eq '') {
4176 36         229 $here_script = CORE::substr $_, pos $_;
4177 36         194 $here_script =~ s/.*?\n//oxm;
4178             }
4179 36 50       775 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4180 36         101 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4181 36         147 push @heredoc_delimiter, $delimiter;
4182             }
4183             else {
4184 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4185             }
4186 36         162 return $here_quote;
4187             }
4188              
4189             # <
4190             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4191 42         79 $slash = 'm//';
4192 42         97 my $here_quote = $1;
4193 42         76 my $delimiter = $2;
4194              
4195             # get here document
4196 42 50       118 if ($here_script eq '') {
4197 42         355 $here_script = CORE::substr $_, pos $_;
4198 42         296 $here_script =~ s/.*?\n//oxm;
4199             }
4200 42 50       640 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4201 42         122 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4202 42         86 push @heredoc_delimiter, $delimiter;
4203             }
4204             else {
4205 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4206             }
4207 42         196 return $here_quote;
4208             }
4209              
4210             # <<`HEREDOC`
4211             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4212 0         0 $slash = 'm//';
4213 0         0 my $here_quote = $1;
4214 0         0 my $delimiter = $2;
4215              
4216             # get here document
4217 0 0       0 if ($here_script eq '') {
4218 0         0 $here_script = CORE::substr $_, pos $_;
4219 0         0 $here_script =~ s/.*?\n//oxm;
4220             }
4221 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4222 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4223 0         0 push @heredoc_delimiter, $delimiter;
4224             }
4225             else {
4226 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228 0         0 return $here_quote;
4229             }
4230              
4231             # <<= <=> <= < operator
4232             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4233 11         42 return $1;
4234             }
4235              
4236             #
4237             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4238 0         0 return $1;
4239             }
4240              
4241             # --- glob
4242              
4243             # avoid "Error: Runtime exception" of perl version 5.005_03
4244              
4245             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4246 0         0 return 'Elatin9::glob("' . $1 . '")';
4247             }
4248              
4249             # __DATA__
4250 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4251              
4252             # __END__
4253 200         1340 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4254              
4255             # \cD Control-D
4256              
4257             # P.68 2.6.8. Other Literal Tokens
4258             # in Chapter 2: Bits and Pieces
4259             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4260              
4261             # P.76 Other Literal Tokens
4262             # in Chapter 2: Bits and Pieces
4263             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4264              
4265 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4266              
4267             # \cZ Control-Z
4268 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4269              
4270             # any operator before div
4271             elsif (/\G (
4272             -- | \+\+ |
4273             [\)\}\]]
4274              
4275 4824         5532 ) /oxgc) { $slash = 'div'; return $1; }
  4824         18542  
4276              
4277             # yada-yada or triple-dot operator
4278             elsif (/\G (
4279             \.\.\.
4280              
4281 7         9 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         41  
4282              
4283             # any operator before m//
4284              
4285             # //, //= (defined-or)
4286              
4287             # P.164 Logical Operators
4288             # in Chapter 10: More Control Structures
4289             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4290              
4291             # P.119 C-Style Logical (Short-Circuit) Operators
4292             # in Chapter 3: Unary and Binary Operators
4293             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4294              
4295             # (and so on)
4296              
4297             # ~~
4298              
4299             # P.221 The Smart Match Operator
4300             # in Chapter 15: Smart Matching and given-when
4301             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4302              
4303             # P.112 Smartmatch Operator
4304             # in Chapter 3: Unary and Binary Operators
4305             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4306              
4307             # (and so on)
4308              
4309             elsif (/\G ((?>
4310              
4311             !~~ | !~ | != | ! |
4312             %= | % |
4313             &&= | && | &= | &\.= | &\. | & |
4314             -= | -> | - |
4315             :(?>\s*)= |
4316             : |
4317             <<>> |
4318             <<= | <=> | <= | < |
4319             == | => | =~ | = |
4320             >>= | >> | >= | > |
4321             \*\*= | \*\* | \*= | \* |
4322             \+= | \+ |
4323             \.\. | \.= | \. |
4324             \/\/= | \/\/ |
4325             \/= | \/ |
4326             \? |
4327             \\ |
4328             \^= | \^\.= | \^\. | \^ |
4329             \b x= |
4330             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4331             ~~ | ~\. | ~ |
4332             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4333             \b(?: print )\b |
4334              
4335             [,;\(\{\[]
4336              
4337 8485         9292 )) /oxgc) { $slash = 'm//'; return $1; }
  8485         32701  
4338              
4339             # other any character
4340 14740         15348 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14740         56850  
4341              
4342             # system error
4343             else {
4344 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4345             }
4346             }
4347              
4348             # escape Latin-9 string
4349             sub e_string {
4350 1718     1718 0 2805 my($string) = @_;
4351 1718         1709 my $e_string = '';
4352              
4353 1718         1894 local $slash = 'm//';
4354              
4355             # P.1024 Appendix W.10 Multibyte Processing
4356             # of ISBN 1-56592-224-7 CJKV Information Processing
4357             # (and so on)
4358              
4359 1718         15077 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4360              
4361             # without { ... }
4362 1718 100 66     7005 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4363 1701 50       3246 if ($string !~ /<
4364 1701         3518 return $string;
4365             }
4366             }
4367              
4368             E_STRING_LOOP:
4369 17         55 while ($string !~ /\G \z/oxgc) {
4370 190 50       13239 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4371             }
4372              
4373             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Elatin9::PREMATCH()]}
4374 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4375 0         0 $e_string .= q{Elatin9::PREMATCH()};
4376 0         0 $slash = 'div';
4377             }
4378              
4379             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Elatin9::MATCH()]}
4380             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4381 0         0 $e_string .= q{Elatin9::MATCH()};
4382 0         0 $slash = 'div';
4383             }
4384              
4385             # $', ${'} --> $', ${'}
4386             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4387 0         0 $e_string .= $1;
4388 0         0 $slash = 'div';
4389             }
4390              
4391             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Elatin9::POSTMATCH()]}
4392             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4393 0         0 $e_string .= q{Elatin9::POSTMATCH()};
4394 0         0 $slash = 'div';
4395             }
4396              
4397             # bareword
4398             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4399 0         0 $e_string .= $1;
4400 0         0 $slash = 'div';
4401             }
4402              
4403             # $0 --> $0
4404             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4405 0         0 $e_string .= $1;
4406 0         0 $slash = 'div';
4407             }
4408             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4409 0         0 $e_string .= $1;
4410 0         0 $slash = 'div';
4411             }
4412              
4413             # $$ --> $$
4414             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4415 0         0 $e_string .= $1;
4416 0         0 $slash = 'div';
4417             }
4418              
4419             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4420             # $1, $2, $3 --> $1, $2, $3 otherwise
4421             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4422 0         0 $e_string .= e_capture($1);
4423 0         0 $slash = 'div';
4424             }
4425             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4426 0         0 $e_string .= e_capture($1);
4427 0         0 $slash = 'div';
4428             }
4429              
4430             # $$foo[ ... ] --> $ $foo->[ ... ]
4431             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4432 0         0 $e_string .= e_capture($1.'->'.$2);
4433 0         0 $slash = 'div';
4434             }
4435              
4436             # $$foo{ ... } --> $ $foo->{ ... }
4437             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4438 0         0 $e_string .= e_capture($1.'->'.$2);
4439 0         0 $slash = 'div';
4440             }
4441              
4442             # $$foo
4443             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4444 0         0 $e_string .= e_capture($1);
4445 0         0 $slash = 'div';
4446             }
4447              
4448             # ${ foo }
4449             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4450 0         0 $e_string .= '${' . $1 . '}';
4451 0         0 $slash = 'div';
4452             }
4453              
4454             # ${ ... }
4455             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4456 3         9 $e_string .= e_capture($1);
4457 3         13 $slash = 'div';
4458             }
4459              
4460             # variable or function
4461             # $ @ % & * $ #
4462             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) {
4463 7         18 $e_string .= $1;
4464 7         27 $slash = 'div';
4465             }
4466             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4467             # $ @ # \ ' " / ? ( ) [ ] < >
4468             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4469 0         0 $e_string .= $1;
4470 0         0 $slash = 'div';
4471             }
4472              
4473             # subroutines of package Elatin9
4474 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4475 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4476 0         0 elsif ($string =~ /\G \b Latin9::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b Latin9::eval \b /oxgc) { $e_string .= 'eval Latin9::escape'; $slash = 'm//'; }
  0         0  
4479 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4480 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Elatin9::chop'; $slash = 'm//'; }
  0         0  
4481 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4482 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4483 0         0 elsif ($string =~ /\G \b Latin9::index \b /oxgc) { $e_string .= 'Latin9::index'; $slash = 'm//'; }
  0         0  
4484 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Elatin9::index'; $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G \b Latin9::rindex \b /oxgc) { $e_string .= 'Latin9::rindex'; $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Elatin9::rindex'; $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::lc'; $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::lcfirst'; $slash = 'm//'; }
  0         0  
4491 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::uc'; $slash = 'm//'; }
  0         0  
4492 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::ucfirst'; $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::fc'; $slash = 'm//'; }
  0         0  
4494              
4495             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4496 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4497 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4498 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4499 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4500 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4501 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4502 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4503              
4504 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4505 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4506 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4507 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4508 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4509 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4510 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4511              
4512             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4513 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4514 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4515 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4517              
4518 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4519 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4520 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::chr'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Elatin9::glob'; $slash = 'm//'; }
  0         0  
4524 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Elatin9::lc_'; $slash = 'm//'; }
  0         0  
4525 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Elatin9::lcfirst_'; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Elatin9::uc_'; $slash = 'm//'; }
  0         0  
4527 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Elatin9::ucfirst_'; $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Elatin9::fc_'; $slash = 'm//'; }
  0         0  
4529 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4530              
4531 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4532 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4533 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Elatin9::chr_'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4535 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4536 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Elatin9::glob_'; $slash = 'm//'; }
  0         0  
4537 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4538 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4539             # split
4540             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4541 0         0 $slash = 'm//';
4542              
4543 0         0 my $e = '';
4544 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4545 0         0 $e .= $1;
4546             }
4547              
4548             # end of split
4549 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Elatin9::split' . $e; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4550              
4551             # split scalar value
4552 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Elatin9::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4553              
4554             # split literal space
4555 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4556 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4557 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4559 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4560 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4561 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4562 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4563 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4564 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4565 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4566 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4567 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4568 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Elatin9::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4569              
4570             # split qq//
4571             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4572 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0         0  
  0         0  
4573             else {
4574 0         0 while ($string !~ /\G \z/oxgc) {
4575 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4576 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4577 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4578 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4579 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4580 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4581 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0         0  
4582             }
4583 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4584             }
4585             }
4586              
4587             # split qr//
4588             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4589 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0         0  
  0         0  
4590             else {
4591 0         0 while ($string !~ /\G \z/oxgc) {
4592 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4593 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4594 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4595 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4596 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4597 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4598 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0         0  
4599 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0         0  
4600             }
4601 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4602             }
4603             }
4604              
4605             # split q//
4606             elsif ($string =~ /\G \b (q) \b /oxgc) {
4607 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0         0  
  0         0  
4608             else {
4609 0         0 while ($string !~ /\G \z/oxgc) {
4610 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4611 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4612 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4613 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4614 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4615 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0         0  
4616 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0         0  
4617             }
4618 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4619             }
4620             }
4621              
4622             # split m//
4623             elsif ($string =~ /\G \b (m) \b /oxgc) {
4624 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0         0  
  0         0  
4625             else {
4626 0         0 while ($string !~ /\G \z/oxgc) {
4627 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4628 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4629 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4630 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4631 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4632 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4633 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0         0  
4634 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0         0  
4635             }
4636 0         0 die __FILE__, ": Search pattern not terminated\n";
4637             }
4638             }
4639              
4640             # split ''
4641             elsif ($string =~ /\G (\') /oxgc) {
4642 0         0 my $q_string = '';
4643 0         0 while ($string !~ /\G \z/oxgc) {
4644 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4645 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4646 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4647 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4648             }
4649 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4650             }
4651              
4652             # split ""
4653             elsif ($string =~ /\G (\") /oxgc) {
4654 0         0 my $qq_string = '';
4655 0         0 while ($string !~ /\G \z/oxgc) {
4656 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4657 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4658 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4659 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4660             }
4661 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4662             }
4663              
4664             # split //
4665             elsif ($string =~ /\G (\/) /oxgc) {
4666 0         0 my $regexp = '';
4667 0         0 while ($string !~ /\G \z/oxgc) {
4668 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4669 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4670 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4671 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4672             }
4673 0         0 die __FILE__, ": Search pattern not terminated\n";
4674             }
4675             }
4676              
4677             # qq//
4678             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4679 0         0 my $ope = $1;
4680 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4681 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4682             }
4683             else {
4684 0         0 my $e = '';
4685 0         0 while ($string !~ /\G \z/oxgc) {
4686 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4687 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4688 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4689 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4690 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4691 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0         0  
4692             }
4693 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4694             }
4695             }
4696              
4697             # qx//
4698             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4699 0         0 my $ope = $1;
4700 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4701 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4702             }
4703             else {
4704 0         0 my $e = '';
4705 0         0 while ($string !~ /\G \z/oxgc) {
4706 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4707 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4708 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4709 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4710 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4711 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4712 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0         0  
4713             }
4714 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4715             }
4716             }
4717              
4718             # q//
4719             elsif ($string =~ /\G \b (q) \b /oxgc) {
4720 0         0 my $ope = $1;
4721 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4722 0         0 $e_string .= e_q($ope,$1,$3,$2);
4723             }
4724             else {
4725 0         0 my $e = '';
4726 0         0 while ($string !~ /\G \z/oxgc) {
4727 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4728 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4729 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4730 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4731 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4732 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0         0  
4733             }
4734 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4735             }
4736             }
4737              
4738             # ''
4739 0         0 elsif ($string =~ /\G (?
4740              
4741             # ""
4742 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4743              
4744             # ``
4745 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4746              
4747             # <<>> (a safer ARGV)
4748 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4749              
4750             # <<= <=> <= < operator
4751 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4752              
4753             #
4754 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4755              
4756             # --- glob
4757             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4758 0         0 $e_string .= 'Elatin9::glob("' . $1 . '")';
4759             }
4760              
4761             # << (bit shift) --- not here document
4762 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4763              
4764             # <<'HEREDOC'
4765             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4766 0         0 $slash = 'm//';
4767 0         0 my $here_quote = $1;
4768 0         0 my $delimiter = $2;
4769              
4770             # get here document
4771 0 0       0 if ($here_script eq '') {
4772 0         0 $here_script = CORE::substr $_, pos $_;
4773 0         0 $here_script =~ s/.*?\n//oxm;
4774             }
4775 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4776 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4777 0         0 push @heredoc_delimiter, $delimiter;
4778             }
4779             else {
4780 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4781             }
4782 0         0 $e_string .= $here_quote;
4783             }
4784              
4785             # <<\HEREDOC
4786             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4787 0         0 $slash = 'm//';
4788 0         0 my $here_quote = $1;
4789 0         0 my $delimiter = $2;
4790              
4791             # get here document
4792 0 0       0 if ($here_script eq '') {
4793 0         0 $here_script = CORE::substr $_, pos $_;
4794 0         0 $here_script =~ s/.*?\n//oxm;
4795             }
4796 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4797 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4798 0         0 push @heredoc_delimiter, $delimiter;
4799             }
4800             else {
4801 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4802             }
4803 0         0 $e_string .= $here_quote;
4804             }
4805              
4806             # <<"HEREDOC"
4807             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4808 0         0 $slash = 'm//';
4809 0         0 my $here_quote = $1;
4810 0         0 my $delimiter = $2;
4811              
4812             # get here document
4813 0 0       0 if ($here_script eq '') {
4814 0         0 $here_script = CORE::substr $_, pos $_;
4815 0         0 $here_script =~ s/.*?\n//oxm;
4816             }
4817 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4818 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4819 0         0 push @heredoc_delimiter, $delimiter;
4820             }
4821             else {
4822 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4823             }
4824 0         0 $e_string .= $here_quote;
4825             }
4826              
4827             # <
4828             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4829 0         0 $slash = 'm//';
4830 0         0 my $here_quote = $1;
4831 0         0 my $delimiter = $2;
4832              
4833             # get here document
4834 0 0       0 if ($here_script eq '') {
4835 0         0 $here_script = CORE::substr $_, pos $_;
4836 0         0 $here_script =~ s/.*?\n//oxm;
4837             }
4838 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4839 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4840 0         0 push @heredoc_delimiter, $delimiter;
4841             }
4842             else {
4843 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4844             }
4845 0         0 $e_string .= $here_quote;
4846             }
4847              
4848             # <<`HEREDOC`
4849             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4850 0         0 $slash = 'm//';
4851 0         0 my $here_quote = $1;
4852 0         0 my $delimiter = $2;
4853              
4854             # get here document
4855 0 0       0 if ($here_script eq '') {
4856 0         0 $here_script = CORE::substr $_, pos $_;
4857 0         0 $here_script =~ s/.*?\n//oxm;
4858             }
4859 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4860 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4861 0         0 push @heredoc_delimiter, $delimiter;
4862             }
4863             else {
4864 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4865             }
4866 0         0 $e_string .= $here_quote;
4867             }
4868              
4869             # any operator before div
4870             elsif ($string =~ /\G (
4871             -- | \+\+ |
4872             [\)\}\]]
4873              
4874 18         31 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         61  
4875              
4876             # yada-yada or triple-dot operator
4877             elsif ($string =~ /\G (
4878             \.\.\.
4879              
4880 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4881              
4882             # any operator before m//
4883             elsif ($string =~ /\G ((?>
4884              
4885             !~~ | !~ | != | ! |
4886             %= | % |
4887             &&= | && | &= | &\.= | &\. | & |
4888             -= | -> | - |
4889             :(?>\s*)= |
4890             : |
4891             <<>> |
4892             <<= | <=> | <= | < |
4893             == | => | =~ | = |
4894             >>= | >> | >= | > |
4895             \*\*= | \*\* | \*= | \* |
4896             \+= | \+ |
4897             \.\. | \.= | \. |
4898             \/\/= | \/\/ |
4899             \/= | \/ |
4900             \? |
4901             \\ |
4902             \^= | \^\.= | \^\. | \^ |
4903             \b x= |
4904             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4905             ~~ | ~\. | ~ |
4906             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4907             \b(?: print )\b |
4908              
4909             [,;\(\{\[]
4910              
4911 31         44 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         124  
4912              
4913             # other any character
4914 131         341 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4915              
4916             # system error
4917             else {
4918 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4919             }
4920             }
4921              
4922 17         99 return $e_string;
4923             }
4924              
4925             #
4926             # character class
4927             #
4928             sub character_class {
4929 1914     1914 0 2220 my($char,$modifier) = @_;
4930              
4931 1914 100       2650 if ($char eq '.') {
4932 52 100       88 if ($modifier =~ /s/) {
4933 17         34 return '${Elatin9::dot_s}';
4934             }
4935             else {
4936 35         70 return '${Elatin9::dot}';
4937             }
4938             }
4939             else {
4940 1862         2725 return Elatin9::classic_character_class($char);
4941             }
4942             }
4943              
4944             #
4945             # escape capture ($1, $2, $3, ...)
4946             #
4947             sub e_capture {
4948              
4949 212     212 0 751 return join '', '${', $_[0], '}';
4950             }
4951              
4952             #
4953             # escape transliteration (tr/// or y///)
4954             #
4955             sub e_tr {
4956 3     3 0 8 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4957 3         4 my $e_tr = '';
4958 3   50     7 $modifier ||= '';
4959              
4960 3         4 $slash = 'div';
4961              
4962             # quote character class 1
4963 3         6 $charclass = q_tr($charclass);
4964              
4965             # quote character class 2
4966 3         7 $charclass2 = q_tr($charclass2);
4967              
4968             # /b /B modifier
4969 3 50       13 if ($modifier =~ tr/bB//d) {
4970 0 0       0 if ($variable eq '') {
4971 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4972             }
4973             else {
4974 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4975             }
4976             }
4977             else {
4978 3 100       7 if ($variable eq '') {
4979 2         7 $e_tr = qq{Elatin9::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4980             }
4981             else {
4982 1         17 $e_tr = qq{Elatin9::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4983             }
4984             }
4985              
4986             # clear tr/// variable
4987 3         6 $tr_variable = '';
4988 3         3 $bind_operator = '';
4989              
4990 3         17 return $e_tr;
4991             }
4992              
4993             #
4994             # quote for escape transliteration (tr/// or y///)
4995             #
4996             sub q_tr {
4997 6     6 0 7 my($charclass) = @_;
4998              
4999             # quote character class
5000 6 50       13 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5001 6         9 return e_q('', "'", "'", $charclass); # --> q' '
5002             }
5003             elsif ($charclass !~ /\//oxms) {
5004 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
5005             }
5006             elsif ($charclass !~ /\#/oxms) {
5007 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
5008             }
5009             elsif ($charclass !~ /[\<\>]/oxms) {
5010 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
5011             }
5012             elsif ($charclass !~ /[\(\)]/oxms) {
5013 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
5014             }
5015             elsif ($charclass !~ /[\{\}]/oxms) {
5016 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5017             }
5018             else {
5019 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5020 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5021 0         0 return e_q('q', $char, $char, $charclass);
5022             }
5023             }
5024             }
5025              
5026 0         0 return e_q('q', '{', '}', $charclass);
5027             }
5028              
5029             #
5030             # escape q string (q//, '')
5031             #
5032             sub e_q {
5033 1092     1092 0 1883 my($ope,$delimiter,$end_delimiter,$string) = @_;
5034              
5035 1092         1181 $slash = 'div';
5036              
5037 1092         5303 return join '', $ope, $delimiter, $string, $end_delimiter;
5038             }
5039              
5040             #
5041             # escape qq string (qq//, "", qx//, ``)
5042             #
5043             sub e_qq {
5044 3959     3959 0 6409 my($ope,$delimiter,$end_delimiter,$string) = @_;
5045              
5046 3959         3962 $slash = 'div';
5047              
5048 3959         3288 my $left_e = 0;
5049 3959         2909 my $right_e = 0;
5050              
5051             # split regexp
5052 3959         135744 my @char = $string =~ /\G((?>
5053             [^\\\$] |
5054             \\x\{ (?>[0-9A-Fa-f]+) \} |
5055             \\o\{ (?>[0-7]+) \} |
5056             \\N\{ (?>[^0-9\}][^\}]*) \} |
5057             \\ $q_char |
5058             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5059             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5060             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5061             \$ (?>\s* [0-9]+) |
5062             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5063             \$ \$ (?![\w\{]) |
5064             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5065             $q_char
5066             ))/oxmsg;
5067              
5068 3959         13514 for (my $i=0; $i <= $#char; $i++) {
5069              
5070             # "\L\u" --> "\u\L"
5071 111852 50 33     419905 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5072 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5073             }
5074              
5075             # "\U\l" --> "\l\U"
5076             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5077 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5078             }
5079              
5080             # octal escape sequence
5081             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5082 1         3 $char[$i] = Elatin9::octchr($1);
5083             }
5084              
5085             # hexadecimal escape sequence
5086             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5087 1         3 $char[$i] = Elatin9::hexchr($1);
5088             }
5089              
5090             # \N{CHARNAME} --> N{CHARNAME}
5091             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5092 0         0 $char[$i] = $1;
5093             }
5094              
5095 111852 100       1146330 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5096             }
5097              
5098             # \F
5099             #
5100             # P.69 Table 2-6. Translation escapes
5101             # in Chapter 2: Bits and Pieces
5102             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5103             # (and so on)
5104              
5105             # \u \l \U \L \F \Q \E
5106 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5107 484 50       1097 if ($right_e < $left_e) {
5108 0         0 $char[$i] = '\\' . $char[$i];
5109             }
5110             }
5111             elsif ($char[$i] eq '\u') {
5112              
5113             # "STRING @{[ LIST EXPR ]} MORE STRING"
5114              
5115             # P.257 Other Tricks You Can Do with Hard References
5116             # in Chapter 8: References
5117             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5118              
5119             # P.353 Other Tricks You Can Do with Hard References
5120             # in Chapter 8: References
5121             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5122              
5123             # (and so on)
5124              
5125 0         0 $char[$i] = '@{[Elatin9::ucfirst qq<';
5126 0         0 $left_e++;
5127             }
5128             elsif ($char[$i] eq '\l') {
5129 0         0 $char[$i] = '@{[Elatin9::lcfirst qq<';
5130 0         0 $left_e++;
5131             }
5132             elsif ($char[$i] eq '\U') {
5133 0         0 $char[$i] = '@{[Elatin9::uc qq<';
5134 0         0 $left_e++;
5135             }
5136             elsif ($char[$i] eq '\L') {
5137 0         0 $char[$i] = '@{[Elatin9::lc qq<';
5138 0         0 $left_e++;
5139             }
5140             elsif ($char[$i] eq '\F') {
5141 24         30 $char[$i] = '@{[Elatin9::fc qq<';
5142 24         42 $left_e++;
5143             }
5144             elsif ($char[$i] eq '\Q') {
5145 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5146 0         0 $left_e++;
5147             }
5148             elsif ($char[$i] eq '\E') {
5149 24 50       30 if ($right_e < $left_e) {
5150 24         24 $char[$i] = '>]}';
5151 24         45 $right_e++;
5152             }
5153             else {
5154 0         0 $char[$i] = '';
5155             }
5156             }
5157             elsif ($char[$i] eq '\Q') {
5158 0         0 while (1) {
5159 0 0       0 if (++$i > $#char) {
5160 0         0 last;
5161             }
5162 0 0       0 if ($char[$i] eq '\E') {
5163 0         0 last;
5164             }
5165             }
5166             }
5167             elsif ($char[$i] eq '\E') {
5168             }
5169              
5170             # $0 --> $0
5171             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5172             }
5173             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5174             }
5175              
5176             # $$ --> $$
5177             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5178             }
5179              
5180             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5181             # $1, $2, $3 --> $1, $2, $3 otherwise
5182             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5183 205         356 $char[$i] = e_capture($1);
5184             }
5185             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5186 0         0 $char[$i] = e_capture($1);
5187             }
5188              
5189             # $$foo[ ... ] --> $ $foo->[ ... ]
5190             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5191 0         0 $char[$i] = e_capture($1.'->'.$2);
5192             }
5193              
5194             # $$foo{ ... } --> $ $foo->{ ... }
5195             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5196 0         0 $char[$i] = e_capture($1.'->'.$2);
5197             }
5198              
5199             # $$foo
5200             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5201 0         0 $char[$i] = e_capture($1);
5202             }
5203              
5204             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin9::PREMATCH()
5205             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5206 44         102 $char[$i] = '@{[Elatin9::PREMATCH()]}';
5207             }
5208              
5209             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin9::MATCH()
5210             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5211 45         122 $char[$i] = '@{[Elatin9::MATCH()]}';
5212             }
5213              
5214             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin9::POSTMATCH()
5215             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5216 33         82 $char[$i] = '@{[Elatin9::POSTMATCH()]}';
5217             }
5218              
5219             # ${ foo } --> ${ foo }
5220             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5221             }
5222              
5223             # ${ ... }
5224             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5225 0         0 $char[$i] = e_capture($1);
5226             }
5227             }
5228              
5229             # return string
5230 3959 50       6621 if ($left_e > $right_e) {
5231 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5232             }
5233 3959         33581 return join '', $ope, $delimiter, @char, $end_delimiter;
5234             }
5235              
5236             #
5237             # escape qw string (qw//)
5238             #
5239             sub e_qw {
5240 16     16 0 83 my($ope,$delimiter,$end_delimiter,$string) = @_;
5241              
5242 16         40 $slash = 'div';
5243              
5244             # choice again delimiter
5245 16         211 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         565  
5246 16 50       100 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5247 16         115 return join '', $ope, $delimiter, $string, $end_delimiter;
5248             }
5249             elsif (not $octet{')'}) {
5250 0         0 return join '', $ope, '(', $string, ')';
5251             }
5252             elsif (not $octet{'}'}) {
5253 0         0 return join '', $ope, '{', $string, '}';
5254             }
5255             elsif (not $octet{']'}) {
5256 0         0 return join '', $ope, '[', $string, ']';
5257             }
5258             elsif (not $octet{'>'}) {
5259 0         0 return join '', $ope, '<', $string, '>';
5260             }
5261             else {
5262 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5263 0 0       0 if (not $octet{$char}) {
5264 0         0 return join '', $ope, $char, $string, $char;
5265             }
5266             }
5267             }
5268              
5269             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5270 0         0 my @string = CORE::split(/\s+/, $string);
5271 0         0 for my $string (@string) {
5272 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5273 0         0 for my $octet (@octet) {
5274 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5275 0         0 $octet = '\\' . $1;
5276             }
5277             }
5278 0         0 $string = join '', @octet;
5279             }
5280 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5281             }
5282              
5283             #
5284             # escape here document (<<"HEREDOC", <
5285             #
5286             sub e_heredoc {
5287 78     78 0 210 my($string) = @_;
5288              
5289 78         127 $slash = 'm//';
5290              
5291 78         288 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5292              
5293 78         120 my $left_e = 0;
5294 78         85 my $right_e = 0;
5295              
5296             # split regexp
5297 78         7687 my @char = $string =~ /\G((?>
5298             [^\\\$] |
5299             \\x\{ (?>[0-9A-Fa-f]+) \} |
5300             \\o\{ (?>[0-7]+) \} |
5301             \\N\{ (?>[^0-9\}][^\}]*) \} |
5302             \\ $q_char |
5303             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5304             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5305             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5306             \$ (?>\s* [0-9]+) |
5307             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5308             \$ \$ (?![\w\{]) |
5309             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5310             $q_char
5311             ))/oxmsg;
5312              
5313 78         436 for (my $i=0; $i <= $#char; $i++) {
5314              
5315             # "\L\u" --> "\u\L"
5316 2882 50 33     11844 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5317 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5318             }
5319              
5320             # "\U\l" --> "\l\U"
5321             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5322 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5323             }
5324              
5325             # octal escape sequence
5326             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5327 1         3 $char[$i] = Elatin9::octchr($1);
5328             }
5329              
5330             # hexadecimal escape sequence
5331             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5332 1         3 $char[$i] = Elatin9::hexchr($1);
5333             }
5334              
5335             # \N{CHARNAME} --> N{CHARNAME}
5336             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5337 0         0 $char[$i] = $1;
5338             }
5339              
5340 2882 50       32496 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5341             }
5342              
5343             # \u \l \U \L \F \Q \E
5344 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5345 0 0       0 if ($right_e < $left_e) {
5346 0         0 $char[$i] = '\\' . $char[$i];
5347             }
5348             }
5349             elsif ($char[$i] eq '\u') {
5350 0         0 $char[$i] = '@{[Elatin9::ucfirst qq<';
5351 0         0 $left_e++;
5352             }
5353             elsif ($char[$i] eq '\l') {
5354 0         0 $char[$i] = '@{[Elatin9::lcfirst qq<';
5355 0         0 $left_e++;
5356             }
5357             elsif ($char[$i] eq '\U') {
5358 0         0 $char[$i] = '@{[Elatin9::uc qq<';
5359 0         0 $left_e++;
5360             }
5361             elsif ($char[$i] eq '\L') {
5362 0         0 $char[$i] = '@{[Elatin9::lc qq<';
5363 0         0 $left_e++;
5364             }
5365             elsif ($char[$i] eq '\F') {
5366 0         0 $char[$i] = '@{[Elatin9::fc qq<';
5367 0         0 $left_e++;
5368             }
5369             elsif ($char[$i] eq '\Q') {
5370 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5371 0         0 $left_e++;
5372             }
5373             elsif ($char[$i] eq '\E') {
5374 0 0       0 if ($right_e < $left_e) {
5375 0         0 $char[$i] = '>]}';
5376 0         0 $right_e++;
5377             }
5378             else {
5379 0         0 $char[$i] = '';
5380             }
5381             }
5382             elsif ($char[$i] eq '\Q') {
5383 0         0 while (1) {
5384 0 0       0 if (++$i > $#char) {
5385 0         0 last;
5386             }
5387 0 0       0 if ($char[$i] eq '\E') {
5388 0         0 last;
5389             }
5390             }
5391             }
5392             elsif ($char[$i] eq '\E') {
5393             }
5394              
5395             # $0 --> $0
5396             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5397             }
5398             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5399             }
5400              
5401             # $$ --> $$
5402             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5403             }
5404              
5405             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5406             # $1, $2, $3 --> $1, $2, $3 otherwise
5407             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5408 0         0 $char[$i] = e_capture($1);
5409             }
5410             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5411 0         0 $char[$i] = e_capture($1);
5412             }
5413              
5414             # $$foo[ ... ] --> $ $foo->[ ... ]
5415             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5416 0         0 $char[$i] = e_capture($1.'->'.$2);
5417             }
5418              
5419             # $$foo{ ... } --> $ $foo->{ ... }
5420             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5421 0         0 $char[$i] = e_capture($1.'->'.$2);
5422             }
5423              
5424             # $$foo
5425             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5426 0         0 $char[$i] = e_capture($1);
5427             }
5428              
5429             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin9::PREMATCH()
5430             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5431 8         38 $char[$i] = '@{[Elatin9::PREMATCH()]}';
5432             }
5433              
5434             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin9::MATCH()
5435             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5436 8         44 $char[$i] = '@{[Elatin9::MATCH()]}';
5437             }
5438              
5439             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin9::POSTMATCH()
5440             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5441 6         27 $char[$i] = '@{[Elatin9::POSTMATCH()]}';
5442             }
5443              
5444             # ${ foo } --> ${ foo }
5445             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5446             }
5447              
5448             # ${ ... }
5449             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5450 0         0 $char[$i] = e_capture($1);
5451             }
5452             }
5453              
5454             # return string
5455 78 50       179 if ($left_e > $right_e) {
5456 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5457             }
5458 78         791 return join '', @char;
5459             }
5460              
5461             #
5462             # escape regexp (m//, qr//)
5463             #
5464             sub e_qr {
5465 651     651 0 1935 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5466 651   100     2121 $modifier ||= '';
5467              
5468 651         940 $modifier =~ tr/p//d;
5469 651 50       1451 if ($modifier =~ /([adlu])/oxms) {
5470 0         0 my $line = 0;
5471 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5472 0 0       0 if ($filename ne __FILE__) {
5473 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5474 0         0 last;
5475             }
5476             }
5477 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5478             }
5479              
5480 651         778 $slash = 'div';
5481              
5482             # literal null string pattern
5483 651 100       2069 if ($string eq '') {
    100          
5484 8         7 $modifier =~ tr/bB//d;
5485 8         6 $modifier =~ tr/i//d;
5486 8         43 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5487             }
5488              
5489             # /b /B modifier
5490             elsif ($modifier =~ tr/bB//d) {
5491              
5492             # choice again delimiter
5493 2 50       12 if ($delimiter =~ / [\@:] /oxms) {
5494 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5495 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5496 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5497 0         0 $delimiter = '(';
5498 0         0 $end_delimiter = ')';
5499             }
5500             elsif (not $octet{'}'}) {
5501 0         0 $delimiter = '{';
5502 0         0 $end_delimiter = '}';
5503             }
5504             elsif (not $octet{']'}) {
5505 0         0 $delimiter = '[';
5506 0         0 $end_delimiter = ']';
5507             }
5508             elsif (not $octet{'>'}) {
5509 0         0 $delimiter = '<';
5510 0         0 $end_delimiter = '>';
5511             }
5512             else {
5513 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5514 0 0       0 if (not $octet{$char}) {
5515 0         0 $delimiter = $char;
5516 0         0 $end_delimiter = $char;
5517 0         0 last;
5518             }
5519             }
5520             }
5521             }
5522              
5523 2 50 33     13 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5524 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5525             }
5526             else {
5527 2         9 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5528             }
5529             }
5530              
5531 641 100       1314 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5532 641         2251 my $metachar = qr/[\@\\|[\]{^]/oxms;
5533              
5534             # split regexp
5535 641         64693 my @char = $string =~ /\G((?>
5536             [^\\\$\@\[\(] |
5537             \\x (?>[0-9A-Fa-f]{1,2}) |
5538             \\ (?>[0-7]{2,3}) |
5539             \\c [\x40-\x5F] |
5540             \\x\{ (?>[0-9A-Fa-f]+) \} |
5541             \\o\{ (?>[0-7]+) \} |
5542             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5543             \\ $q_char |
5544             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5545             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5546             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5547             [\$\@] $qq_variable |
5548             \$ (?>\s* [0-9]+) |
5549             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5550             \$ \$ (?![\w\{]) |
5551             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5552             \[\^ |
5553             \[\: (?>[a-z]+) :\] |
5554             \[\:\^ (?>[a-z]+) :\] |
5555             \(\? |
5556             $q_char
5557             ))/oxmsg;
5558              
5559             # choice again delimiter
5560 641 50       2917 if ($delimiter =~ / [\@:] /oxms) {
5561 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5562 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5563 0         0 $delimiter = '(';
5564 0         0 $end_delimiter = ')';
5565             }
5566             elsif (not $octet{'}'}) {
5567 0         0 $delimiter = '{';
5568 0         0 $end_delimiter = '}';
5569             }
5570             elsif (not $octet{']'}) {
5571 0         0 $delimiter = '[';
5572 0         0 $end_delimiter = ']';
5573             }
5574             elsif (not $octet{'>'}) {
5575 0         0 $delimiter = '<';
5576 0         0 $end_delimiter = '>';
5577             }
5578             else {
5579 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5580 0 0       0 if (not $octet{$char}) {
5581 0         0 $delimiter = $char;
5582 0         0 $end_delimiter = $char;
5583 0         0 last;
5584             }
5585             }
5586             }
5587             }
5588              
5589 641         727 my $left_e = 0;
5590 641         614 my $right_e = 0;
5591 641         1616 for (my $i=0; $i <= $#char; $i++) {
5592              
5593             # "\L\u" --> "\u\L"
5594 1867 50 66     10873 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5595 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5596             }
5597              
5598             # "\U\l" --> "\l\U"
5599             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5600 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5601             }
5602              
5603             # octal escape sequence
5604             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5605 1         2 $char[$i] = Elatin9::octchr($1);
5606             }
5607              
5608             # hexadecimal escape sequence
5609             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5610 1         3 $char[$i] = Elatin9::hexchr($1);
5611             }
5612              
5613             # \b{...} --> b\{...}
5614             # \B{...} --> B\{...}
5615             # \N{CHARNAME} --> N\{CHARNAME}
5616             # \p{PROPERTY} --> p\{PROPERTY}
5617             # \P{PROPERTY} --> P\{PROPERTY}
5618             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5619 6         28 $char[$i] = $1 . '\\' . $2;
5620             }
5621              
5622             # \p, \P, \X --> p, P, X
5623             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5624 4         12 $char[$i] = $1;
5625             }
5626              
5627 1867 100 100     5473 if (0) {
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5628             }
5629              
5630             # join separated multiple-octet
5631 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5632 6 50 33     113 if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    50 33        
    50 33        
      33        
      66        
      33        
5633 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5634             }
5635             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)) {
5636 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5637             }
5638             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)) {
5639 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5640             }
5641             }
5642              
5643             # open character class [...]
5644             elsif ($char[$i] eq '[') {
5645 328         352 my $left = $i;
5646              
5647             # [] make die "Unmatched [] in regexp ...\n"
5648             # (and so on)
5649              
5650 328 100       870 if ($char[$i+1] eq ']') {
5651 3         5 $i++;
5652             }
5653              
5654 328         301 while (1) {
5655 1379 50       1801 if (++$i > $#char) {
5656 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5657             }
5658 1379 100       1964 if ($char[$i] eq ']') {
5659 328         297 my $right = $i;
5660              
5661             # [...]
5662 328 100       1702 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5663 30         59 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin9::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         108  
5664             }
5665             else {
5666 298         1063 splice @char, $left, $right-$left+1, Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
5667             }
5668              
5669 328         451 $i = $left;
5670 328         840 last;
5671             }
5672             }
5673             }
5674              
5675             # open character class [^...]
5676             elsif ($char[$i] eq '[^') {
5677 74         74 my $left = $i;
5678              
5679             # [^] make die "Unmatched [] in regexp ...\n"
5680             # (and so on)
5681              
5682 74 100       159 if ($char[$i+1] eq ']') {
5683 4         5 $i++;
5684             }
5685              
5686 74         67 while (1) {
5687 272 50       354 if (++$i > $#char) {
5688 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5689             }
5690 272 100       419 if ($char[$i] eq ']') {
5691 74         67 my $right = $i;
5692              
5693             # [^...]
5694 74 100       409 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5695 30         67 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin9::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         122  
5696             }
5697             else {
5698 44         177 splice @char, $left, $right-$left+1, Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5699             }
5700              
5701 74         106 $i = $left;
5702 74         204 last;
5703             }
5704             }
5705             }
5706              
5707             # rewrite character class or escape character
5708             elsif (my $char = character_class($char[$i],$modifier)) {
5709 139         520 $char[$i] = $char;
5710             }
5711              
5712             # /i modifier
5713             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin9::uc($char[$i]) ne Elatin9::fc($char[$i]))) {
5714 20 50       24 if (CORE::length(Elatin9::fc($char[$i])) == 1) {
5715 20         25 $char[$i] = '[' . Elatin9::uc($char[$i]) . Elatin9::fc($char[$i]) . ']';
5716             }
5717             else {
5718 0         0 $char[$i] = '(?:' . Elatin9::uc($char[$i]) . '|' . Elatin9::fc($char[$i]) . ')';
5719             }
5720             }
5721              
5722             # \u \l \U \L \F \Q \E
5723             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5724 1 50       10 if ($right_e < $left_e) {
5725 0         0 $char[$i] = '\\' . $char[$i];
5726             }
5727             }
5728             elsif ($char[$i] eq '\u') {
5729 0         0 $char[$i] = '@{[Elatin9::ucfirst qq<';
5730 0         0 $left_e++;
5731             }
5732             elsif ($char[$i] eq '\l') {
5733 0         0 $char[$i] = '@{[Elatin9::lcfirst qq<';
5734 0         0 $left_e++;
5735             }
5736             elsif ($char[$i] eq '\U') {
5737 1         3 $char[$i] = '@{[Elatin9::uc qq<';
5738 1         10 $left_e++;
5739             }
5740             elsif ($char[$i] eq '\L') {
5741 1         3 $char[$i] = '@{[Elatin9::lc qq<';
5742 1         7 $left_e++;
5743             }
5744             elsif ($char[$i] eq '\F') {
5745 18         18 $char[$i] = '@{[Elatin9::fc qq<';
5746 18         68 $left_e++;
5747             }
5748             elsif ($char[$i] eq '\Q') {
5749 1         3 $char[$i] = '@{[CORE::quotemeta qq<';
5750 1         8 $left_e++;
5751             }
5752             elsif ($char[$i] eq '\E') {
5753 21 50       38 if ($right_e < $left_e) {
5754 21         22 $char[$i] = '>]}';
5755 21         75 $right_e++;
5756             }
5757             else {
5758 0         0 $char[$i] = '';
5759             }
5760             }
5761             elsif ($char[$i] eq '\Q') {
5762 0         0 while (1) {
5763 0 0       0 if (++$i > $#char) {
5764 0         0 last;
5765             }
5766 0 0       0 if ($char[$i] eq '\E') {
5767 0         0 last;
5768             }
5769             }
5770             }
5771             elsif ($char[$i] eq '\E') {
5772             }
5773              
5774             # $0 --> $0
5775             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5776 0 0       0 if ($ignorecase) {
5777 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5778             }
5779             }
5780             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5781 0 0       0 if ($ignorecase) {
5782 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5783             }
5784             }
5785              
5786             # $$ --> $$
5787             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5788             }
5789              
5790             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5791             # $1, $2, $3 --> $1, $2, $3 otherwise
5792             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5793 0         0 $char[$i] = e_capture($1);
5794 0 0       0 if ($ignorecase) {
5795 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5796             }
5797             }
5798             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5799 0         0 $char[$i] = e_capture($1);
5800 0 0       0 if ($ignorecase) {
5801 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5802             }
5803             }
5804              
5805             # $$foo[ ... ] --> $ $foo->[ ... ]
5806             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5807 0         0 $char[$i] = e_capture($1.'->'.$2);
5808 0 0       0 if ($ignorecase) {
5809 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5810             }
5811             }
5812              
5813             # $$foo{ ... } --> $ $foo->{ ... }
5814             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5815 0         0 $char[$i] = e_capture($1.'->'.$2);
5816 0 0       0 if ($ignorecase) {
5817 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5818             }
5819             }
5820              
5821             # $$foo
5822             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5823 0         0 $char[$i] = e_capture($1);
5824 0 0       0 if ($ignorecase) {
5825 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5826             }
5827             }
5828              
5829             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin9::PREMATCH()
5830             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5831 8 50       17 if ($ignorecase) {
5832 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::PREMATCH())]}';
5833             }
5834             else {
5835 8         33 $char[$i] = '@{[Elatin9::PREMATCH()]}';
5836             }
5837             }
5838              
5839             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin9::MATCH()
5840             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5841 8 50       22 if ($ignorecase) {
5842 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::MATCH())]}';
5843             }
5844             else {
5845 8         43 $char[$i] = '@{[Elatin9::MATCH()]}';
5846             }
5847             }
5848              
5849             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin9::POSTMATCH()
5850             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5851 6 50       13 if ($ignorecase) {
5852 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::POSTMATCH())]}';
5853             }
5854             else {
5855 6         24 $char[$i] = '@{[Elatin9::POSTMATCH()]}';
5856             }
5857             }
5858              
5859             # ${ foo }
5860             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5861 0 0       0 if ($ignorecase) {
5862 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5863             }
5864             }
5865              
5866             # ${ ... }
5867             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5868 0         0 $char[$i] = e_capture($1);
5869 0 0       0 if ($ignorecase) {
5870 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5871             }
5872             }
5873              
5874             # $scalar or @array
5875             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5876 21         39 $char[$i] = e_string($char[$i]);
5877 21 100       87 if ($ignorecase) {
5878 11         49 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
5879             }
5880             }
5881              
5882             # quote character before ? + * {
5883             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5884 138 100 33     1030 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5885             }
5886             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5887 0         0 my $char = $char[$i-1];
5888 0 0       0 if ($char[$i] eq '{') {
5889 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5890             }
5891             else {
5892 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5893             }
5894             }
5895             else {
5896 127         738 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5897             }
5898             }
5899             }
5900              
5901             # make regexp string
5902 641         848 $modifier =~ tr/i//d;
5903 641 50       1440 if ($left_e > $right_e) {
5904 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5905 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5906             }
5907             else {
5908 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5909             }
5910             }
5911 641 50 33     3633 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5912 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5913             }
5914             else {
5915 641         5123 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5916             }
5917             }
5918              
5919             #
5920             # double quote stuff
5921             #
5922             sub qq_stuff {
5923 180     180 0 186 my($delimiter,$end_delimiter,$stuff) = @_;
5924              
5925             # scalar variable or array variable
5926 180 100       340 if ($stuff =~ /\A [\$\@] /oxms) {
5927 100         310 return $stuff;
5928             }
5929              
5930             # quote by delimiter
5931 80         265 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         260  
5932 80         176 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5933 80 50       127 next if $char eq $delimiter;
5934 80 50       105 next if $char eq $end_delimiter;
5935 80 50       137 if (not $octet{$char}) {
5936 80         380 return join '', 'qq', $char, $stuff, $char;
5937             }
5938             }
5939 0         0 return join '', 'qq', '<', $stuff, '>';
5940             }
5941              
5942             #
5943             # escape regexp (m'', qr'', and m''b, qr''b)
5944             #
5945             sub e_qr_q {
5946 10     10 0 22 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5947 10   50     30 $modifier ||= '';
5948              
5949 10         11 $modifier =~ tr/p//d;
5950 10 50       17 if ($modifier =~ /([adlu])/oxms) {
5951 0         0 my $line = 0;
5952 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5953 0 0       0 if ($filename ne __FILE__) {
5954 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5955 0         0 last;
5956             }
5957             }
5958 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5959             }
5960              
5961 10         11 $slash = 'div';
5962              
5963             # literal null string pattern
5964 10 100       17 if ($string eq '') {
    50          
5965 8         8 $modifier =~ tr/bB//d;
5966 8         5 $modifier =~ tr/i//d;
5967 8         36 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5968             }
5969              
5970             # with /b /B modifier
5971             elsif ($modifier =~ tr/bB//d) {
5972 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5973             }
5974              
5975             # without /b /B modifier
5976             else {
5977 2         5 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5978             }
5979             }
5980              
5981             #
5982             # escape regexp (m'', qr'')
5983             #
5984             sub e_qr_qt {
5985 2     2 0 4 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5986              
5987 2 50       5 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5988              
5989             # split regexp
5990 2         66 my @char = $string =~ /\G((?>
5991             [^\\\[\$\@\/] |
5992             [\x00-\xFF] |
5993             \[\^ |
5994             \[\: (?>[a-z]+) \:\] |
5995             \[\:\^ (?>[a-z]+) \:\] |
5996             [\$\@\/] |
5997             \\ (?:$q_char) |
5998             (?:$q_char)
5999             ))/oxmsg;
6000              
6001             # unescape character
6002 2         9 for (my $i=0; $i <= $#char; $i++) {
6003 2 50 33     14 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
6004             }
6005              
6006             # open character class [...]
6007 0         0 elsif ($char[$i] eq '[') {
6008 0         0 my $left = $i;
6009 0 0       0 if ($char[$i+1] eq ']') {
6010 0         0 $i++;
6011             }
6012 0         0 while (1) {
6013 0 0       0 if (++$i > $#char) {
6014 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6015             }
6016 0 0       0 if ($char[$i] eq ']') {
6017 0         0 my $right = $i;
6018              
6019             # [...]
6020 0         0 splice @char, $left, $right-$left+1, Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
6021              
6022 0         0 $i = $left;
6023 0         0 last;
6024             }
6025             }
6026             }
6027              
6028             # open character class [^...]
6029             elsif ($char[$i] eq '[^') {
6030 0         0 my $left = $i;
6031 0 0       0 if ($char[$i+1] eq ']') {
6032 0         0 $i++;
6033             }
6034 0         0 while (1) {
6035 0 0       0 if (++$i > $#char) {
6036 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6037             }
6038 0 0       0 if ($char[$i] eq ']') {
6039 0         0 my $right = $i;
6040              
6041             # [^...]
6042 0         0 splice @char, $left, $right-$left+1, Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6043              
6044 0         0 $i = $left;
6045 0         0 last;
6046             }
6047             }
6048             }
6049              
6050             # escape $ @ / and \
6051             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6052 0         0 $char[$i] = '\\' . $char[$i];
6053             }
6054              
6055             # rewrite character class or escape character
6056             elsif (my $char = character_class($char[$i],$modifier)) {
6057 0         0 $char[$i] = $char;
6058             }
6059              
6060             # /i modifier
6061             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin9::uc($char[$i]) ne Elatin9::fc($char[$i]))) {
6062 0 0       0 if (CORE::length(Elatin9::fc($char[$i])) == 1) {
6063 0         0 $char[$i] = '[' . Elatin9::uc($char[$i]) . Elatin9::fc($char[$i]) . ']';
6064             }
6065             else {
6066 0         0 $char[$i] = '(?:' . Elatin9::uc($char[$i]) . '|' . Elatin9::fc($char[$i]) . ')';
6067             }
6068             }
6069              
6070             # quote character before ? + * {
6071             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6072 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6073             }
6074             else {
6075 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6076             }
6077             }
6078             }
6079              
6080 2         2 $delimiter = '/';
6081 2         3 $end_delimiter = '/';
6082              
6083 2         2 $modifier =~ tr/i//d;
6084 2         13 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6085             }
6086              
6087             #
6088             # escape regexp (m''b, qr''b)
6089             #
6090             sub e_qr_qb {
6091 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6092              
6093             # split regexp
6094 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6095              
6096             # unescape character
6097 0         0 for (my $i=0; $i <= $#char; $i++) {
6098 0 0       0 if (0) {
    0          
6099             }
6100              
6101             # remain \\
6102 0         0 elsif ($char[$i] eq '\\\\') {
6103             }
6104              
6105             # escape $ @ / and \
6106             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6107 0         0 $char[$i] = '\\' . $char[$i];
6108             }
6109             }
6110              
6111 0         0 $delimiter = '/';
6112 0         0 $end_delimiter = '/';
6113 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6114             }
6115              
6116             #
6117             # escape regexp (s/here//)
6118             #
6119             sub e_s1 {
6120 76     76 0 150 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6121 76   100     293 $modifier ||= '';
6122              
6123 76         101 $modifier =~ tr/p//d;
6124 76 50       194 if ($modifier =~ /([adlu])/oxms) {
6125 0         0 my $line = 0;
6126 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6127 0 0       0 if ($filename ne __FILE__) {
6128 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6129 0         0 last;
6130             }
6131             }
6132 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6133             }
6134              
6135 76         104 $slash = 'div';
6136              
6137             # literal null string pattern
6138 76 100       247 if ($string eq '') {
    50          
6139 8         7 $modifier =~ tr/bB//d;
6140 8         6 $modifier =~ tr/i//d;
6141 8         48 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6142             }
6143              
6144             # /b /B modifier
6145             elsif ($modifier =~ tr/bB//d) {
6146              
6147             # choice again delimiter
6148 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6149 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6150 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6151 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6152 0         0 $delimiter = '(';
6153 0         0 $end_delimiter = ')';
6154             }
6155             elsif (not $octet{'}'}) {
6156 0         0 $delimiter = '{';
6157 0         0 $end_delimiter = '}';
6158             }
6159             elsif (not $octet{']'}) {
6160 0         0 $delimiter = '[';
6161 0         0 $end_delimiter = ']';
6162             }
6163             elsif (not $octet{'>'}) {
6164 0         0 $delimiter = '<';
6165 0         0 $end_delimiter = '>';
6166             }
6167             else {
6168 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6169 0 0       0 if (not $octet{$char}) {
6170 0         0 $delimiter = $char;
6171 0         0 $end_delimiter = $char;
6172 0         0 last;
6173             }
6174             }
6175             }
6176             }
6177              
6178 0         0 my $prematch = '';
6179 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6180             }
6181              
6182 68 100       181 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6183 68         268 my $metachar = qr/[\@\\|[\]{^]/oxms;
6184              
6185             # split regexp
6186 68         16620 my @char = $string =~ /\G((?>
6187             [^\\\$\@\[\(] |
6188             \\ (?>[1-9][0-9]*) |
6189             \\g (?>\s*) (?>[1-9][0-9]*) |
6190             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6191             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6192             \\x (?>[0-9A-Fa-f]{1,2}) |
6193             \\ (?>[0-7]{2,3}) |
6194             \\c [\x40-\x5F] |
6195             \\x\{ (?>[0-9A-Fa-f]+) \} |
6196             \\o\{ (?>[0-7]+) \} |
6197             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6198             \\ $q_char |
6199             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6200             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6201             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6202             [\$\@] $qq_variable |
6203             \$ (?>\s* [0-9]+) |
6204             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6205             \$ \$ (?![\w\{]) |
6206             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6207             \[\^ |
6208             \[\: (?>[a-z]+) :\] |
6209             \[\:\^ (?>[a-z]+) :\] |
6210             \(\? |
6211             $q_char
6212             ))/oxmsg;
6213              
6214             # choice again delimiter
6215 68 50       576 if ($delimiter =~ / [\@:] /oxms) {
6216 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6217 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6218 0         0 $delimiter = '(';
6219 0         0 $end_delimiter = ')';
6220             }
6221             elsif (not $octet{'}'}) {
6222 0         0 $delimiter = '{';
6223 0         0 $end_delimiter = '}';
6224             }
6225             elsif (not $octet{']'}) {
6226 0         0 $delimiter = '[';
6227 0         0 $end_delimiter = ']';
6228             }
6229             elsif (not $octet{'>'}) {
6230 0         0 $delimiter = '<';
6231 0         0 $end_delimiter = '>';
6232             }
6233             else {
6234 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6235 0 0       0 if (not $octet{$char}) {
6236 0         0 $delimiter = $char;
6237 0         0 $end_delimiter = $char;
6238 0         0 last;
6239             }
6240             }
6241             }
6242             }
6243              
6244             # count '('
6245 68         117 my $parens = grep { $_ eq '(' } @char;
  253         393  
6246              
6247 68         105 my $left_e = 0;
6248 68         86 my $right_e = 0;
6249 68         229 for (my $i=0; $i <= $#char; $i++) {
6250              
6251             # "\L\u" --> "\u\L"
6252 195 50 33     1404 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6253 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6254             }
6255              
6256             # "\U\l" --> "\l\U"
6257             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6258 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6259             }
6260              
6261             # octal escape sequence
6262             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6263 1         2 $char[$i] = Elatin9::octchr($1);
6264             }
6265              
6266             # hexadecimal escape sequence
6267             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6268 1         4 $char[$i] = Elatin9::hexchr($1);
6269             }
6270              
6271             # \b{...} --> b\{...}
6272             # \B{...} --> B\{...}
6273             # \N{CHARNAME} --> N\{CHARNAME}
6274             # \p{PROPERTY} --> p\{PROPERTY}
6275             # \P{PROPERTY} --> P\{PROPERTY}
6276             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6277 0         0 $char[$i] = $1 . '\\' . $2;
6278             }
6279              
6280             # \p, \P, \X --> p, P, X
6281             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6282 0         0 $char[$i] = $1;
6283             }
6284              
6285 195 50 66     757 if (0) {
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6286             }
6287              
6288             # join separated multiple-octet
6289 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6290 0 0 0     0 if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6291 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6292             }
6293             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)) {
6294 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6295             }
6296             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)) {
6297 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6298             }
6299             }
6300              
6301             # open character class [...]
6302             elsif ($char[$i] eq '[') {
6303 13         27 my $left = $i;
6304 13 50       60 if ($char[$i+1] eq ']') {
6305 0         0 $i++;
6306             }
6307 13         13 while (1) {
6308 58 50       107 if (++$i > $#char) {
6309 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6310             }
6311 58 100       91 if ($char[$i] eq ']') {
6312 13         22 my $right = $i;
6313              
6314             # [...]
6315 13 50       91 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6316 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin9::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6317             }
6318             else {
6319 13         87 splice @char, $left, $right-$left+1, Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
6320             }
6321              
6322 13         26 $i = $left;
6323 13         47 last;
6324             }
6325             }
6326             }
6327              
6328             # open character class [^...]
6329             elsif ($char[$i] eq '[^') {
6330 0         0 my $left = $i;
6331 0 0       0 if ($char[$i+1] eq ']') {
6332 0         0 $i++;
6333             }
6334 0         0 while (1) {
6335 0 0       0 if (++$i > $#char) {
6336 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6337             }
6338 0 0       0 if ($char[$i] eq ']') {
6339 0         0 my $right = $i;
6340              
6341             # [^...]
6342 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6343 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin9::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6344             }
6345             else {
6346 0         0 splice @char, $left, $right-$left+1, Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6347             }
6348              
6349 0         0 $i = $left;
6350 0         0 last;
6351             }
6352             }
6353             }
6354              
6355             # rewrite character class or escape character
6356             elsif (my $char = character_class($char[$i],$modifier)) {
6357 7         16 $char[$i] = $char;
6358             }
6359              
6360             # /i modifier
6361             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin9::uc($char[$i]) ne Elatin9::fc($char[$i]))) {
6362 3 50       7 if (CORE::length(Elatin9::fc($char[$i])) == 1) {
6363 3         7 $char[$i] = '[' . Elatin9::uc($char[$i]) . Elatin9::fc($char[$i]) . ']';
6364             }
6365             else {
6366 0         0 $char[$i] = '(?:' . Elatin9::uc($char[$i]) . '|' . Elatin9::fc($char[$i]) . ')';
6367             }
6368             }
6369              
6370             # \u \l \U \L \F \Q \E
6371             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6372 0 0       0 if ($right_e < $left_e) {
6373 0         0 $char[$i] = '\\' . $char[$i];
6374             }
6375             }
6376             elsif ($char[$i] eq '\u') {
6377 0         0 $char[$i] = '@{[Elatin9::ucfirst qq<';
6378 0         0 $left_e++;
6379             }
6380             elsif ($char[$i] eq '\l') {
6381 0         0 $char[$i] = '@{[Elatin9::lcfirst qq<';
6382 0         0 $left_e++;
6383             }
6384             elsif ($char[$i] eq '\U') {
6385 0         0 $char[$i] = '@{[Elatin9::uc qq<';
6386 0         0 $left_e++;
6387             }
6388             elsif ($char[$i] eq '\L') {
6389 0         0 $char[$i] = '@{[Elatin9::lc qq<';
6390 0         0 $left_e++;
6391             }
6392             elsif ($char[$i] eq '\F') {
6393 0         0 $char[$i] = '@{[Elatin9::fc qq<';
6394 0         0 $left_e++;
6395             }
6396             elsif ($char[$i] eq '\Q') {
6397 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6398 0         0 $left_e++;
6399             }
6400             elsif ($char[$i] eq '\E') {
6401 0 0       0 if ($right_e < $left_e) {
6402 0         0 $char[$i] = '>]}';
6403 0         0 $right_e++;
6404             }
6405             else {
6406 0         0 $char[$i] = '';
6407             }
6408             }
6409             elsif ($char[$i] eq '\Q') {
6410 0         0 while (1) {
6411 0 0       0 if (++$i > $#char) {
6412 0         0 last;
6413             }
6414 0 0       0 if ($char[$i] eq '\E') {
6415 0         0 last;
6416             }
6417             }
6418             }
6419             elsif ($char[$i] eq '\E') {
6420             }
6421              
6422             # \0 --> \0
6423             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6424             }
6425              
6426             # \g{N}, \g{-N}
6427              
6428             # P.108 Using Simple Patterns
6429             # in Chapter 7: In the World of Regular Expressions
6430             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6431              
6432             # P.221 Capturing
6433             # in Chapter 5: Pattern Matching
6434             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6435              
6436             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6437             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6438             }
6439              
6440             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6441             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6442             }
6443              
6444             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6445             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6446             }
6447              
6448             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6449             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6450             }
6451              
6452             # $0 --> $0
6453             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6454 0 0       0 if ($ignorecase) {
6455 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6456             }
6457             }
6458             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6459 0 0       0 if ($ignorecase) {
6460 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6461             }
6462             }
6463              
6464             # $$ --> $$
6465             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6466             }
6467              
6468             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6469             # $1, $2, $3 --> $1, $2, $3 otherwise
6470             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6471 0         0 $char[$i] = e_capture($1);
6472 0 0       0 if ($ignorecase) {
6473 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6474             }
6475             }
6476             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6477 0         0 $char[$i] = e_capture($1);
6478 0 0       0 if ($ignorecase) {
6479 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6480             }
6481             }
6482              
6483             # $$foo[ ... ] --> $ $foo->[ ... ]
6484             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6485 0         0 $char[$i] = e_capture($1.'->'.$2);
6486 0 0       0 if ($ignorecase) {
6487 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6488             }
6489             }
6490              
6491             # $$foo{ ... } --> $ $foo->{ ... }
6492             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6493 0         0 $char[$i] = e_capture($1.'->'.$2);
6494 0 0       0 if ($ignorecase) {
6495 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6496             }
6497             }
6498              
6499             # $$foo
6500             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6501 0         0 $char[$i] = e_capture($1);
6502 0 0       0 if ($ignorecase) {
6503 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6504             }
6505             }
6506              
6507             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin9::PREMATCH()
6508             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6509 4 50       11 if ($ignorecase) {
6510 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::PREMATCH())]}';
6511             }
6512             else {
6513 4         19 $char[$i] = '@{[Elatin9::PREMATCH()]}';
6514             }
6515             }
6516              
6517             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin9::MATCH()
6518             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6519 4 50       14 if ($ignorecase) {
6520 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::MATCH())]}';
6521             }
6522             else {
6523 4         25 $char[$i] = '@{[Elatin9::MATCH()]}';
6524             }
6525             }
6526              
6527             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin9::POSTMATCH()
6528             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6529 3 50       8 if ($ignorecase) {
6530 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::POSTMATCH())]}';
6531             }
6532             else {
6533 3         14 $char[$i] = '@{[Elatin9::POSTMATCH()]}';
6534             }
6535             }
6536              
6537             # ${ foo }
6538             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6539 0 0       0 if ($ignorecase) {
6540 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6541             }
6542             }
6543              
6544             # ${ ... }
6545             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6546 0         0 $char[$i] = e_capture($1);
6547 0 0       0 if ($ignorecase) {
6548 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6549             }
6550             }
6551              
6552             # $scalar or @array
6553             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6554 4         10 $char[$i] = e_string($char[$i]);
6555 4 50       38 if ($ignorecase) {
6556 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
6557             }
6558             }
6559              
6560             # quote character before ? + * {
6561             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6562 13 50       57 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6563             }
6564             else {
6565 13         95 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6566             }
6567             }
6568             }
6569              
6570             # make regexp string
6571 68         129 my $prematch = '';
6572 68         91 $modifier =~ tr/i//d;
6573 68 50       252 if ($left_e > $right_e) {
6574 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6575             }
6576 68         834 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6577             }
6578              
6579             #
6580             # escape regexp (s'here'' or s'here''b)
6581             #
6582             sub e_s1_q {
6583 21     21 0 35 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6584 21   100     58 $modifier ||= '';
6585              
6586 21         22 $modifier =~ tr/p//d;
6587 21 50       51 if ($modifier =~ /([adlu])/oxms) {
6588 0         0 my $line = 0;
6589 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6590 0 0       0 if ($filename ne __FILE__) {
6591 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6592 0         0 last;
6593             }
6594             }
6595 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6596             }
6597              
6598 21         25 $slash = 'div';
6599              
6600             # literal null string pattern
6601 21 100       42 if ($string eq '') {
    50          
6602 8         7 $modifier =~ tr/bB//d;
6603 8         7 $modifier =~ tr/i//d;
6604 8         43 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6605             }
6606              
6607             # with /b /B modifier
6608             elsif ($modifier =~ tr/bB//d) {
6609 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6610             }
6611              
6612             # without /b /B modifier
6613             else {
6614 13         33 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6615             }
6616             }
6617              
6618             #
6619             # escape regexp (s'here'')
6620             #
6621             sub e_s1_qt {
6622 13     13 0 34 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6623              
6624 13 50       25 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6625              
6626             # split regexp
6627 13         244 my @char = $string =~ /\G((?>
6628             [^\\\[\$\@\/] |
6629             [\x00-\xFF] |
6630             \[\^ |
6631             \[\: (?>[a-z]+) \:\] |
6632             \[\:\^ (?>[a-z]+) \:\] |
6633             [\$\@\/] |
6634             \\ (?:$q_char) |
6635             (?:$q_char)
6636             ))/oxmsg;
6637              
6638             # unescape character
6639 13         39 for (my $i=0; $i <= $#char; $i++) {
6640 25 50 33     111 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6641             }
6642              
6643             # open character class [...]
6644 0         0 elsif ($char[$i] eq '[') {
6645 0         0 my $left = $i;
6646 0 0       0 if ($char[$i+1] eq ']') {
6647 0         0 $i++;
6648             }
6649 0         0 while (1) {
6650 0 0       0 if (++$i > $#char) {
6651 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6652             }
6653 0 0       0 if ($char[$i] eq ']') {
6654 0         0 my $right = $i;
6655              
6656             # [...]
6657 0         0 splice @char, $left, $right-$left+1, Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
6658              
6659 0         0 $i = $left;
6660 0         0 last;
6661             }
6662             }
6663             }
6664              
6665             # open character class [^...]
6666             elsif ($char[$i] eq '[^') {
6667 0         0 my $left = $i;
6668 0 0       0 if ($char[$i+1] eq ']') {
6669 0         0 $i++;
6670             }
6671 0         0 while (1) {
6672 0 0       0 if (++$i > $#char) {
6673 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6674             }
6675 0 0       0 if ($char[$i] eq ']') {
6676 0         0 my $right = $i;
6677              
6678             # [^...]
6679 0         0 splice @char, $left, $right-$left+1, Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6680              
6681 0         0 $i = $left;
6682 0         0 last;
6683             }
6684             }
6685             }
6686              
6687             # escape $ @ / and \
6688             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6689 0         0 $char[$i] = '\\' . $char[$i];
6690             }
6691              
6692             # rewrite character class or escape character
6693             elsif (my $char = character_class($char[$i],$modifier)) {
6694 6         11 $char[$i] = $char;
6695             }
6696              
6697             # /i modifier
6698             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin9::uc($char[$i]) ne Elatin9::fc($char[$i]))) {
6699 0 0       0 if (CORE::length(Elatin9::fc($char[$i])) == 1) {
6700 0         0 $char[$i] = '[' . Elatin9::uc($char[$i]) . Elatin9::fc($char[$i]) . ']';
6701             }
6702             else {
6703 0         0 $char[$i] = '(?:' . Elatin9::uc($char[$i]) . '|' . Elatin9::fc($char[$i]) . ')';
6704             }
6705             }
6706              
6707             # quote character before ? + * {
6708             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6709 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6710             }
6711             else {
6712 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6713             }
6714             }
6715             }
6716              
6717 13         18 $modifier =~ tr/i//d;
6718 13         17 $delimiter = '/';
6719 13         14 $end_delimiter = '/';
6720 13         10 my $prematch = '';
6721 13         105 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6722             }
6723              
6724             #
6725             # escape regexp (s'here''b)
6726             #
6727             sub e_s1_qb {
6728 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6729              
6730             # split regexp
6731 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6732              
6733             # unescape character
6734 0         0 for (my $i=0; $i <= $#char; $i++) {
6735 0 0       0 if (0) {
    0          
6736             }
6737              
6738             # remain \\
6739 0         0 elsif ($char[$i] eq '\\\\') {
6740             }
6741              
6742             # escape $ @ / and \
6743             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6744 0         0 $char[$i] = '\\' . $char[$i];
6745             }
6746             }
6747              
6748 0         0 $delimiter = '/';
6749 0         0 $end_delimiter = '/';
6750 0         0 my $prematch = '';
6751 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6752             }
6753              
6754             #
6755             # escape regexp (s''here')
6756             #
6757             sub e_s2_q {
6758 16     16 0 24 my($ope,$delimiter,$end_delimiter,$string) = @_;
6759              
6760 16         23 $slash = 'div';
6761              
6762 16         119 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6763 16         46 for (my $i=0; $i <= $#char; $i++) {
6764 9 100       37 if (0) {
    100          
6765             }
6766              
6767             # not escape \\
6768 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6769             }
6770              
6771             # escape $ @ / and \
6772             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6773 5         15 $char[$i] = '\\' . $char[$i];
6774             }
6775             }
6776              
6777 16         51 return join '', $ope, $delimiter, @char, $end_delimiter;
6778             }
6779              
6780             #
6781             # escape regexp (s/here/and here/modifier)
6782             #
6783             sub e_sub {
6784 97     97 0 426 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6785 97   100     352 $modifier ||= '';
6786              
6787 97         161 $modifier =~ tr/p//d;
6788 97 50       251 if ($modifier =~ /([adlu])/oxms) {
6789 0         0 my $line = 0;
6790 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6791 0 0       0 if ($filename ne __FILE__) {
6792 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6793 0         0 last;
6794             }
6795             }
6796 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6797             }
6798              
6799 97 100       239 if ($variable eq '') {
6800 36         28 $variable = '$_';
6801 36         48 $bind_operator = ' =~ ';
6802             }
6803              
6804 97         137 $slash = 'div';
6805              
6806             # P.128 Start of match (or end of previous match): \G
6807             # P.130 Advanced Use of \G with Perl
6808             # in Chapter 3: Overview of Regular Expression Features and Flavors
6809             # P.312 Iterative Matching: Scalar Context, with /g
6810             # in Chapter 7: Perl
6811             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6812              
6813             # P.181 Where You Left Off: The \G Assertion
6814             # in Chapter 5: Pattern Matching
6815             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6816              
6817             # P.220 Where You Left Off: The \G Assertion
6818             # in Chapter 5: Pattern Matching
6819             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6820              
6821 97         129 my $e_modifier = $modifier =~ tr/e//d;
6822 97         116 my $r_modifier = $modifier =~ tr/r//d;
6823              
6824 97         109 my $my = '';
6825 97 50       240 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6826 0         0 $my = $variable;
6827 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6828 0         0 $variable =~ s/ = .+ \z//oxms;
6829             }
6830              
6831 97         211 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6832 97         159 $variable_basename =~ s/ \s+ \z//oxms;
6833              
6834             # quote replacement string
6835 97         124 my $e_replacement = '';
6836 97 100       196 if ($e_modifier >= 1) {
6837 17         26 $e_replacement = e_qq('', '', '', $replacement);
6838 17         23 $e_modifier--;
6839             }
6840             else {
6841 80 100       163 if ($delimiter2 eq "'") {
6842 16         30 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6843             }
6844             else {
6845 64         159 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6846             }
6847             }
6848              
6849 97         140 my $sub = '';
6850              
6851             # with /r
6852 97 100       185 if ($r_modifier) {
6853 8 100       18 if (0) {
6854             }
6855              
6856             # s///gr without multibyte anchoring
6857 0         0 elsif ($modifier =~ /g/oxms) {
6858 4 50       18 $sub = sprintf(
6859             # 1 2 3 4 5
6860             q,
6861              
6862             $variable, # 1
6863             ($delimiter1 eq "'") ? # 2
6864             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6865             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6866             $s_matched, # 3
6867             $e_replacement, # 4
6868             '$Latin9::re_r=CORE::eval $Latin9::re_r; ' x $e_modifier, # 5
6869             );
6870             }
6871              
6872             # s///r
6873             else {
6874              
6875 4         6 my $prematch = q{$`};
6876              
6877 4 50       13 $sub = sprintf(
6878             # 1 2 3 4 5 6 7
6879             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Latin9::re_r=%s; %s"%s$Latin9::re_r$'" } : %s>,
6880              
6881             $variable, # 1
6882             ($delimiter1 eq "'") ? # 2
6883             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6884             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6885             $s_matched, # 3
6886             $e_replacement, # 4
6887             '$Latin9::re_r=CORE::eval $Latin9::re_r; ' x $e_modifier, # 5
6888             $prematch, # 6
6889             $variable, # 7
6890             );
6891             }
6892              
6893             # $var !~ s///r doesn't make sense
6894 8 50       25 if ($bind_operator =~ / !~ /oxms) {
6895 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6896             }
6897             }
6898              
6899             # without /r
6900             else {
6901 89 100       201 if (0) {
6902             }
6903              
6904             # s///g without multibyte anchoring
6905 0         0 elsif ($modifier =~ /g/oxms) {
6906 22 100       91 $sub = sprintf(
    100          
6907             # 1 2 3 4 5 6 7 8
6908             q,
6909              
6910             $variable, # 1
6911             ($delimiter1 eq "'") ? # 2
6912             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6913             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6914             $s_matched, # 3
6915             $e_replacement, # 4
6916             '$Latin9::re_r=CORE::eval $Latin9::re_r; ' x $e_modifier, # 5
6917             $variable, # 6
6918             $variable, # 7
6919             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6920             );
6921             }
6922              
6923             # s///
6924             else {
6925              
6926 67         86 my $prematch = q{$`};
6927              
6928 67 100       363 $sub = sprintf(
    100          
6929              
6930             ($bind_operator =~ / =~ /oxms) ?
6931              
6932             # 1 2 3 4 5 6 7 8
6933             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Latin9::re_r=%s; %s%s="%s$Latin9::re_r$'"; 1 } : undef> :
6934              
6935             # 1 2 3 4 5 6 7 8
6936             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Latin9::re_r=%s; %s%s="%s$Latin9::re_r$'"; undef }>,
6937              
6938             $variable, # 1
6939             $bind_operator, # 2
6940             ($delimiter1 eq "'") ? # 3
6941             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6942             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6943             $s_matched, # 4
6944             $e_replacement, # 5
6945             '$Latin9::re_r=CORE::eval $Latin9::re_r; ' x $e_modifier, # 6
6946             $variable, # 7
6947             $prematch, # 8
6948             );
6949             }
6950             }
6951              
6952             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6953 97 50       248 if ($my ne '') {
6954 0         0 $sub = "($my, $sub)[1]";
6955             }
6956              
6957             # clear s/// variable
6958 97         108 $sub_variable = '';
6959 97         97 $bind_operator = '';
6960              
6961 97         659 return $sub;
6962             }
6963              
6964             #
6965             # escape regexp of split qr//
6966             #
6967             sub e_split {
6968 74     74 0 225 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6969 74   100     349 $modifier ||= '';
6970              
6971 74         121 $modifier =~ tr/p//d;
6972 74 50       335 if ($modifier =~ /([adlu])/oxms) {
6973 0         0 my $line = 0;
6974 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6975 0 0       0 if ($filename ne __FILE__) {
6976 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6977 0         0 last;
6978             }
6979             }
6980 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6981             }
6982              
6983 74         119 $slash = 'div';
6984              
6985             # /b /B modifier
6986 74 50       171 if ($modifier =~ tr/bB//d) {
6987 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6988             }
6989              
6990 74 50       179 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6991 74         310 my $metachar = qr/[\@\\|[\]{^]/oxms;
6992              
6993             # split regexp
6994 74         9368 my @char = $string =~ /\G((?>
6995             [^\\\$\@\[\(] |
6996             \\x (?>[0-9A-Fa-f]{1,2}) |
6997             \\ (?>[0-7]{2,3}) |
6998             \\c [\x40-\x5F] |
6999             \\x\{ (?>[0-9A-Fa-f]+) \} |
7000             \\o\{ (?>[0-7]+) \} |
7001             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7002             \\ $q_char |
7003             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7004             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7005             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7006             [\$\@] $qq_variable |
7007             \$ (?>\s* [0-9]+) |
7008             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7009             \$ \$ (?![\w\{]) |
7010             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7011             \[\^ |
7012             \[\: (?>[a-z]+) :\] |
7013             \[\:\^ (?>[a-z]+) :\] |
7014             \(\? |
7015             $q_char
7016             ))/oxmsg;
7017              
7018 74         261 my $left_e = 0;
7019 74         82 my $right_e = 0;
7020 74         299 for (my $i=0; $i <= $#char; $i++) {
7021              
7022             # "\L\u" --> "\u\L"
7023 249 50 33     1720 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7024 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7025             }
7026              
7027             # "\U\l" --> "\l\U"
7028             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7029 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7030             }
7031              
7032             # octal escape sequence
7033             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7034 1         3 $char[$i] = Elatin9::octchr($1);
7035             }
7036              
7037             # hexadecimal escape sequence
7038             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7039 1         3 $char[$i] = Elatin9::hexchr($1);
7040             }
7041              
7042             # \b{...} --> b\{...}
7043             # \B{...} --> B\{...}
7044             # \N{CHARNAME} --> N\{CHARNAME}
7045             # \p{PROPERTY} --> p\{PROPERTY}
7046             # \P{PROPERTY} --> P\{PROPERTY}
7047             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7048 0         0 $char[$i] = $1 . '\\' . $2;
7049             }
7050              
7051             # \p, \P, \X --> p, P, X
7052             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7053 0         0 $char[$i] = $1;
7054             }
7055              
7056 249 50 100     967 if (0) {
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7057             }
7058              
7059             # join separated multiple-octet
7060 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7061 0 0 0     0 if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
7062 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7063             }
7064             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)) {
7065 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7066             }
7067             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)) {
7068 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7069             }
7070             }
7071              
7072             # open character class [...]
7073             elsif ($char[$i] eq '[') {
7074 3         5 my $left = $i;
7075 3 50       13 if ($char[$i+1] eq ']') {
7076 0         0 $i++;
7077             }
7078 3         5 while (1) {
7079 7 50       26 if (++$i > $#char) {
7080 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7081             }
7082 7 100       17 if ($char[$i] eq ']') {
7083 3         5 my $right = $i;
7084              
7085             # [...]
7086 3 50       24 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7087 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin9::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7088             }
7089             else {
7090 3         20 splice @char, $left, $right-$left+1, Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
7091             }
7092              
7093 3         6 $i = $left;
7094 3         10 last;
7095             }
7096             }
7097             }
7098              
7099             # open character class [^...]
7100             elsif ($char[$i] eq '[^') {
7101 0         0 my $left = $i;
7102 0 0       0 if ($char[$i+1] eq ']') {
7103 0         0 $i++;
7104             }
7105 0         0 while (1) {
7106 0 0       0 if (++$i > $#char) {
7107 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7108             }
7109 0 0       0 if ($char[$i] eq ']') {
7110 0         0 my $right = $i;
7111              
7112             # [^...]
7113 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7114 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Elatin9::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7115             }
7116             else {
7117 0         0 splice @char, $left, $right-$left+1, Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7118             }
7119              
7120 0         0 $i = $left;
7121 0         0 last;
7122             }
7123             }
7124             }
7125              
7126             # rewrite character class or escape character
7127             elsif (my $char = character_class($char[$i],$modifier)) {
7128 1         4 $char[$i] = $char;
7129             }
7130              
7131             # P.794 29.2.161. split
7132             # in Chapter 29: Functions
7133             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7134              
7135             # P.951 split
7136             # in Chapter 27: Functions
7137             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7138              
7139             # said "The //m modifier is assumed when you split on the pattern /^/",
7140             # but perl5.008 is not so. Therefore, this software adds //m.
7141             # (and so on)
7142              
7143             # split(m/^/) --> split(m/^/m)
7144             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7145 7         34 $modifier .= 'm';
7146             }
7147              
7148             # /i modifier
7149             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin9::uc($char[$i]) ne Elatin9::fc($char[$i]))) {
7150 0 0       0 if (CORE::length(Elatin9::fc($char[$i])) == 1) {
7151 0         0 $char[$i] = '[' . Elatin9::uc($char[$i]) . Elatin9::fc($char[$i]) . ']';
7152             }
7153             else {
7154 0         0 $char[$i] = '(?:' . Elatin9::uc($char[$i]) . '|' . Elatin9::fc($char[$i]) . ')';
7155             }
7156             }
7157              
7158             # \u \l \U \L \F \Q \E
7159             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7160 0 0       0 if ($right_e < $left_e) {
7161 0         0 $char[$i] = '\\' . $char[$i];
7162             }
7163             }
7164             elsif ($char[$i] eq '\u') {
7165 0         0 $char[$i] = '@{[Elatin9::ucfirst qq<';
7166 0         0 $left_e++;
7167             }
7168             elsif ($char[$i] eq '\l') {
7169 0         0 $char[$i] = '@{[Elatin9::lcfirst qq<';
7170 0         0 $left_e++;
7171             }
7172             elsif ($char[$i] eq '\U') {
7173 0         0 $char[$i] = '@{[Elatin9::uc qq<';
7174 0         0 $left_e++;
7175             }
7176             elsif ($char[$i] eq '\L') {
7177 0         0 $char[$i] = '@{[Elatin9::lc qq<';
7178 0         0 $left_e++;
7179             }
7180             elsif ($char[$i] eq '\F') {
7181 0         0 $char[$i] = '@{[Elatin9::fc qq<';
7182 0         0 $left_e++;
7183             }
7184             elsif ($char[$i] eq '\Q') {
7185 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7186 0         0 $left_e++;
7187             }
7188             elsif ($char[$i] eq '\E') {
7189 0 0       0 if ($right_e < $left_e) {
7190 0         0 $char[$i] = '>]}';
7191 0         0 $right_e++;
7192             }
7193             else {
7194 0         0 $char[$i] = '';
7195             }
7196             }
7197             elsif ($char[$i] eq '\Q') {
7198 0         0 while (1) {
7199 0 0       0 if (++$i > $#char) {
7200 0         0 last;
7201             }
7202 0 0       0 if ($char[$i] eq '\E') {
7203 0         0 last;
7204             }
7205             }
7206             }
7207             elsif ($char[$i] eq '\E') {
7208             }
7209              
7210             # $0 --> $0
7211             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7212 0 0       0 if ($ignorecase) {
7213 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7214             }
7215             }
7216             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7217 0 0       0 if ($ignorecase) {
7218 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7219             }
7220             }
7221              
7222             # $$ --> $$
7223             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7224             }
7225              
7226             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7227             # $1, $2, $3 --> $1, $2, $3 otherwise
7228             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7229 0         0 $char[$i] = e_capture($1);
7230 0 0       0 if ($ignorecase) {
7231 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7232             }
7233             }
7234             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7235 0         0 $char[$i] = e_capture($1);
7236 0 0       0 if ($ignorecase) {
7237 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7238             }
7239             }
7240              
7241             # $$foo[ ... ] --> $ $foo->[ ... ]
7242             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7243 0         0 $char[$i] = e_capture($1.'->'.$2);
7244 0 0       0 if ($ignorecase) {
7245 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7246             }
7247             }
7248              
7249             # $$foo{ ... } --> $ $foo->{ ... }
7250             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7251 0         0 $char[$i] = e_capture($1.'->'.$2);
7252 0 0       0 if ($ignorecase) {
7253 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7254             }
7255             }
7256              
7257             # $$foo
7258             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7259 0         0 $char[$i] = e_capture($1);
7260 0 0       0 if ($ignorecase) {
7261 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7262             }
7263             }
7264              
7265             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Elatin9::PREMATCH()
7266             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7267 12 50       23 if ($ignorecase) {
7268 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::PREMATCH())]}';
7269             }
7270             else {
7271 12         78 $char[$i] = '@{[Elatin9::PREMATCH()]}';
7272             }
7273             }
7274              
7275             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Elatin9::MATCH()
7276             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7277 12 50       21 if ($ignorecase) {
7278 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::MATCH())]}';
7279             }
7280             else {
7281 12         74 $char[$i] = '@{[Elatin9::MATCH()]}';
7282             }
7283             }
7284              
7285             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Elatin9::POSTMATCH()
7286             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7287 9 50       14 if ($ignorecase) {
7288 0         0 $char[$i] = '@{[Elatin9::ignorecase(Elatin9::POSTMATCH())]}';
7289             }
7290             else {
7291 9         54 $char[$i] = '@{[Elatin9::POSTMATCH()]}';
7292             }
7293             }
7294              
7295             # ${ foo }
7296             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7297 0 0       0 if ($ignorecase) {
7298 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $1 . ')]}';
7299             }
7300             }
7301              
7302             # ${ ... }
7303             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7304 0         0 $char[$i] = e_capture($1);
7305 0 0       0 if ($ignorecase) {
7306 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7307             }
7308             }
7309              
7310             # $scalar or @array
7311             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7312 3         10 $char[$i] = e_string($char[$i]);
7313 3 50       20 if ($ignorecase) {
7314 0         0 $char[$i] = '@{[Elatin9::ignorecase(' . $char[$i] . ')]}';
7315             }
7316             }
7317              
7318             # quote character before ? + * {
7319             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7320 1 50       13 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7321             }
7322             else {
7323 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7324             }
7325             }
7326             }
7327              
7328             # make regexp string
7329 74         115 $modifier =~ tr/i//d;
7330 74 50       159 if ($left_e > $right_e) {
7331 0         0 return join '', 'Elatin9::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7332             }
7333 74         740 return join '', 'Elatin9::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7334             }
7335              
7336             #
7337             # escape regexp of split qr''
7338             #
7339             sub e_split_q {
7340 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7341 0   0       $modifier ||= '';
7342              
7343 0           $modifier =~ tr/p//d;
7344 0 0         if ($modifier =~ /([adlu])/oxms) {
7345 0           my $line = 0;
7346 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7347 0 0         if ($filename ne __FILE__) {
7348 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7349 0           last;
7350             }
7351             }
7352 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7353             }
7354              
7355 0           $slash = 'div';
7356              
7357             # /b /B modifier
7358 0 0         if ($modifier =~ tr/bB//d) {
7359 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7360             }
7361              
7362 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7363              
7364             # split regexp
7365 0           my @char = $string =~ /\G((?>
7366             [^\\\[] |
7367             [\x00-\xFF] |
7368             \[\^ |
7369             \[\: (?>[a-z]+) \:\] |
7370             \[\:\^ (?>[a-z]+) \:\] |
7371             \\ (?:$q_char) |
7372             (?:$q_char)
7373             ))/oxmsg;
7374              
7375             # unescape character
7376 0           for (my $i=0; $i <= $#char; $i++) {
7377 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7378             }
7379              
7380             # open character class [...]
7381 0           elsif ($char[$i] eq '[') {
7382 0           my $left = $i;
7383 0 0         if ($char[$i+1] eq ']') {
7384 0           $i++;
7385             }
7386 0           while (1) {
7387 0 0         if (++$i > $#char) {
7388 0           die __FILE__, ": Unmatched [] in regexp\n";
7389             }
7390 0 0         if ($char[$i] eq ']') {
7391 0           my $right = $i;
7392              
7393             # [...]
7394 0           splice @char, $left, $right-$left+1, Elatin9::charlist_qr(@char[$left+1..$right-1], $modifier);
7395              
7396 0           $i = $left;
7397 0           last;
7398             }
7399             }
7400             }
7401              
7402             # open character class [^...]
7403             elsif ($char[$i] eq '[^') {
7404 0           my $left = $i;
7405 0 0         if ($char[$i+1] eq ']') {
7406 0           $i++;
7407             }
7408 0           while (1) {
7409 0 0         if (++$i > $#char) {
7410 0           die __FILE__, ": Unmatched [] in regexp\n";
7411             }
7412 0 0         if ($char[$i] eq ']') {
7413 0           my $right = $i;
7414              
7415             # [^...]
7416 0           splice @char, $left, $right-$left+1, Elatin9::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7417              
7418 0           $i = $left;
7419 0           last;
7420             }
7421             }
7422             }
7423              
7424             # rewrite character class or escape character
7425             elsif (my $char = character_class($char[$i],$modifier)) {
7426 0           $char[$i] = $char;
7427             }
7428              
7429             # split(m/^/) --> split(m/^/m)
7430             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7431 0           $modifier .= 'm';
7432             }
7433              
7434             # /i modifier
7435             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Elatin9::uc($char[$i]) ne Elatin9::fc($char[$i]))) {
7436 0 0         if (CORE::length(Elatin9::fc($char[$i])) == 1) {
7437 0           $char[$i] = '[' . Elatin9::uc($char[$i]) . Elatin9::fc($char[$i]) . ']';
7438             }
7439             else {
7440 0           $char[$i] = '(?:' . Elatin9::uc($char[$i]) . '|' . Elatin9::fc($char[$i]) . ')';
7441             }
7442             }
7443              
7444             # quote character before ? + * {
7445             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7446 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7447             }
7448             else {
7449 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7450             }
7451             }
7452             }
7453              
7454 0           $modifier =~ tr/i//d;
7455 0           return join '', 'Elatin9::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7456             }
7457              
7458             #
7459             # instead of Carp::carp
7460             #
7461             sub carp {
7462 0     0 0   my($package,$filename,$line) = caller(1);
7463 0           print STDERR "@_ at $filename line $line.\n";
7464             }
7465              
7466             #
7467             # instead of Carp::croak
7468             #
7469             sub croak {
7470 0     0 0   my($package,$filename,$line) = caller(1);
7471 0           print STDERR "@_ at $filename line $line.\n";
7472 0           die "\n";
7473             }
7474              
7475             #
7476             # instead of Carp::cluck
7477             #
7478             sub cluck {
7479 0     0 0   my $i = 0;
7480 0           my @cluck = ();
7481 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7482 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7483 0           $i++;
7484             }
7485 0           print STDERR CORE::reverse @cluck;
7486 0           print STDERR "\n";
7487 0           carp @_;
7488             }
7489              
7490             #
7491             # instead of Carp::confess
7492             #
7493             sub confess {
7494 0     0 0   my $i = 0;
7495 0           my @confess = ();
7496 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7497 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7498 0           $i++;
7499             }
7500 0           print STDERR CORE::reverse @confess;
7501 0           print STDERR "\n";
7502 0           croak @_;
7503             }
7504              
7505             1;
7506              
7507             __END__