File Coverage

blib/lib/Ewindows1258.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 Ewindows1258;
2             ######################################################################
3             #
4             # Ewindows1258 - Run-time routines for Windows1258.pm
5             #
6             # http://search.cpan.org/dist/Char-Windows1258/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3022 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         496  
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   11833 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1176  
  200         280  
  200         25081  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1060 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         267 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         23623 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   12546 CORE::eval q{
  200     200   931  
  200     59   272  
  200         19925  
  43         3216  
  61         4782  
  41         3441  
  55         4768  
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       88507 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   447 my $genpkg = "Symbol::";
67 200         8050 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) && (Ewindows1258::index($name, '::') == -1) && (Ewindows1258::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   326 if (CORE::eval { local $@; CORE::require strict }) {
  200         288  
  200         1746  
115 200         18530 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   12574 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   868  
  200         245  
  200         10036  
145 200     200   10669 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   840  
  200         246  
  200         10453  
146 200     200   14153 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   890  
  200         333  
  200         11823  
147              
148             #
149             # Windows-1258 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   10814 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   863  
  200         257  
  200         266927  
157              
158             #
159             # Windows-1258 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 Ewindows1258 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: windows-?1258 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\x8C" => "\x9C", # LATIN LIGATURE OE
183             "\x9F" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
184             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
185             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
186             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
187             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
188             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
189             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
190             "\xC6" => "\xE6", # LATIN LETTER AE
191             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
192             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
193             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
194             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
195             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
196             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
197             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
198             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
199             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
200             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
201             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
202             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
203             "\xD5" => "\xF5", # LATIN LETTER O WITH HORN
204             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
205             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
206             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
207             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
208             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
209             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
210             "\xDD" => "\xFD", # LATIN LETTER U WITH HORN
211             );
212              
213             %uc = (%uc,
214             "\x9C" => "\x8C", # LATIN LIGATURE OE
215             "\xFF" => "\x9F", # LATIN LETTER Y WITH DIAERESIS
216             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
217             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
218             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
219             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
220             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
221             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
222             "\xE6" => "\xC6", # LATIN LETTER AE
223             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
224             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
225             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
226             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
227             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
228             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
229             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
230             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
231             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
232             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
233             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
234             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
235             "\xF5" => "\xD5", # LATIN LETTER O WITH HORN
236             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
237             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
238             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
239             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
240             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
241             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
242             "\xFD" => "\xDD", # LATIN LETTER U WITH HORN
243             );
244              
245             %fc = (%fc,
246             "\x8C" => "\x9C", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
247             "\x9F" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
248             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
249             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
250             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
251             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
252             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
253             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
254             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
255             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
256             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
257             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
258             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
259             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
260             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
261             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
262             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
263             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
264             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
265             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
266             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
267             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH HORN --> LATIN SMALL LETTER O WITH HORN
268             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
269             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
270             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
271             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
272             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
273             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
274             "\xDD" => "\xFD", # LATIN CAPITAL LETTER U WITH HORN --> LATIN SMALL LETTER U WITH HORN
275             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
276             );
277             }
278              
279             else {
280             croak "Don't know my package name '@{[__PACKAGE__]}'";
281             }
282              
283             #
284             # @ARGV wildcard globbing
285             #
286             sub import {
287              
288 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
289 0         0 my @argv = ();
290 0         0 for (@ARGV) {
291              
292             # has space
293 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
294 0 0       0 if (my @glob = Ewindows1258::glob(qq{"$_"})) {
295 0         0 push @argv, @glob;
296             }
297             else {
298 0         0 push @argv, $_;
299             }
300             }
301              
302             # has wildcard metachar
303             elsif (/\A (?:$q_char)*? [*?] /oxms) {
304 0 0       0 if (my @glob = Ewindows1258::glob($_)) {
305 0         0 push @argv, @glob;
306             }
307             else {
308 0         0 push @argv, $_;
309             }
310             }
311              
312             # no wildcard globbing
313             else {
314 0         0 push @argv, $_;
315             }
316             }
317 0         0 @ARGV = @argv;
318             }
319              
320 0         0 *Char::ord = \&Windows1258::ord;
321 0         0 *Char::ord_ = \&Windows1258::ord_;
322 0         0 *Char::reverse = \&Windows1258::reverse;
323 0         0 *Char::getc = \&Windows1258::getc;
324 0         0 *Char::length = \&Windows1258::length;
325 0         0 *Char::substr = \&Windows1258::substr;
326 0         0 *Char::index = \&Windows1258::index;
327 0         0 *Char::rindex = \&Windows1258::rindex;
328 0         0 *Char::eval = \&Windows1258::eval;
329 0         0 *Char::escape = \&Windows1258::escape;
330 0         0 *Char::escape_token = \&Windows1258::escape_token;
331 0         0 *Char::escape_script = \&Windows1258::escape_script;
332             }
333              
334             # P.230 Care with Prototypes
335             # in Chapter 6: Subroutines
336             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
337             #
338             # If you aren't careful, you can get yourself into trouble with prototypes.
339             # But if you are careful, you can do a lot of neat things with them. This is
340             # all very powerful, of course, and should only be used in moderation to make
341             # the world a better place.
342              
343             # P.332 Care with Prototypes
344             # in Chapter 7: Subroutines
345             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
346             #
347             # If you aren't careful, you can get yourself into trouble with prototypes.
348             # But if you are careful, you can do a lot of neat things with them. This is
349             # all very powerful, of course, and should only be used in moderation to make
350             # the world a better place.
351              
352             #
353             # Prototypes of subroutines
354             #
355       0     sub unimport {}
356             sub Ewindows1258::split(;$$$);
357             sub Ewindows1258::tr($$$$;$);
358             sub Ewindows1258::chop(@);
359             sub Ewindows1258::index($$;$);
360             sub Ewindows1258::rindex($$;$);
361             sub Ewindows1258::lcfirst(@);
362             sub Ewindows1258::lcfirst_();
363             sub Ewindows1258::lc(@);
364             sub Ewindows1258::lc_();
365             sub Ewindows1258::ucfirst(@);
366             sub Ewindows1258::ucfirst_();
367             sub Ewindows1258::uc(@);
368             sub Ewindows1258::uc_();
369             sub Ewindows1258::fc(@);
370             sub Ewindows1258::fc_();
371             sub Ewindows1258::ignorecase;
372             sub Ewindows1258::classic_character_class;
373             sub Ewindows1258::capture;
374             sub Ewindows1258::chr(;$);
375             sub Ewindows1258::chr_();
376             sub Ewindows1258::glob($);
377             sub Ewindows1258::glob_();
378              
379             sub Windows1258::ord(;$);
380             sub Windows1258::ord_();
381             sub Windows1258::reverse(@);
382             sub Windows1258::getc(;*@);
383             sub Windows1258::length(;$);
384             sub Windows1258::substr($$;$$);
385             sub Windows1258::index($$;$);
386             sub Windows1258::rindex($$;$);
387             sub Windows1258::escape(;$);
388              
389             #
390             # Regexp work
391             #
392 200     200   13278 BEGIN { CORE::eval q{ use vars qw(
  200     200   1025  
  200         279  
  200         64445  
393             $Windows1258::re_a
394             $Windows1258::re_t
395             $Windows1258::re_n
396             $Windows1258::re_r
397             ) } }
398              
399             #
400             # Character class
401             #
402 200     200   13269 BEGIN { CORE::eval q{ use vars qw(
  200     200   879  
  200         270  
  200         2153453  
403             $dot
404             $dot_s
405             $eD
406             $eS
407             $eW
408             $eH
409             $eV
410             $eR
411             $eN
412             $not_alnum
413             $not_alpha
414             $not_ascii
415             $not_blank
416             $not_cntrl
417             $not_digit
418             $not_graph
419             $not_lower
420             $not_lower_i
421             $not_print
422             $not_punct
423             $not_space
424             $not_upper
425             $not_upper_i
426             $not_word
427             $not_xdigit
428             $eb
429             $eB
430             ) } }
431              
432             ${Ewindows1258::dot} = qr{(?>[^\x0A])};
433             ${Ewindows1258::dot_s} = qr{(?>[\x00-\xFF])};
434             ${Ewindows1258::eD} = qr{(?>[^0-9])};
435              
436             # Vertical tabs are now whitespace
437             # \s in a regex now matches a vertical tab in all circumstances.
438             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
439             # ${Ewindows1258::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
440             # ${Ewindows1258::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
441             ${Ewindows1258::eS} = qr{(?>[^\s])};
442              
443             ${Ewindows1258::eW} = qr{(?>[^0-9A-Z_a-z])};
444             ${Ewindows1258::eH} = qr{(?>[^\x09\x20])};
445             ${Ewindows1258::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
446             ${Ewindows1258::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
447             ${Ewindows1258::eN} = qr{(?>[^\x0A])};
448             ${Ewindows1258::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
449             ${Ewindows1258::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
450             ${Ewindows1258::not_ascii} = qr{(?>[^\x00-\x7F])};
451             ${Ewindows1258::not_blank} = qr{(?>[^\x09\x20])};
452             ${Ewindows1258::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
453             ${Ewindows1258::not_digit} = qr{(?>[^\x30-\x39])};
454             ${Ewindows1258::not_graph} = qr{(?>[^\x21-\x7F])};
455             ${Ewindows1258::not_lower} = qr{(?>[^\x61-\x7A])};
456             ${Ewindows1258::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
457             # ${Ewindows1258::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
458             ${Ewindows1258::not_print} = qr{(?>[^\x20-\x7F])};
459             ${Ewindows1258::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
460             ${Ewindows1258::not_space} = qr{(?>[^\s\x0B])};
461             ${Ewindows1258::not_upper} = qr{(?>[^\x41-\x5A])};
462             ${Ewindows1258::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
463             # ${Ewindows1258::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
464             ${Ewindows1258::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
465             ${Ewindows1258::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
466             ${Ewindows1258::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))};
467             ${Ewindows1258::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]))};
468              
469             # avoid: Name "Ewindows1258::foo" used only once: possible typo at here.
470             ${Ewindows1258::dot} = ${Ewindows1258::dot};
471             ${Ewindows1258::dot_s} = ${Ewindows1258::dot_s};
472             ${Ewindows1258::eD} = ${Ewindows1258::eD};
473             ${Ewindows1258::eS} = ${Ewindows1258::eS};
474             ${Ewindows1258::eW} = ${Ewindows1258::eW};
475             ${Ewindows1258::eH} = ${Ewindows1258::eH};
476             ${Ewindows1258::eV} = ${Ewindows1258::eV};
477             ${Ewindows1258::eR} = ${Ewindows1258::eR};
478             ${Ewindows1258::eN} = ${Ewindows1258::eN};
479             ${Ewindows1258::not_alnum} = ${Ewindows1258::not_alnum};
480             ${Ewindows1258::not_alpha} = ${Ewindows1258::not_alpha};
481             ${Ewindows1258::not_ascii} = ${Ewindows1258::not_ascii};
482             ${Ewindows1258::not_blank} = ${Ewindows1258::not_blank};
483             ${Ewindows1258::not_cntrl} = ${Ewindows1258::not_cntrl};
484             ${Ewindows1258::not_digit} = ${Ewindows1258::not_digit};
485             ${Ewindows1258::not_graph} = ${Ewindows1258::not_graph};
486             ${Ewindows1258::not_lower} = ${Ewindows1258::not_lower};
487             ${Ewindows1258::not_lower_i} = ${Ewindows1258::not_lower_i};
488             ${Ewindows1258::not_print} = ${Ewindows1258::not_print};
489             ${Ewindows1258::not_punct} = ${Ewindows1258::not_punct};
490             ${Ewindows1258::not_space} = ${Ewindows1258::not_space};
491             ${Ewindows1258::not_upper} = ${Ewindows1258::not_upper};
492             ${Ewindows1258::not_upper_i} = ${Ewindows1258::not_upper_i};
493             ${Ewindows1258::not_word} = ${Ewindows1258::not_word};
494             ${Ewindows1258::not_xdigit} = ${Ewindows1258::not_xdigit};
495             ${Ewindows1258::eb} = ${Ewindows1258::eb};
496             ${Ewindows1258::eB} = ${Ewindows1258::eB};
497              
498             #
499             # Windows-1258 split
500             #
501             sub Ewindows1258::split(;$$$) {
502              
503             # P.794 29.2.161. split
504             # in Chapter 29: Functions
505             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
506              
507             # P.951 split
508             # in Chapter 27: Functions
509             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
510              
511 0     0 0 0 my $pattern = $_[0];
512 0         0 my $string = $_[1];
513 0         0 my $limit = $_[2];
514              
515             # if $pattern is also omitted or is the literal space, " "
516 0 0       0 if (not defined $pattern) {
517 0         0 $pattern = ' ';
518             }
519              
520             # if $string is omitted, the function splits the $_ string
521 0 0       0 if (not defined $string) {
522 0 0       0 if (defined $_) {
523 0         0 $string = $_;
524             }
525             else {
526 0         0 $string = '';
527             }
528             }
529              
530 0         0 my @split = ();
531              
532             # when string is empty
533 0 0       0 if ($string eq '') {
    0          
534              
535             # resulting list value in list context
536 0 0       0 if (wantarray) {
537 0         0 return @split;
538             }
539              
540             # count of substrings in scalar context
541             else {
542 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
543 0         0 @_ = @split;
544 0         0 return scalar @_;
545             }
546             }
547              
548             # split's first argument is more consistently interpreted
549             #
550             # After some changes earlier in v5.17, split's behavior has been simplified:
551             # if the PATTERN argument evaluates to a string containing one space, it is
552             # treated the way that a literal string containing one space once was.
553             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
554              
555             # if $pattern is also omitted or is the literal space, " ", the function splits
556             # on whitespace, /\s+/, after skipping any leading whitespace
557             # (and so on)
558              
559             elsif ($pattern eq ' ') {
560 0 0       0 if (not defined $limit) {
561 0         0 return CORE::split(' ', $string);
562             }
563             else {
564 0         0 return CORE::split(' ', $string, $limit);
565             }
566             }
567              
568             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
569 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
570              
571             # a pattern capable of matching either the null string or something longer than the
572             # null string will split the value of $string into separate characters wherever it
573             # matches the null string between characters
574             # (and so on)
575              
576 0 0       0 if ('' =~ / \A $pattern \z /xms) {
577 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
578 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
579              
580             # P.1024 Appendix W.10 Multibyte Processing
581             # of ISBN 1-56592-224-7 CJKV Information Processing
582             # (and so on)
583              
584             # the //m modifier is assumed when you split on the pattern /^/
585             # (and so on)
586              
587             # V
588 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
589              
590             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
591             # is included in the resulting list, interspersed with the fields that are ordinarily returned
592             # (and so on)
593              
594 0         0 local $@;
595 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
596 0         0 push @split, CORE::eval('$' . $digit);
597             }
598             }
599             }
600              
601             else {
602 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
603              
604             # V
605 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
606 0         0 local $@;
607 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
608 0         0 push @split, CORE::eval('$' . $digit);
609             }
610             }
611             }
612             }
613              
614             elsif ($limit > 0) {
615 0 0       0 if ('' =~ / \A $pattern \z /xms) {
616 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
617 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
618              
619             # V
620 0 0       0 if ($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             else {
629 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
630 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
631              
632             # V
633 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
634 0         0 local $@;
635 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
636 0         0 push @split, CORE::eval('$' . $digit);
637             }
638             }
639             }
640             }
641             }
642              
643 0 0       0 if (CORE::length($string) > 0) {
644 0         0 push @split, $string;
645             }
646              
647             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
648 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
649 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
650 0         0 pop @split;
651             }
652             }
653              
654             # resulting list value in list context
655 0 0       0 if (wantarray) {
656 0         0 return @split;
657             }
658              
659             # count of substrings in scalar context
660             else {
661 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
662 0         0 @_ = @split;
663 0         0 return scalar @_;
664             }
665             }
666              
667             #
668             # get last subexpression offsets
669             #
670             sub _last_subexpression_offsets {
671 0     0   0 my $pattern = $_[0];
672              
673             # remove comment
674 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
675              
676 0         0 my $modifier = '';
677 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
678 0         0 $modifier = $1;
679 0         0 $modifier =~ s/-[A-Za-z]*//;
680             }
681              
682             # with /x modifier
683 0         0 my @char = ();
684 0 0       0 if ($modifier =~ /x/oxms) {
685 0         0 @char = $pattern =~ /\G((?>
686             [^\\\#\[\(] |
687             \\ $q_char |
688             \# (?>[^\n]*) $ |
689             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
690             \(\? |
691             $q_char
692             ))/oxmsg;
693             }
694              
695             # without /x modifier
696             else {
697 0         0 @char = $pattern =~ /\G((?>
698             [^\\\[\(] |
699             \\ $q_char |
700             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
701             \(\? |
702             $q_char
703             ))/oxmsg;
704             }
705              
706 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
707             }
708              
709             #
710             # Windows-1258 transliteration (tr///)
711             #
712             sub Ewindows1258::tr($$$$;$) {
713              
714 0     0 0 0 my $bind_operator = $_[1];
715 0         0 my $searchlist = $_[2];
716 0         0 my $replacementlist = $_[3];
717 0   0     0 my $modifier = $_[4] || '';
718              
719 0 0       0 if ($modifier =~ /r/oxms) {
720 0 0       0 if ($bind_operator =~ / !~ /oxms) {
721 0         0 croak "Using !~ with tr///r doesn't make sense";
722             }
723             }
724              
725 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
726 0         0 my @searchlist = _charlist_tr($searchlist);
727 0         0 my @replacementlist = _charlist_tr($replacementlist);
728              
729 0         0 my %tr = ();
730 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
731 0 0       0 if (not exists $tr{$searchlist[$i]}) {
732 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
733 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
734             }
735             elsif ($modifier =~ /d/oxms) {
736 0         0 $tr{$searchlist[$i]} = '';
737             }
738             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
739 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
740             }
741             else {
742 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
743             }
744             }
745             }
746              
747 0         0 my $tr = 0;
748 0         0 my $replaced = '';
749 0 0       0 if ($modifier =~ /c/oxms) {
750 0         0 while (defined(my $char = shift @char)) {
751 0 0       0 if (not exists $tr{$char}) {
752 0 0       0 if (defined $replacementlist[0]) {
753 0         0 $replaced .= $replacementlist[0];
754             }
755 0         0 $tr++;
756 0 0       0 if ($modifier =~ /s/oxms) {
757 0   0     0 while (@char and (not exists $tr{$char[0]})) {
758 0         0 shift @char;
759 0         0 $tr++;
760             }
761             }
762             }
763             else {
764 0         0 $replaced .= $char;
765             }
766             }
767             }
768             else {
769 0         0 while (defined(my $char = shift @char)) {
770 0 0       0 if (exists $tr{$char}) {
771 0         0 $replaced .= $tr{$char};
772 0         0 $tr++;
773 0 0       0 if ($modifier =~ /s/oxms) {
774 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
775 0         0 shift @char;
776 0         0 $tr++;
777             }
778             }
779             }
780             else {
781 0         0 $replaced .= $char;
782             }
783             }
784             }
785              
786 0 0       0 if ($modifier =~ /r/oxms) {
787 0         0 return $replaced;
788             }
789             else {
790 0         0 $_[0] = $replaced;
791 0 0       0 if ($bind_operator =~ / !~ /oxms) {
792 0         0 return not $tr;
793             }
794             else {
795 0         0 return $tr;
796             }
797             }
798             }
799              
800             #
801             # Windows-1258 chop
802             #
803             sub Ewindows1258::chop(@) {
804              
805 0     0 0 0 my $chop;
806 0 0       0 if (@_ == 0) {
807 0         0 my @char = /\G (?>$q_char) /oxmsg;
808 0         0 $chop = pop @char;
809 0         0 $_ = join '', @char;
810             }
811             else {
812 0         0 for (@_) {
813 0         0 my @char = /\G (?>$q_char) /oxmsg;
814 0         0 $chop = pop @char;
815 0         0 $_ = join '', @char;
816             }
817             }
818 0         0 return $chop;
819             }
820              
821             #
822             # Windows-1258 index by octet
823             #
824             sub Ewindows1258::index($$;$) {
825              
826 0     0 1 0 my($str,$substr,$position) = @_;
827 0   0     0 $position ||= 0;
828 0         0 my $pos = 0;
829              
830 0         0 while ($pos < CORE::length($str)) {
831 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
832 0 0       0 if ($pos >= $position) {
833 0         0 return $pos;
834             }
835             }
836 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
837 0         0 $pos += CORE::length($1);
838             }
839             else {
840 0         0 $pos += 1;
841             }
842             }
843 0         0 return -1;
844             }
845              
846             #
847             # Windows-1258 reverse index
848             #
849             sub Ewindows1258::rindex($$;$) {
850              
851 0     0 0 0 my($str,$substr,$position) = @_;
852 0   0     0 $position ||= CORE::length($str) - 1;
853 0         0 my $pos = 0;
854 0         0 my $rindex = -1;
855              
856 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
857 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
858 0         0 $rindex = $pos;
859             }
860 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
861 0         0 $pos += CORE::length($1);
862             }
863             else {
864 0         0 $pos += 1;
865             }
866             }
867 0         0 return $rindex;
868             }
869              
870             #
871             # Windows-1258 lower case first with parameter
872             #
873             sub Ewindows1258::lcfirst(@) {
874 0 0   0 0 0 if (@_) {
875 0         0 my $s = shift @_;
876 0 0 0     0 if (@_ and wantarray) {
877 0         0 return Ewindows1258::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
878             }
879             else {
880 0         0 return Ewindows1258::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
881             }
882             }
883             else {
884 0         0 return Ewindows1258::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
885             }
886             }
887              
888             #
889             # Windows-1258 lower case first without parameter
890             #
891             sub Ewindows1258::lcfirst_() {
892 0     0 0 0 return Ewindows1258::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
893             }
894              
895             #
896             # Windows-1258 lower case with parameter
897             #
898             sub Ewindows1258::lc(@) {
899 0 0   0 0 0 if (@_) {
900 0         0 my $s = shift @_;
901 0 0 0     0 if (@_ and wantarray) {
902 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
903             }
904             else {
905 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
906             }
907             }
908             else {
909 0         0 return Ewindows1258::lc_();
910             }
911             }
912              
913             #
914             # Windows-1258 lower case without parameter
915             #
916             sub Ewindows1258::lc_() {
917 0     0 0 0 my $s = $_;
918 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
919             }
920              
921             #
922             # Windows-1258 upper case first with parameter
923             #
924             sub Ewindows1258::ucfirst(@) {
925 0 0   0 0 0 if (@_) {
926 0         0 my $s = shift @_;
927 0 0 0     0 if (@_ and wantarray) {
928 0         0 return Ewindows1258::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
929             }
930             else {
931 0         0 return Ewindows1258::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
932             }
933             }
934             else {
935 0         0 return Ewindows1258::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
936             }
937             }
938              
939             #
940             # Windows-1258 upper case first without parameter
941             #
942             sub Ewindows1258::ucfirst_() {
943 0     0 0 0 return Ewindows1258::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
944             }
945              
946             #
947             # Windows-1258 upper case with parameter
948             #
949             sub Ewindows1258::uc(@) {
950 174 50   174 0 218 if (@_) {
951 174         161 my $s = shift @_;
952 174 50 33     297 if (@_ and wantarray) {
953 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
954             }
955             else {
956 174 100       481 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  174         532  
957             }
958             }
959             else {
960 0         0 return Ewindows1258::uc_();
961             }
962             }
963              
964             #
965             # Windows-1258 upper case without parameter
966             #
967             sub Ewindows1258::uc_() {
968 0     0 0 0 my $s = $_;
969 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
970             }
971              
972             #
973             # Windows-1258 fold case with parameter
974             #
975             sub Ewindows1258::fc(@) {
976 197 50   197 0 219 if (@_) {
977 197         145 my $s = shift @_;
978 197 50 33     340 if (@_ and wantarray) {
979 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
980             }
981             else {
982 197 100       404 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  197         1030  
983             }
984             }
985             else {
986 0         0 return Ewindows1258::fc_();
987             }
988             }
989              
990             #
991             # Windows-1258 fold case without parameter
992             #
993             sub Ewindows1258::fc_() {
994 0     0 0 0 my $s = $_;
995 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
996             }
997              
998             #
999             # Windows-1258 regexp capture
1000             #
1001             {
1002             sub Ewindows1258::capture {
1003 0     0 1 0 return $_[0];
1004             }
1005             }
1006              
1007             #
1008             # Windows-1258 regexp ignore case modifier
1009             #
1010             sub Ewindows1258::ignorecase {
1011              
1012 0     0 0 0 my @string = @_;
1013 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1014              
1015             # ignore case of $scalar or @array
1016 0         0 for my $string (@string) {
1017              
1018             # split regexp
1019 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1020              
1021             # unescape character
1022 0         0 for (my $i=0; $i <= $#char; $i++) {
1023 0 0       0 next if not defined $char[$i];
1024              
1025             # open character class [...]
1026 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1027 0         0 my $left = $i;
1028              
1029             # [] make die "unmatched [] in regexp ...\n"
1030              
1031 0 0       0 if ($char[$i+1] eq ']') {
1032 0         0 $i++;
1033             }
1034              
1035 0         0 while (1) {
1036 0 0       0 if (++$i > $#char) {
1037 0         0 croak "Unmatched [] in regexp";
1038             }
1039 0 0       0 if ($char[$i] eq ']') {
1040 0         0 my $right = $i;
1041 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1042              
1043             # escape character
1044 0         0 for my $char (@charlist) {
1045 0 0       0 if (0) {
1046             }
1047              
1048 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1049 0         0 $char = '\\' . $char;
1050             }
1051             }
1052              
1053             # [...]
1054 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1055              
1056 0         0 $i = $left;
1057 0         0 last;
1058             }
1059             }
1060             }
1061              
1062             # open character class [^...]
1063             elsif ($char[$i] eq '[^') {
1064 0         0 my $left = $i;
1065              
1066             # [^] make die "unmatched [] in regexp ...\n"
1067              
1068 0 0       0 if ($char[$i+1] eq ']') {
1069 0         0 $i++;
1070             }
1071              
1072 0         0 while (1) {
1073 0 0       0 if (++$i > $#char) {
1074 0         0 croak "Unmatched [] in regexp";
1075             }
1076 0 0       0 if ($char[$i] eq ']') {
1077 0         0 my $right = $i;
1078 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1079              
1080             # escape character
1081 0         0 for my $char (@charlist) {
1082 0 0       0 if (0) {
1083             }
1084              
1085 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1086 0         0 $char = '\\' . $char;
1087             }
1088             }
1089              
1090             # [^...]
1091 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1092              
1093 0         0 $i = $left;
1094 0         0 last;
1095             }
1096             }
1097             }
1098              
1099             # rewrite classic character class or escape character
1100             elsif (my $char = classic_character_class($char[$i])) {
1101 0         0 $char[$i] = $char;
1102             }
1103              
1104             # with /i modifier
1105             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1106 0         0 my $uc = Ewindows1258::uc($char[$i]);
1107 0         0 my $fc = Ewindows1258::fc($char[$i]);
1108 0 0       0 if ($uc ne $fc) {
1109 0 0       0 if (CORE::length($fc) == 1) {
1110 0         0 $char[$i] = '[' . $uc . $fc . ']';
1111             }
1112             else {
1113 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1114             }
1115             }
1116             }
1117             }
1118              
1119             # characterize
1120 0         0 for (my $i=0; $i <= $#char; $i++) {
1121 0 0       0 next if not defined $char[$i];
1122              
1123 0 0       0 if (0) {
1124             }
1125              
1126             # quote character before ? + * {
1127 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1128 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1129 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1130             }
1131             }
1132             }
1133              
1134 0         0 $string = join '', @char;
1135             }
1136              
1137             # make regexp string
1138 0         0 return @string;
1139             }
1140              
1141             #
1142             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1143             #
1144             sub Ewindows1258::classic_character_class {
1145 1862     1862 0 1589 my($char) = @_;
1146              
1147             return {
1148             '\D' => '${Ewindows1258::eD}',
1149             '\S' => '${Ewindows1258::eS}',
1150             '\W' => '${Ewindows1258::eW}',
1151             '\d' => '[0-9]',
1152              
1153             # Before Perl 5.6, \s only matched the five whitespace characters
1154             # tab, newline, form-feed, carriage return, and the space character
1155             # itself, which, taken together, is the character class [\t\n\f\r ].
1156              
1157             # Vertical tabs are now whitespace
1158             # \s in a regex now matches a vertical tab in all circumstances.
1159             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1160             # \t \n \v \f \r space
1161             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1162             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1163             '\s' => '\s',
1164              
1165             '\w' => '[0-9A-Z_a-z]',
1166             '\C' => '[\x00-\xFF]',
1167             '\X' => 'X',
1168              
1169             # \h \v \H \V
1170              
1171             # P.114 Character Class Shortcuts
1172             # in Chapter 7: In the World of Regular Expressions
1173             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1174              
1175             # P.357 13.2.3 Whitespace
1176             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1177             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1178             #
1179             # 0x00009 CHARACTER TABULATION h s
1180             # 0x0000a LINE FEED (LF) vs
1181             # 0x0000b LINE TABULATION v
1182             # 0x0000c FORM FEED (FF) vs
1183             # 0x0000d CARRIAGE RETURN (CR) vs
1184             # 0x00020 SPACE h s
1185              
1186             # P.196 Table 5-9. Alphanumeric regex metasymbols
1187             # in Chapter 5. Pattern Matching
1188             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1189              
1190             # (and so on)
1191              
1192             '\H' => '${Ewindows1258::eH}',
1193             '\V' => '${Ewindows1258::eV}',
1194             '\h' => '[\x09\x20]',
1195             '\v' => '[\x0A\x0B\x0C\x0D]',
1196             '\R' => '${Ewindows1258::eR}',
1197              
1198             # \N
1199             #
1200             # http://perldoc.perl.org/perlre.html
1201             # Character Classes and other Special Escapes
1202             # Any character but \n (experimental). Not affected by /s modifier
1203              
1204             '\N' => '${Ewindows1258::eN}',
1205              
1206             # \b \B
1207              
1208             # P.180 Boundaries: The \b and \B Assertions
1209             # in Chapter 5: Pattern Matching
1210             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1211              
1212             # P.219 Boundaries: The \b and \B Assertions
1213             # in Chapter 5: Pattern Matching
1214             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1215              
1216             # \b really means (?:(?<=\w)(?!\w)|(?
1217             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1218             '\b' => '${Ewindows1258::eb}',
1219              
1220             # \B really means (?:(?<=\w)(?=\w)|(?
1221             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1222             '\B' => '${Ewindows1258::eB}',
1223              
1224 1862   100     72868 }->{$char} || '';
1225             }
1226              
1227             #
1228             # prepare Windows-1258 characters per length
1229             #
1230              
1231             # 1 octet characters
1232             my @chars1 = ();
1233             sub chars1 {
1234 0 0   0 0 0 if (@chars1) {
1235 0         0 return @chars1;
1236             }
1237 0 0       0 if (exists $range_tr{1}) {
1238 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1239 0         0 while (my @range = splice(@ranges,0,1)) {
1240 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1241 0         0 push @chars1, pack 'C', $oct0;
1242             }
1243             }
1244             }
1245 0         0 return @chars1;
1246             }
1247              
1248             # 2 octets characters
1249             my @chars2 = ();
1250             sub chars2 {
1251 0 0   0 0 0 if (@chars2) {
1252 0         0 return @chars2;
1253             }
1254 0 0       0 if (exists $range_tr{2}) {
1255 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1256 0         0 while (my @range = splice(@ranges,0,2)) {
1257 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1258 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1259 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1260             }
1261             }
1262             }
1263             }
1264 0         0 return @chars2;
1265             }
1266              
1267             # 3 octets characters
1268             my @chars3 = ();
1269             sub chars3 {
1270 0 0   0 0 0 if (@chars3) {
1271 0         0 return @chars3;
1272             }
1273 0 0       0 if (exists $range_tr{3}) {
1274 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1275 0         0 while (my @range = splice(@ranges,0,3)) {
1276 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1277 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1278 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1279 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1280             }
1281             }
1282             }
1283             }
1284             }
1285 0         0 return @chars3;
1286             }
1287              
1288             # 4 octets characters
1289             my @chars4 = ();
1290             sub chars4 {
1291 0 0   0 0 0 if (@chars4) {
1292 0         0 return @chars4;
1293             }
1294 0 0       0 if (exists $range_tr{4}) {
1295 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1296 0         0 while (my @range = splice(@ranges,0,4)) {
1297 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1298 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1299 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1300 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1301 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1302             }
1303             }
1304             }
1305             }
1306             }
1307             }
1308 0         0 return @chars4;
1309             }
1310              
1311             #
1312             # Windows-1258 open character list for tr
1313             #
1314             sub _charlist_tr {
1315              
1316 0     0   0 local $_ = shift @_;
1317              
1318             # unescape character
1319 0         0 my @char = ();
1320 0         0 while (not /\G \z/oxmsgc) {
1321 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1322 0         0 push @char, '\-';
1323             }
1324             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1325 0         0 push @char, CORE::chr(oct $1);
1326             }
1327             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1328 0         0 push @char, CORE::chr(hex $1);
1329             }
1330             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1331 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1332             }
1333             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1334             push @char, {
1335             '\0' => "\0",
1336             '\n' => "\n",
1337             '\r' => "\r",
1338             '\t' => "\t",
1339             '\f' => "\f",
1340             '\b' => "\x08", # \b means backspace in character class
1341             '\a' => "\a",
1342             '\e' => "\e",
1343 0         0 }->{$1};
1344             }
1345             elsif (/\G \\ ($q_char) /oxmsgc) {
1346 0         0 push @char, $1;
1347             }
1348             elsif (/\G ($q_char) /oxmsgc) {
1349 0         0 push @char, $1;
1350             }
1351             }
1352              
1353             # join separated multiple-octet
1354 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1355              
1356             # unescape '-'
1357 0         0 my @i = ();
1358 0         0 for my $i (0 .. $#char) {
1359 0 0       0 if ($char[$i] eq '\-') {
    0          
1360 0         0 $char[$i] = '-';
1361             }
1362             elsif ($char[$i] eq '-') {
1363 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1364 0         0 push @i, $i;
1365             }
1366             }
1367             }
1368              
1369             # open character list (reverse for splice)
1370 0         0 for my $i (CORE::reverse @i) {
1371 0         0 my @range = ();
1372              
1373             # range error
1374 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1375 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1376             }
1377              
1378             # range of multiple-octet code
1379 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1380 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1381 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1382             }
1383             elsif (CORE::length($char[$i+1]) == 2) {
1384 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1385 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1386             }
1387             elsif (CORE::length($char[$i+1]) == 3) {
1388 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1389 0         0 push @range, chars2();
1390 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1391             }
1392             elsif (CORE::length($char[$i+1]) == 4) {
1393 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1394 0         0 push @range, chars2();
1395 0         0 push @range, chars3();
1396 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1397             }
1398             else {
1399 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1400             }
1401             }
1402             elsif (CORE::length($char[$i-1]) == 2) {
1403 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1404 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1405             }
1406             elsif (CORE::length($char[$i+1]) == 3) {
1407 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1408 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1409             }
1410             elsif (CORE::length($char[$i+1]) == 4) {
1411 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1412 0         0 push @range, chars3();
1413 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1414             }
1415             else {
1416 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1417             }
1418             }
1419             elsif (CORE::length($char[$i-1]) == 3) {
1420 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1421 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1422             }
1423             elsif (CORE::length($char[$i+1]) == 4) {
1424 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1426             }
1427             else {
1428 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1429             }
1430             }
1431             elsif (CORE::length($char[$i-1]) == 4) {
1432 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1433 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1434             }
1435             else {
1436 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1437             }
1438             }
1439             else {
1440 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1441             }
1442              
1443 0         0 splice @char, $i-1, 3, @range;
1444             }
1445              
1446 0         0 return @char;
1447             }
1448              
1449             #
1450             # Windows-1258 open character class
1451             #
1452             sub _cc {
1453 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1454 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1455             }
1456             elsif (scalar(@_) == 1) {
1457 0         0 return sprintf('\x%02X',$_[0]);
1458             }
1459             elsif (scalar(@_) == 2) {
1460 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1461 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1462             }
1463             elsif ($_[0] == $_[1]) {
1464 0         0 return sprintf('\x%02X',$_[0]);
1465             }
1466             elsif (($_[0]+1) == $_[1]) {
1467 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1468             }
1469             else {
1470 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1471             }
1472             }
1473             else {
1474 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1475             }
1476             }
1477              
1478             #
1479             # Windows-1258 octet range
1480             #
1481             sub _octets {
1482 182     182   264 my $length = shift @_;
1483              
1484 182 50       324 if ($length == 1) {
1485 182         503 my($a1) = unpack 'C', $_[0];
1486 182         276 my($z1) = unpack 'C', $_[1];
1487              
1488 182 50       362 if ($a1 > $z1) {
1489 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1490             }
1491              
1492 182 50       456 if ($a1 == $z1) {
    50          
1493 0         0 return sprintf('\x%02X',$a1);
1494             }
1495             elsif (($a1+1) == $z1) {
1496 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1497             }
1498             else {
1499 182         1258 return sprintf('\x%02X-\x%02X',$a1,$z1);
1500             }
1501             }
1502             else {
1503 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1504             }
1505             }
1506              
1507             #
1508             # Windows-1258 range regexp
1509             #
1510             sub _range_regexp {
1511 182     182   266 my($length,$first,$last) = @_;
1512              
1513 182         210 my @range_regexp = ();
1514 182 50       466 if (not exists $range_tr{$length}) {
1515 0         0 return @range_regexp;
1516             }
1517              
1518 182         179 my @ranges = @{ $range_tr{$length} };
  182         414  
1519 182         589 while (my @range = splice(@ranges,0,$length)) {
1520 182         197 my $min = '';
1521 182         157 my $max = '';
1522 182         432 for (my $i=0; $i < $length; $i++) {
1523 182         713 $min .= pack 'C', $range[$i][0];
1524 182         454 $max .= pack 'C', $range[$i][-1];
1525             }
1526              
1527             # min___max
1528             # FIRST_____________LAST
1529             # (nothing)
1530              
1531 182 50 33     2188 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1532             }
1533              
1534             # **********
1535             # min_________max
1536             # FIRST_____________LAST
1537             # **********
1538              
1539             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1540 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1541             }
1542              
1543             # **********************
1544             # min________________max
1545             # FIRST_____________LAST
1546             # **********************
1547              
1548             elsif (($min eq $first) and ($max eq $last)) {
1549 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1550             }
1551              
1552             # *********
1553             # min___max
1554             # FIRST_____________LAST
1555             # *********
1556              
1557             elsif (($first le $min) and ($max le $last)) {
1558 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1559             }
1560              
1561             # **********************
1562             # min__________________________max
1563             # FIRST_____________LAST
1564             # **********************
1565              
1566             elsif (($min le $first) and ($last le $max)) {
1567 182         388 push @range_regexp, _octets($length,$first,$last,$min,$max);
1568             }
1569              
1570             # *********
1571             # min________max
1572             # FIRST_____________LAST
1573             # *********
1574              
1575             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1576 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1577             }
1578              
1579             # min___max
1580             # FIRST_____________LAST
1581             # (nothing)
1582              
1583             elsif ($last lt $min) {
1584             }
1585              
1586             else {
1587 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1588             }
1589             }
1590              
1591 182         358 return @range_regexp;
1592             }
1593              
1594             #
1595             # Windows-1258 open character list for qr and not qr
1596             #
1597             sub _charlist {
1598              
1599 358     358   440 my $modifier = pop @_;
1600 358         627 my @char = @_;
1601              
1602 358 100       739 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1603              
1604             # unescape character
1605 358         1050 for (my $i=0; $i <= $#char; $i++) {
1606              
1607             # escape - to ...
1608 1125 100 100     9616 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1609 206 100 100     983 if ((0 < $i) and ($i < $#char)) {
1610 182         397 $char[$i] = '...';
1611             }
1612             }
1613              
1614             # octal escape sequence
1615             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1616 0         0 $char[$i] = octchr($1);
1617             }
1618              
1619             # hexadecimal escape sequence
1620             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1621 0         0 $char[$i] = hexchr($1);
1622             }
1623              
1624             # \b{...} --> b\{...}
1625             # \B{...} --> B\{...}
1626             # \N{CHARNAME} --> N\{CHARNAME}
1627             # \p{PROPERTY} --> p\{PROPERTY}
1628             # \P{PROPERTY} --> P\{PROPERTY}
1629             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1630 0         0 $char[$i] = $1 . '\\' . $2;
1631             }
1632              
1633             # \p, \P, \X --> p, P, X
1634             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1635 0         0 $char[$i] = $1;
1636             }
1637              
1638             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1639 0         0 $char[$i] = CORE::chr oct $1;
1640             }
1641             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1642 22         89 $char[$i] = CORE::chr hex $1;
1643             }
1644             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1645 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1646             }
1647             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1648             $char[$i] = {
1649             '\0' => "\0",
1650             '\n' => "\n",
1651             '\r' => "\r",
1652             '\t' => "\t",
1653             '\f' => "\f",
1654             '\b' => "\x08", # \b means backspace in character class
1655             '\a' => "\a",
1656             '\e' => "\e",
1657             '\d' => '[0-9]',
1658              
1659             # Vertical tabs are now whitespace
1660             # \s in a regex now matches a vertical tab in all circumstances.
1661             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1662             # \t \n \v \f \r space
1663             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1664             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1665             '\s' => '\s',
1666              
1667             '\w' => '[0-9A-Z_a-z]',
1668             '\D' => '${Ewindows1258::eD}',
1669             '\S' => '${Ewindows1258::eS}',
1670             '\W' => '${Ewindows1258::eW}',
1671              
1672             '\H' => '${Ewindows1258::eH}',
1673             '\V' => '${Ewindows1258::eV}',
1674             '\h' => '[\x09\x20]',
1675             '\v' => '[\x0A\x0B\x0C\x0D]',
1676             '\R' => '${Ewindows1258::eR}',
1677              
1678 25         398 }->{$1};
1679             }
1680              
1681             # POSIX-style character classes
1682             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1683             $char[$i] = {
1684              
1685             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1686             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1687             '[:^lower:]' => '${Ewindows1258::not_lower_i}',
1688             '[:^upper:]' => '${Ewindows1258::not_upper_i}',
1689              
1690 8         71 }->{$1};
1691             }
1692             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1693             $char[$i] = {
1694              
1695             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1696             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1697             '[:ascii:]' => '[\x00-\x7F]',
1698             '[:blank:]' => '[\x09\x20]',
1699             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1700             '[:digit:]' => '[\x30-\x39]',
1701             '[:graph:]' => '[\x21-\x7F]',
1702             '[:lower:]' => '[\x61-\x7A]',
1703             '[:print:]' => '[\x20-\x7F]',
1704             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1705              
1706             # P.174 POSIX-Style Character Classes
1707             # in Chapter 5: Pattern Matching
1708             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1709              
1710             # P.311 11.2.4 Character Classes and other Special Escapes
1711             # in Chapter 11: perlre: Perl regular expressions
1712             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1713              
1714             # P.210 POSIX-Style Character Classes
1715             # in Chapter 5: Pattern Matching
1716             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1717              
1718             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1719              
1720             '[:upper:]' => '[\x41-\x5A]',
1721             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1722             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1723             '[:^alnum:]' => '${Ewindows1258::not_alnum}',
1724             '[:^alpha:]' => '${Ewindows1258::not_alpha}',
1725             '[:^ascii:]' => '${Ewindows1258::not_ascii}',
1726             '[:^blank:]' => '${Ewindows1258::not_blank}',
1727             '[:^cntrl:]' => '${Ewindows1258::not_cntrl}',
1728             '[:^digit:]' => '${Ewindows1258::not_digit}',
1729             '[:^graph:]' => '${Ewindows1258::not_graph}',
1730             '[:^lower:]' => '${Ewindows1258::not_lower}',
1731             '[:^print:]' => '${Ewindows1258::not_print}',
1732             '[:^punct:]' => '${Ewindows1258::not_punct}',
1733             '[:^space:]' => '${Ewindows1258::not_space}',
1734             '[:^upper:]' => '${Ewindows1258::not_upper}',
1735             '[:^word:]' => '${Ewindows1258::not_word}',
1736             '[:^xdigit:]' => '${Ewindows1258::not_xdigit}',
1737              
1738 70         1634 }->{$1};
1739             }
1740             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1741 7         34 $char[$i] = $1;
1742             }
1743             }
1744              
1745             # open character list
1746 358         540 my @singleoctet = ();
1747 358         412 my @multipleoctet = ();
1748 358         840 for (my $i=0; $i <= $#char; ) {
1749              
1750             # escaped -
1751 943 100 100     4353 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1752 182         196 $i += 1;
1753 182         342 next;
1754             }
1755              
1756             # make range regexp
1757             elsif ($char[$i] eq '...') {
1758              
1759             # range error
1760 182 50       729 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1761 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1762             }
1763             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1764 182 50       441 if ($char[$i-1] gt $char[$i+1]) {
1765 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]);
1766             }
1767             }
1768              
1769             # make range regexp per length
1770 182         546 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1771 182         234 my @regexp = ();
1772              
1773             # is first and last
1774 182 50 33     859 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1775 182         524 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1776             }
1777              
1778             # is first
1779             elsif ($length == CORE::length($char[$i-1])) {
1780 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1781             }
1782              
1783             # is inside in first and last
1784             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1785 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1786             }
1787              
1788             # is last
1789             elsif ($length == CORE::length($char[$i+1])) {
1790 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1791             }
1792              
1793             else {
1794 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1795             }
1796              
1797 182 50       393 if ($length == 1) {
1798 182         363 push @singleoctet, @regexp;
1799             }
1800             else {
1801 0         0 push @multipleoctet, @regexp;
1802             }
1803             }
1804              
1805 182         376 $i += 2;
1806             }
1807              
1808             # with /i modifier
1809             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1810 493 100       604 if ($modifier =~ /i/oxms) {
1811 24         48 my $uc = Ewindows1258::uc($char[$i]);
1812 24         46 my $fc = Ewindows1258::fc($char[$i]);
1813 24 100       44 if ($uc ne $fc) {
1814 12 50       30 if (CORE::length($fc) == 1) {
1815 12         20 push @singleoctet, $uc, $fc;
1816             }
1817             else {
1818 0         0 push @singleoctet, $uc;
1819 0         0 push @multipleoctet, $fc;
1820             }
1821             }
1822             else {
1823 12         19 push @singleoctet, $char[$i];
1824             }
1825             }
1826             else {
1827 469         521 push @singleoctet, $char[$i];
1828             }
1829 493         721 $i += 1;
1830             }
1831              
1832             # single character of single octet code
1833             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1834 0         0 push @singleoctet, "\t", "\x20";
1835 0         0 $i += 1;
1836             }
1837             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1838 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1839 0         0 $i += 1;
1840             }
1841             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1842 2         4 push @singleoctet, $char[$i];
1843 2         4 $i += 1;
1844             }
1845              
1846             # single character of multiple-octet code
1847             else {
1848 84         137 push @multipleoctet, $char[$i];
1849 84         163 $i += 1;
1850             }
1851             }
1852              
1853             # quote metachar
1854 358         684 for (@singleoctet) {
1855 689 50       3163 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1856 0         0 $_ = '-';
1857             }
1858             elsif (/\A \n \z/oxms) {
1859 8         15 $_ = '\n';
1860             }
1861             elsif (/\A \r \z/oxms) {
1862 8         17 $_ = '\r';
1863             }
1864             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1865 60         168 $_ = sprintf('\x%02X', CORE::ord $1);
1866             }
1867             elsif (/\A [\x00-\xFF] \z/oxms) {
1868 429         491 $_ = quotemeta $_;
1869             }
1870             }
1871              
1872             # return character list
1873 358         970 return \@singleoctet, \@multipleoctet;
1874             }
1875              
1876             #
1877             # Windows-1258 octal escape sequence
1878             #
1879             sub octchr {
1880 5     5 0 13 my($octdigit) = @_;
1881              
1882 5         8 my @binary = ();
1883 5         20 for my $octal (split(//,$octdigit)) {
1884             push @binary, {
1885             '0' => '000',
1886             '1' => '001',
1887             '2' => '010',
1888             '3' => '011',
1889             '4' => '100',
1890             '5' => '101',
1891             '6' => '110',
1892             '7' => '111',
1893 50         220 }->{$octal};
1894             }
1895 5         17 my $binary = join '', @binary;
1896              
1897             my $octchr = {
1898             # 1234567
1899             1 => pack('B*', "0000000$binary"),
1900             2 => pack('B*', "000000$binary"),
1901             3 => pack('B*', "00000$binary"),
1902             4 => pack('B*', "0000$binary"),
1903             5 => pack('B*', "000$binary"),
1904             6 => pack('B*', "00$binary"),
1905             7 => pack('B*', "0$binary"),
1906             0 => pack('B*', "$binary"),
1907              
1908 5         85 }->{CORE::length($binary) % 8};
1909              
1910 5         21 return $octchr;
1911             }
1912              
1913             #
1914             # Windows-1258 hexadecimal escape sequence
1915             #
1916             sub hexchr {
1917 5     5 0 10 my($hexdigit) = @_;
1918              
1919             my $hexchr = {
1920             1 => pack('H*', "0$hexdigit"),
1921             0 => pack('H*', "$hexdigit"),
1922              
1923 5         38 }->{CORE::length($_[0]) % 2};
1924              
1925 5         15 return $hexchr;
1926             }
1927              
1928             #
1929             # Windows-1258 open character list for qr
1930             #
1931             sub charlist_qr {
1932              
1933 314     314 0 510 my $modifier = pop @_;
1934 314         701 my @char = @_;
1935              
1936 314         821 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1937 314         596 my @singleoctet = @$singleoctet;
1938 314         422 my @multipleoctet = @$multipleoctet;
1939              
1940             # return character list
1941 314 100       727 if (scalar(@singleoctet) >= 1) {
1942              
1943             # with /i modifier
1944 236 100       462 if ($modifier =~ m/i/oxms) {
1945 22         34 my %singleoctet_ignorecase = ();
1946 22         30 for (@singleoctet) {
1947 46   100     217 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1948 46         128 for my $ord (hex($1) .. hex($2)) {
1949 66         68 my $char = CORE::chr($ord);
1950 66         80 my $uc = Ewindows1258::uc($char);
1951 66         84 my $fc = Ewindows1258::fc($char);
1952 66 100       89 if ($uc eq $fc) {
1953 12         107 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1954             }
1955             else {
1956 54 50       68 if (CORE::length($fc) == 1) {
1957 54         95 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1958 54         190 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1959             }
1960             else {
1961 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1962 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1963             }
1964             }
1965             }
1966             }
1967 46 50       82 if ($_ ne '') {
1968 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1969             }
1970             }
1971 22         22 my $i = 0;
1972 22         30 my @singleoctet_ignorecase = ();
1973 22         31 for my $ord (0 .. 255) {
1974 5632 100       4920 if (exists $singleoctet_ignorecase{$ord}) {
1975 96         61 push @{$singleoctet_ignorecase[$i]}, $ord;
  96         160  
1976             }
1977             else {
1978 5536         3595 $i++;
1979             }
1980             }
1981 22         38 @singleoctet = ();
1982 22         51 for my $range (@singleoctet_ignorecase) {
1983 3648 100       5014 if (ref $range) {
1984 56 100       29 if (scalar(@{$range}) == 1) {
  56 50       82  
1985 36         30 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  36         126  
1986             }
1987 20         21 elsif (scalar(@{$range}) == 2) {
1988 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1989             }
1990             else {
1991 20         17 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         17  
  20         66  
1992             }
1993             }
1994             }
1995             }
1996              
1997 236         290 my $not_anchor = '';
1998              
1999 236         591 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2000             }
2001 314 100       574 if (scalar(@multipleoctet) >= 2) {
2002 6         28 return '(?:' . join('|', @multipleoctet) . ')';
2003             }
2004             else {
2005 308         1302 return $multipleoctet[0];
2006             }
2007             }
2008              
2009             #
2010             # Windows-1258 open character list for not qr
2011             #
2012             sub charlist_not_qr {
2013              
2014 44     44 0 85 my $modifier = pop @_;
2015 44         86 my @char = @_;
2016              
2017 44         96 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2018 44         86 my @singleoctet = @$singleoctet;
2019 44         52 my @multipleoctet = @$multipleoctet;
2020              
2021             # with /i modifier
2022 44 100       99 if ($modifier =~ m/i/oxms) {
2023 10         14 my %singleoctet_ignorecase = ();
2024 10         11 for (@singleoctet) {
2025 10   66     45 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2026 10         33 for my $ord (hex($1) .. hex($2)) {
2027 30         33 my $char = CORE::chr($ord);
2028 30         34 my $uc = Ewindows1258::uc($char);
2029 30         41 my $fc = Ewindows1258::fc($char);
2030 30 50       40 if ($uc eq $fc) {
2031 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2032             }
2033             else {
2034 30 50       30 if (CORE::length($fc) == 1) {
2035 30         59 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2036 30         89 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2037             }
2038             else {
2039 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2040 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2041             }
2042             }
2043             }
2044             }
2045 10 50       21 if ($_ ne '') {
2046 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2047             }
2048             }
2049 10         8 my $i = 0;
2050 10         9 my @singleoctet_ignorecase = ();
2051 10         14 for my $ord (0 .. 255) {
2052 2560 100       2298 if (exists $singleoctet_ignorecase{$ord}) {
2053 60         38 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         89  
2054             }
2055             else {
2056 2500         1639 $i++;
2057             }
2058             }
2059 10         16 @singleoctet = ();
2060 10         22 for my $range (@singleoctet_ignorecase) {
2061 960 100       1303 if (ref $range) {
2062 20 50       14 if (scalar(@{$range}) == 1) {
  20 50       33  
2063 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2064             }
2065 20         25 elsif (scalar(@{$range}) == 2) {
2066 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2067             }
2068             else {
2069 20         13 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         19  
  20         82  
2070             }
2071             }
2072             }
2073             }
2074              
2075             # return character list
2076 44 50       87 if (scalar(@multipleoctet) >= 1) {
2077 0 0       0 if (scalar(@singleoctet) >= 1) {
2078              
2079             # any character other than multiple-octet and single octet character class
2080 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2081             }
2082             else {
2083              
2084             # any character other than multiple-octet character class
2085 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2086             }
2087             }
2088             else {
2089 44 50       76 if (scalar(@singleoctet) >= 1) {
2090              
2091             # any character other than single octet character class
2092 44         240 return '(?:[^' . join('', @singleoctet) . '])';
2093             }
2094             else {
2095              
2096             # any character
2097 0         0 return "(?:$your_char)";
2098             }
2099             }
2100             }
2101              
2102             #
2103             # open file in read mode
2104             #
2105             sub _open_r {
2106 400     400   2482 my(undef,$file) = @_;
2107 400         1904 $file =~ s#\A (\s) #./$1#oxms;
2108 400   33     30649 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2109             open($_[0],"< $file\0");
2110             }
2111              
2112             #
2113             # open file in write mode
2114             #
2115             sub _open_w {
2116 0     0   0 my(undef,$file) = @_;
2117 0         0 $file =~ s#\A (\s) #./$1#oxms;
2118 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2119             open($_[0],"> $file\0");
2120             }
2121              
2122             #
2123             # open file in append mode
2124             #
2125             sub _open_a {
2126 0     0   0 my(undef,$file) = @_;
2127 0         0 $file =~ s#\A (\s) #./$1#oxms;
2128 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2129             open($_[0],">> $file\0");
2130             }
2131              
2132             #
2133             # safe system
2134             #
2135             sub _systemx {
2136              
2137             # P.707 29.2.33. exec
2138             # in Chapter 29: Functions
2139             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2140             #
2141             # Be aware that in older releases of Perl, exec (and system) did not flush
2142             # your output buffer, so you needed to enable command buffering by setting $|
2143             # on one or more filehandles to avoid lost output in the case of exec, or
2144             # misordererd output in the case of system. This situation was largely remedied
2145             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2146              
2147             # P.855 exec
2148             # in Chapter 27: Functions
2149             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2150             #
2151             # In very old release of Perl (before v5.6), exec (and system) did not flush
2152             # your output buffer, so you needed to enable command buffering by setting $|
2153             # on one or more filehandles to avoid lost output with exec or misordered
2154             # output with system.
2155              
2156 200     200   700 $| = 1;
2157              
2158             # P.565 23.1.2. Cleaning Up Your Environment
2159             # in Chapter 23: Security
2160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2161              
2162             # P.656 Cleaning Up Your Environment
2163             # in Chapter 20: Security
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165              
2166             # local $ENV{'PATH'} = '.';
2167 200         1618 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2168              
2169             # P.707 29.2.33. exec
2170             # in Chapter 29: Functions
2171             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2172             #
2173             # As we mentioned earlier, exec treats a discrete list of arguments as an
2174             # indication that it should bypass shell processing. However, there is one
2175             # place where you might still get tripped up. The exec call (and system, too)
2176             # will not distinguish between a single scalar argument and an array containing
2177             # only one element.
2178             #
2179             # @args = ("echo surprise"); # just one element in list
2180             # exec @args # still subject to shell escapes
2181             # or die "exec: $!"; # because @args == 1
2182             #
2183             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2184             # first argument as the pathname, which forces the rest of the arguments to be
2185             # interpreted as a list, even if there is only one of them:
2186             #
2187             # exec { $args[0] } @args # safe even with one-argument list
2188             # or die "can't exec @args: $!";
2189              
2190             # P.855 exec
2191             # in Chapter 27: Functions
2192             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2193             #
2194             # As we mentioned earlier, exec treats a discrete list of arguments as a
2195             # directive to bypass shell processing. However, there is one place where
2196             # you might still get tripped up. The exec call (and system, too) cannot
2197             # distinguish between a single scalar argument and an array containing
2198             # only one element.
2199             #
2200             # @args = ("echo surprise"); # just one element in list
2201             # exec @args # still subject to shell escapes
2202             # || die "exec: $!"; # because @args == 1
2203             #
2204             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2205             # argument as the pathname, which forces the rest of the arguments to be
2206             # interpreted as a list, even if there is only one of them:
2207             #
2208             # exec { $args[0] } @args # safe even with one-argument list
2209             # || die "can't exec @args: $!";
2210              
2211 200         317 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         15163376  
2212             }
2213              
2214             #
2215             # Windows-1258 order to character (with parameter)
2216             #
2217             sub Ewindows1258::chr(;$) {
2218              
2219 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2220              
2221 0 0       0 if ($c == 0x00) {
2222 0         0 return "\x00";
2223             }
2224             else {
2225 0         0 my @chr = ();
2226 0         0 while ($c > 0) {
2227 0         0 unshift @chr, ($c % 0x100);
2228 0         0 $c = int($c / 0x100);
2229             }
2230 0         0 return pack 'C*', @chr;
2231             }
2232             }
2233              
2234             #
2235             # Windows-1258 order to character (without parameter)
2236             #
2237             sub Ewindows1258::chr_() {
2238              
2239 0     0 0 0 my $c = $_;
2240              
2241 0 0       0 if ($c == 0x00) {
2242 0         0 return "\x00";
2243             }
2244             else {
2245 0         0 my @chr = ();
2246 0         0 while ($c > 0) {
2247 0         0 unshift @chr, ($c % 0x100);
2248 0         0 $c = int($c / 0x100);
2249             }
2250 0         0 return pack 'C*', @chr;
2251             }
2252             }
2253              
2254             #
2255             # Windows-1258 path globbing (with parameter)
2256             #
2257             sub Ewindows1258::glob($) {
2258              
2259 0 0   0 0 0 if (wantarray) {
2260 0         0 my @glob = _DOS_like_glob(@_);
2261 0         0 for my $glob (@glob) {
2262 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2263             }
2264 0         0 return @glob;
2265             }
2266             else {
2267 0         0 my $glob = _DOS_like_glob(@_);
2268 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2269 0         0 return $glob;
2270             }
2271             }
2272              
2273             #
2274             # Windows-1258 path globbing (without parameter)
2275             #
2276             sub Ewindows1258::glob_() {
2277              
2278 0 0   0 0 0 if (wantarray) {
2279 0         0 my @glob = _DOS_like_glob();
2280 0         0 for my $glob (@glob) {
2281 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2282             }
2283 0         0 return @glob;
2284             }
2285             else {
2286 0         0 my $glob = _DOS_like_glob();
2287 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2288 0         0 return $glob;
2289             }
2290             }
2291              
2292             #
2293             # Windows-1258 path globbing via File::DosGlob 1.10
2294             #
2295             # Often I confuse "_dosglob" and "_doglob".
2296             # So, I renamed "_dosglob" to "_DOS_like_glob".
2297             #
2298             my %iter;
2299             my %entries;
2300             sub _DOS_like_glob {
2301              
2302             # context (keyed by second cxix argument provided by core)
2303 0     0   0 my($expr,$cxix) = @_;
2304              
2305             # glob without args defaults to $_
2306 0 0       0 $expr = $_ if not defined $expr;
2307              
2308             # represents the current user's home directory
2309             #
2310             # 7.3. Expanding Tildes in Filenames
2311             # in Chapter 7. File Access
2312             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2313             #
2314             # and File::HomeDir, File::HomeDir::Windows module
2315              
2316             # DOS-like system
2317 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2318 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2319 0         0 { my_home_MSWin32() }oxmse;
2320             }
2321              
2322             # UNIX-like system
2323             else {
2324 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2325 0 0 0     0 { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2326             }
2327              
2328             # assume global context if not provided one
2329 0 0       0 $cxix = '_G_' if not defined $cxix;
2330 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2331              
2332             # if we're just beginning, do it all first
2333 0 0       0 if ($iter{$cxix} == 0) {
2334 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2335             }
2336              
2337             # chuck it all out, quick or slow
2338 0 0       0 if (wantarray) {
2339 0         0 delete $iter{$cxix};
2340 0         0 return @{delete $entries{$cxix}};
  0         0  
2341             }
2342             else {
2343 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2344 0         0 return shift @{$entries{$cxix}};
  0         0  
2345             }
2346             else {
2347             # return undef for EOL
2348 0         0 delete $iter{$cxix};
2349 0         0 delete $entries{$cxix};
2350 0         0 return undef;
2351             }
2352             }
2353             }
2354              
2355             #
2356             # Windows-1258 path globbing subroutine
2357             #
2358             sub _do_glob {
2359              
2360 0     0   0 my($cond,@expr) = @_;
2361 0         0 my @glob = ();
2362 0         0 my $fix_drive_relative_paths = 0;
2363              
2364             OUTER:
2365 0         0 for my $expr (@expr) {
2366 0 0       0 next OUTER if not defined $expr;
2367 0 0       0 next OUTER if $expr eq '';
2368              
2369 0         0 my @matched = ();
2370 0         0 my @globdir = ();
2371 0         0 my $head = '.';
2372 0         0 my $pathsep = '/';
2373 0         0 my $tail;
2374              
2375             # if argument is within quotes strip em and do no globbing
2376 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2377 0         0 $expr = $1;
2378 0 0       0 if ($cond eq 'd') {
2379 0 0       0 if (-d $expr) {
2380 0         0 push @glob, $expr;
2381             }
2382             }
2383             else {
2384 0 0       0 if (-e $expr) {
2385 0         0 push @glob, $expr;
2386             }
2387             }
2388 0         0 next OUTER;
2389             }
2390              
2391             # wildcards with a drive prefix such as h:*.pm must be changed
2392             # to h:./*.pm to expand correctly
2393 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2394 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2395 0         0 $fix_drive_relative_paths = 1;
2396             }
2397             }
2398              
2399 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2400 0 0       0 if ($tail eq '') {
2401 0         0 push @glob, $expr;
2402 0         0 next OUTER;
2403             }
2404 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2405 0 0       0 if (@globdir = _do_glob('d', $head)) {
2406 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2407 0         0 next OUTER;
2408             }
2409             }
2410 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2411 0         0 $head .= $pathsep;
2412             }
2413 0         0 $expr = $tail;
2414             }
2415              
2416             # If file component has no wildcards, we can avoid opendir
2417 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2418 0 0       0 if ($head eq '.') {
2419 0         0 $head = '';
2420             }
2421 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2422 0         0 $head .= $pathsep;
2423             }
2424 0         0 $head .= $expr;
2425 0 0       0 if ($cond eq 'd') {
2426 0 0       0 if (-d $head) {
2427 0         0 push @glob, $head;
2428             }
2429             }
2430             else {
2431 0 0       0 if (-e $head) {
2432 0         0 push @glob, $head;
2433             }
2434             }
2435 0         0 next OUTER;
2436             }
2437 0 0       0 opendir(*DIR, $head) or next OUTER;
2438 0         0 my @leaf = readdir DIR;
2439 0         0 closedir DIR;
2440              
2441 0 0       0 if ($head eq '.') {
2442 0         0 $head = '';
2443             }
2444 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2445 0         0 $head .= $pathsep;
2446             }
2447              
2448 0         0 my $pattern = '';
2449 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2450 0         0 my $char = $1;
2451              
2452             # 6.9. Matching Shell Globs as Regular Expressions
2453             # in Chapter 6. Pattern Matching
2454             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2455             # (and so on)
2456              
2457 0 0       0 if ($char eq '*') {
    0          
    0          
2458 0         0 $pattern .= "(?:$your_char)*",
2459             }
2460             elsif ($char eq '?') {
2461 0         0 $pattern .= "(?:$your_char)?", # DOS style
2462             # $pattern .= "(?:$your_char)", # UNIX style
2463             }
2464             elsif ((my $fc = Ewindows1258::fc($char)) ne $char) {
2465 0         0 $pattern .= $fc;
2466             }
2467             else {
2468 0         0 $pattern .= quotemeta $char;
2469             }
2470             }
2471 0     0   0 my $matchsub = sub { Ewindows1258::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2472              
2473             # if ($@) {
2474             # print STDERR "$0: $@\n";
2475             # next OUTER;
2476             # }
2477              
2478             INNER:
2479 0         0 for my $leaf (@leaf) {
2480 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2481 0         0 next INNER;
2482             }
2483 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2484 0         0 next INNER;
2485             }
2486              
2487 0 0       0 if (&$matchsub($leaf)) {
2488 0         0 push @matched, "$head$leaf";
2489 0         0 next INNER;
2490             }
2491              
2492             # [DOS compatibility special case]
2493             # Failed, add a trailing dot and try again, but only...
2494              
2495 0 0 0     0 if (Ewindows1258::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2496             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2497             Ewindows1258::index($pattern,'\\.') != -1 # pattern has a dot.
2498             ) {
2499 0 0       0 if (&$matchsub("$leaf.")) {
2500 0         0 push @matched, "$head$leaf";
2501 0         0 next INNER;
2502             }
2503             }
2504             }
2505 0 0       0 if (@matched) {
2506 0         0 push @glob, @matched;
2507             }
2508             }
2509 0 0       0 if ($fix_drive_relative_paths) {
2510 0         0 for my $glob (@glob) {
2511 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2512             }
2513             }
2514 0         0 return @glob;
2515             }
2516              
2517             #
2518             # Windows-1258 parse line
2519             #
2520             sub _parse_line {
2521              
2522 0     0   0 my($line) = @_;
2523              
2524 0         0 $line .= ' ';
2525 0         0 my @piece = ();
2526 0         0 while ($line =~ /
2527             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2528             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2529             /oxmsg
2530             ) {
2531 0 0       0 push @piece, defined($1) ? $1 : $2;
2532             }
2533 0         0 return @piece;
2534             }
2535              
2536             #
2537             # Windows-1258 parse path
2538             #
2539             sub _parse_path {
2540              
2541 0     0   0 my($path,$pathsep) = @_;
2542              
2543 0         0 $path .= '/';
2544 0         0 my @subpath = ();
2545 0         0 while ($path =~ /
2546             ((?: [^\/\\] )+?) [\/\\]
2547             /oxmsg
2548             ) {
2549 0         0 push @subpath, $1;
2550             }
2551              
2552 0         0 my $tail = pop @subpath;
2553 0         0 my $head = join $pathsep, @subpath;
2554 0         0 return $head, $tail;
2555             }
2556              
2557             #
2558             # via File::HomeDir::Windows 1.00
2559             #
2560             sub my_home_MSWin32 {
2561              
2562             # A lot of unix people and unix-derived tools rely on
2563             # the ability to overload HOME. We will support it too
2564             # so that they can replace raw HOME calls with File::HomeDir.
2565 0 0 0 0 0 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2566 0         0 return $ENV{'HOME'};
2567             }
2568              
2569             # Do we have a user profile?
2570             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2571 0         0 return $ENV{'USERPROFILE'};
2572             }
2573              
2574             # Some Windows use something like $ENV{'HOME'}
2575             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2576 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2577             }
2578              
2579 0         0 return undef;
2580             }
2581              
2582             #
2583             # via File::HomeDir::Unix 1.00
2584             #
2585             sub my_home {
2586 0     0 0 0 my $home;
2587              
2588 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2589 0         0 $home = $ENV{'HOME'};
2590             }
2591              
2592             # This is from the original code, but I'm guessing
2593             # it means "login directory" and exists on some Unixes.
2594             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2595 0         0 $home = $ENV{'LOGDIR'};
2596             }
2597              
2598             ### More-desperate methods
2599              
2600             # Light desperation on any (Unixish) platform
2601             else {
2602 0         0 $home = CORE::eval q{ (getpwuid($<))[7] };
2603             }
2604              
2605             # On Unix in general, a non-existant home means "no home"
2606             # For example, "nobody"-like users might use /nonexistant
2607 0 0 0     0 if (defined $home and ! -d($home)) {
2608 0         0 $home = undef;
2609             }
2610 0         0 return $home;
2611             }
2612              
2613             #
2614             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2615             #
2616             sub Ewindows1258::PREMATCH {
2617 0     0 0 0 return $`;
2618             }
2619              
2620             #
2621             # ${^MATCH}, $MATCH, $& the string that matched
2622             #
2623             sub Ewindows1258::MATCH {
2624 0     0 0 0 return $&;
2625             }
2626              
2627             #
2628             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2629             #
2630             sub Ewindows1258::POSTMATCH {
2631 0     0 0 0 return $';
2632             }
2633              
2634             #
2635             # Windows-1258 character to order (with parameter)
2636             #
2637             sub Windows1258::ord(;$) {
2638              
2639 0 0   0 1 0 local $_ = shift if @_;
2640              
2641 0 0       0 if (/\A ($q_char) /oxms) {
2642 0         0 my @ord = unpack 'C*', $1;
2643 0         0 my $ord = 0;
2644 0         0 while (my $o = shift @ord) {
2645 0         0 $ord = $ord * 0x100 + $o;
2646             }
2647 0         0 return $ord;
2648             }
2649             else {
2650 0         0 return CORE::ord $_;
2651             }
2652             }
2653              
2654             #
2655             # Windows-1258 character to order (without parameter)
2656             #
2657             sub Windows1258::ord_() {
2658              
2659 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2660 0         0 my @ord = unpack 'C*', $1;
2661 0         0 my $ord = 0;
2662 0         0 while (my $o = shift @ord) {
2663 0         0 $ord = $ord * 0x100 + $o;
2664             }
2665 0         0 return $ord;
2666             }
2667             else {
2668 0         0 return CORE::ord $_;
2669             }
2670             }
2671              
2672             #
2673             # Windows-1258 reverse
2674             #
2675             sub Windows1258::reverse(@) {
2676              
2677 0 0   0 0 0 if (wantarray) {
2678 0         0 return CORE::reverse @_;
2679             }
2680             else {
2681              
2682             # One of us once cornered Larry in an elevator and asked him what
2683             # problem he was solving with this, but he looked as far off into
2684             # the distance as he could in an elevator and said, "It seemed like
2685             # a good idea at the time."
2686              
2687 0         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2688             }
2689             }
2690              
2691             #
2692             # Windows-1258 getc (with parameter, without parameter)
2693             #
2694             sub Windows1258::getc(;*@) {
2695              
2696 0     0 0 0 my($package) = caller;
2697 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2698 0 0 0     0 croak 'Too many arguments for Windows1258::getc' if @_ and not wantarray;
2699              
2700 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2701 0         0 my $getc = '';
2702 0         0 for my $length ($length[0] .. $length[-1]) {
2703 0         0 $getc .= CORE::getc($fh);
2704 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2705 0 0       0 if ($getc =~ /\A ${Ewindows1258::dot_s} \z/oxms) {
2706 0 0       0 return wantarray ? ($getc,@_) : $getc;
2707             }
2708             }
2709             }
2710 0 0       0 return wantarray ? ($getc,@_) : $getc;
2711             }
2712              
2713             #
2714             # Windows-1258 length by character
2715             #
2716             sub Windows1258::length(;$) {
2717              
2718 0 0   0 1 0 local $_ = shift if @_;
2719              
2720 0         0 local @_ = /\G ($q_char) /oxmsg;
2721 0         0 return scalar @_;
2722             }
2723              
2724             #
2725             # Windows-1258 substr by character
2726             #
2727             BEGIN {
2728              
2729             # P.232 The lvalue Attribute
2730             # in Chapter 6: Subroutines
2731             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2732              
2733             # P.336 The lvalue Attribute
2734             # in Chapter 7: Subroutines
2735             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2736              
2737             # P.144 8.4 Lvalue subroutines
2738             # in Chapter 8: perlsub: Perl subroutines
2739             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2740              
2741 200 50 0 200 1 102839 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  
2742             # vv----------------------*******
2743             sub Windows1258::substr($$;$$) %s {
2744              
2745             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2746              
2747             # If the substring is beyond either end of the string, substr() returns the undefined
2748             # value and produces a warning. When used as an lvalue, specifying a substring that
2749             # is entirely outside the string raises an exception.
2750             # http://perldoc.perl.org/functions/substr.html
2751              
2752             # A return with no argument returns the scalar value undef in scalar context,
2753             # an empty list () in list context, and (naturally) nothing at all in void
2754             # context.
2755              
2756             my $offset = $_[1];
2757             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2758             return;
2759             }
2760              
2761             # substr($string,$offset,$length,$replacement)
2762             if (@_ == 4) {
2763             my(undef,undef,$length,$replacement) = @_;
2764             my $substr = join '', splice(@char, $offset, $length, $replacement);
2765             $_[0] = join '', @char;
2766              
2767             # return $substr; this doesn't work, don't say "return"
2768             $substr;
2769             }
2770              
2771             # substr($string,$offset,$length)
2772             elsif (@_ == 3) {
2773             my(undef,undef,$length) = @_;
2774             my $octet_offset = 0;
2775             my $octet_length = 0;
2776             if ($offset == 0) {
2777             $octet_offset = 0;
2778             }
2779             elsif ($offset > 0) {
2780             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2781             }
2782             else {
2783             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2784             }
2785             if ($length == 0) {
2786             $octet_length = 0;
2787             }
2788             elsif ($length > 0) {
2789             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2790             }
2791             else {
2792             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2793             }
2794             CORE::substr($_[0], $octet_offset, $octet_length);
2795             }
2796              
2797             # substr($string,$offset)
2798             else {
2799             my $octet_offset = 0;
2800             if ($offset == 0) {
2801             $octet_offset = 0;
2802             }
2803             elsif ($offset > 0) {
2804             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2805             }
2806             else {
2807             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset);
2810             }
2811             }
2812             END
2813             }
2814              
2815             #
2816             # Windows-1258 index by character
2817             #
2818             sub Windows1258::index($$;$) {
2819              
2820 0     0 1 0 my $index;
2821 0 0       0 if (@_ == 3) {
2822 0         0 $index = Ewindows1258::index($_[0], $_[1], CORE::length(Windows1258::substr($_[0], 0, $_[2])));
2823             }
2824             else {
2825 0         0 $index = Ewindows1258::index($_[0], $_[1]);
2826             }
2827              
2828 0 0       0 if ($index == -1) {
2829 0         0 return -1;
2830             }
2831             else {
2832 0         0 return Windows1258::length(CORE::substr $_[0], 0, $index);
2833             }
2834             }
2835              
2836             #
2837             # Windows-1258 rindex by character
2838             #
2839             sub Windows1258::rindex($$;$) {
2840              
2841 0     0 1 0 my $rindex;
2842 0 0       0 if (@_ == 3) {
2843 0         0 $rindex = Ewindows1258::rindex($_[0], $_[1], CORE::length(Windows1258::substr($_[0], 0, $_[2])));
2844             }
2845             else {
2846 0         0 $rindex = Ewindows1258::rindex($_[0], $_[1]);
2847             }
2848              
2849 0 0       0 if ($rindex == -1) {
2850 0         0 return -1;
2851             }
2852             else {
2853 0         0 return Windows1258::length(CORE::substr $_[0], 0, $rindex);
2854             }
2855             }
2856              
2857             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2858             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2859 200     200   14610 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1419  
  200         308  
  200         11730  
2860              
2861             # ord() to ord() or Windows1258::ord()
2862 200     200   11020 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1297  
  200         307  
  200         9470  
2863              
2864             # ord to ord or Windows1258::ord_
2865 200     200   10486 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   875  
  200         303  
  200         11009  
2866              
2867             # reverse to reverse or Windows1258::reverse
2868 200     200   10437 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   868  
  200         286  
  200         9442  
2869              
2870             # getc to getc or Windows1258::getc
2871 200     200   9634 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   833  
  200         310  
  200         9826  
2872              
2873             # P.1023 Appendix W.9 Multibyte Anchoring
2874             # of ISBN 1-56592-224-7 CJKV Information Processing
2875              
2876             my $anchor = '';
2877              
2878 200     200   10015 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   810  
  200         287  
  200         7483718  
2879              
2880             # regexp of nested parens in qqXX
2881              
2882             # P.340 Matching Nested Constructs with Embedded Code
2883             # in Chapter 7: Perl
2884             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2885              
2886             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2887             [^\\()] |
2888             \( (?{$nest++}) |
2889             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2890             \\ [^c] |
2891             \\c[\x40-\x5F] |
2892             [\x00-\xFF]
2893             }xms;
2894              
2895             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2896             [^\\{}] |
2897             \{ (?{$nest++}) |
2898             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2899             \\ [^c] |
2900             \\c[\x40-\x5F] |
2901             [\x00-\xFF]
2902             }xms;
2903              
2904             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2905             [^\\\[\]] |
2906             \[ (?{$nest++}) |
2907             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2908             \\ [^c] |
2909             \\c[\x40-\x5F] |
2910             [\x00-\xFF]
2911             }xms;
2912              
2913             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2914             [^\\<>] |
2915             \< (?{$nest++}) |
2916             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2917             \\ [^c] |
2918             \\c[\x40-\x5F] |
2919             [\x00-\xFF]
2920             }xms;
2921              
2922             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2923             (?: ::)? (?:
2924             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2925             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2926             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2927             ))
2928             }xms;
2929              
2930             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2931             (?: ::)? (?:
2932             (?>[0-9]+) |
2933             [^a-zA-Z_0-9\[\]] |
2934             ^[A-Z] |
2935             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2936             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2937             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2938             ))
2939             }xms;
2940              
2941             my $qq_substr = qr{(?> Char::substr | Windows1258::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2942             }xms;
2943              
2944             # regexp of nested parens in qXX
2945             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2946             [^()] |
2947             \( (?{$nest++}) |
2948             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2949             [\x00-\xFF]
2950             }xms;
2951              
2952             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2953             [^\{\}] |
2954             \{ (?{$nest++}) |
2955             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2956             [\x00-\xFF]
2957             }xms;
2958              
2959             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2960             [^\[\]] |
2961             \[ (?{$nest++}) |
2962             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2963             [\x00-\xFF]
2964             }xms;
2965              
2966             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2967             [^<>] |
2968             \< (?{$nest++}) |
2969             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2970             [\x00-\xFF]
2971             }xms;
2972              
2973             my $matched = '';
2974             my $s_matched = '';
2975              
2976             my $tr_variable = ''; # variable of tr///
2977             my $sub_variable = ''; # variable of s///
2978             my $bind_operator = ''; # =~ or !~
2979              
2980             my @heredoc = (); # here document
2981             my @heredoc_delimiter = ();
2982             my $here_script = ''; # here script
2983              
2984             #
2985             # escape Windows-1258 script
2986             #
2987             sub Windows1258::escape(;$) {
2988 200 50   200 0 2664 local($_) = $_[0] if @_;
2989              
2990             # P.359 The Study Function
2991             # in Chapter 7: Perl
2992             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2993              
2994 200         326 study $_; # Yes, I studied study yesterday.
2995              
2996             # while all script
2997              
2998             # 6.14. Matching from Where the Last Pattern Left Off
2999             # in Chapter 6. Pattern Matching
3000             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3001             # (and so on)
3002              
3003             # one member of Tag-team
3004             #
3005             # P.128 Start of match (or end of previous match): \G
3006             # P.130 Advanced Use of \G with Perl
3007             # in Chapter 3: Overview of Regular Expression Features and Flavors
3008             # P.255 Use leading anchors
3009             # P.256 Expose ^ and \G at the front expressions
3010             # in Chapter 6: Crafting an Efficient Expression
3011             # P.315 "Tag-team" matching with /gc
3012             # in Chapter 7: Perl
3013             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3014              
3015 200         1365 my $e_script = '';
3016 200         796 while (not /\G \z/oxgc) { # member
3017 72284         82000 $e_script .= Windows1258::escape_token();
3018             }
3019              
3020 200         2173 return $e_script;
3021             }
3022              
3023             #
3024             # escape Windows-1258 token of script
3025             #
3026             sub Windows1258::escape_token {
3027              
3028             # \n output here document
3029              
3030 72284     72284 0 56010 my $ignore_modules = join('|', qw(
3031             utf8
3032             bytes
3033             charnames
3034             I18N::Japanese
3035             I18N::Collate
3036             I18N::JExt
3037             File::DosGlob
3038             Wild
3039             Wildcard
3040             Japanese
3041             ));
3042              
3043             # another member of Tag-team
3044             #
3045             # P.315 "Tag-team" matching with /gc
3046             # in Chapter 7: Perl
3047             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3048              
3049 72284 100 100     3639612 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          
3050 12052         9886 my $heredoc = '';
3051 12052 100       19574 if (scalar(@heredoc_delimiter) >= 1) {
3052 150         147 $slash = 'm//';
3053              
3054 150         266 $heredoc = join '', @heredoc;
3055 150         238 @heredoc = ();
3056              
3057             # skip here document
3058 150         238 for my $heredoc_delimiter (@heredoc_delimiter) {
3059 150         965 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3060             }
3061 150         225 @heredoc_delimiter = ();
3062              
3063 150         162 $here_script = '';
3064             }
3065 12052         31436 return "\n" . $heredoc;
3066             }
3067              
3068             # ignore space, comment
3069 17157         44358 elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3070              
3071             # if (, elsif (, unless (, while (, until (, given (, and when (
3072              
3073             # given, when
3074              
3075             # P.225 The given Statement
3076             # in Chapter 15: Smart Matching and given-when
3077             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3078              
3079             # P.133 The given Statement
3080             # in Chapter 4: Statements and Declarations
3081             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3082              
3083             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3084 1373         1600 $slash = 'm//';
3085 1373         3866 return $1;
3086             }
3087              
3088             # scalar variable ($scalar = ...) =~ tr///;
3089             # scalar variable ($scalar = ...) =~ s///;
3090              
3091             # state
3092              
3093             # P.68 Persistent, Private Variables
3094             # in Chapter 4: Subroutines
3095             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3096              
3097             # P.160 Persistent Lexically Scoped Variables: state
3098             # in Chapter 4: Statements and Declarations
3099             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3100              
3101             # (and so on)
3102              
3103             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3104 85         189 my $e_string = e_string($1);
3105              
3106 85 50       1954 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3107 0         0 $tr_variable = $e_string . e_string($1);
3108 0         0 $bind_operator = $2;
3109 0         0 $slash = 'm//';
3110 0         0 return '';
3111             }
3112             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3113 0         0 $sub_variable = $e_string . e_string($1);
3114 0         0 $bind_operator = $2;
3115 0         0 $slash = 'm//';
3116 0         0 return '';
3117             }
3118             else {
3119 85         110 $slash = 'div';
3120 85         538 return $e_string;
3121             }
3122             }
3123              
3124             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1258::PREMATCH()
3125             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3126 4         8 $slash = 'div';
3127 4         14 return q{Ewindows1258::PREMATCH()};
3128             }
3129              
3130             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1258::MATCH()
3131             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3132 28         44 $slash = 'div';
3133 28         103 return q{Ewindows1258::MATCH()};
3134             }
3135              
3136             # $', ${'} --> $', ${'}
3137             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3138 1         4 $slash = 'div';
3139 1         7 return $1;
3140             }
3141              
3142             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1258::POSTMATCH()
3143             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3144 3         5 $slash = 'div';
3145 3         10 return q{Ewindows1258::POSTMATCH()};
3146             }
3147              
3148             # scalar variable $scalar =~ tr///;
3149             # scalar variable $scalar =~ s///;
3150             # substr() =~ tr///;
3151             # substr() =~ s///;
3152             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3153 1604         2791 my $scalar = e_string($1);
3154              
3155 1604 100       6049 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3156 1         4 $tr_variable = $scalar;
3157 1         3 $bind_operator = $1;
3158 1         3 $slash = 'm//';
3159 1         5 return '';
3160             }
3161             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3162 61         119 $sub_variable = $scalar;
3163 61         120 $bind_operator = $1;
3164 61         77 $slash = 'm//';
3165 61         187 return '';
3166             }
3167             else {
3168 1542         1548 $slash = 'div';
3169 1542         3914 return $scalar;
3170             }
3171             }
3172              
3173             # end of statement
3174             elsif (/\G ( [,;] ) /oxgc) {
3175 4547         4561 $slash = 'm//';
3176              
3177             # clear tr/// variable
3178 4547         3878 $tr_variable = '';
3179              
3180             # clear s/// variable
3181 4547         3497 $sub_variable = '';
3182              
3183 4547         3337 $bind_operator = '';
3184              
3185 4547         14119 return $1;
3186             }
3187              
3188             # bareword
3189             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3190 0         0 return $1;
3191             }
3192              
3193             # $0 --> $0
3194             elsif (/\G ( \$ 0 ) /oxmsgc) {
3195 2         7 $slash = 'div';
3196 2         8 return $1;
3197             }
3198             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3199 0         0 $slash = 'div';
3200 0         0 return $1;
3201             }
3202              
3203             # $$ --> $$
3204             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3205 1         2 $slash = 'div';
3206 1         3 return $1;
3207             }
3208              
3209             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3210             # $1, $2, $3 --> $1, $2, $3 otherwise
3211             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3212 4         5 $slash = 'div';
3213 4         8 return e_capture($1);
3214             }
3215             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3216 0         0 $slash = 'div';
3217 0         0 return e_capture($1);
3218             }
3219              
3220             # $$foo[ ... ] --> $ $foo->[ ... ]
3221             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3222 0         0 $slash = 'div';
3223 0         0 return e_capture($1.'->'.$2);
3224             }
3225              
3226             # $$foo{ ... } --> $ $foo->{ ... }
3227             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3228 0         0 $slash = 'div';
3229 0         0 return e_capture($1.'->'.$2);
3230             }
3231              
3232             # $$foo
3233             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3234 0         0 $slash = 'div';
3235 0         0 return e_capture($1);
3236             }
3237              
3238             # ${ foo }
3239             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3240 0         0 $slash = 'div';
3241 0         0 return '${' . $1 . '}';
3242             }
3243              
3244             # ${ ... }
3245             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3246 0         0 $slash = 'div';
3247 0         0 return e_capture($1);
3248             }
3249              
3250             # variable or function
3251             # $ @ % & * $ #
3252             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) {
3253 42         59 $slash = 'div';
3254 42         127 return $1;
3255             }
3256             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3257             # $ @ # \ ' " / ? ( ) [ ] < >
3258             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3259 60         89 $slash = 'div';
3260 60         175 return $1;
3261             }
3262              
3263             # while ()
3264             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3265 0         0 return $1;
3266             }
3267              
3268             # while () --- glob
3269              
3270             # avoid "Error: Runtime exception" of perl version 5.005_03
3271              
3272             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3273 0         0 return 'while ($_ = Ewindows1258::glob("' . $1 . '"))';
3274             }
3275              
3276             # while (glob)
3277             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3278 0         0 return 'while ($_ = Ewindows1258::glob_)';
3279             }
3280              
3281             # while (glob(WILDCARD))
3282             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3283 0         0 return 'while ($_ = Ewindows1258::glob';
3284             }
3285              
3286             # doit if, doit unless, doit while, doit until, doit for, doit when
3287 241         440 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         843  
3288              
3289             # subroutines of package Ewindows1258
3290 19         29 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         58  
3291 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3292 13         12 elsif (/\G \b Windows1258::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         29  
3293 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3294 114         123 elsif (/\G \b Windows1258::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Windows1258::escape'; }
  114         330  
3295 2         3 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         6  
3296 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::chop'; }
  0         0  
3297 2         3 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         6  
3298 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3299 0         0 elsif (/\G \b Windows1258::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Windows1258::index'; }
  0         0  
3300 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::index'; }
  0         0  
3301 2         3 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         5  
3302 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3303 0         0 elsif (/\G \b Windows1258::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Windows1258::rindex'; }
  0         0  
3304 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::rindex'; }
  0         0  
3305 1         3 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::lc'; }
  1         3  
3306 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::lcfirst'; }
  0         0  
3307 1         1 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::uc'; }
  1         3  
3308 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::ucfirst'; }
  0         0  
3309 6         7 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::fc'; }
  6         12  
3310              
3311             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3312 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3313 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3314 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3315 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3316 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3317 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3318 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  
3319              
3320 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3321 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3322 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3323 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3324 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3325 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3326 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  
3327              
3328             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3329 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3330 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3331 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3332 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3333              
3334 2         4 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         5  
3335 2         4 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         14  
3336 36         67 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::chr'; }
  36         125  
3337 2         3 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         5  
3338 8         10 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         24  
3339 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1258::glob'; }
  0         0  
3340 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::lc_'; }
  0         0  
3341 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::lcfirst_'; }
  0         0  
3342 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::uc_'; }
  0         0  
3343 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::ucfirst_'; }
  0         0  
3344 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::fc_'; }
  0         0  
3345 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3346              
3347 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3348 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3349 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::chr_'; }
  0         0  
3350 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3351 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3352 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1258::glob_'; }
  0         0  
3353 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3354 8         14 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         27  
3355             # split
3356             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3357 87         147 $slash = 'm//';
3358              
3359 87         115 my $e = '';
3360 87         336 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3361 85         372 $e .= $1;
3362             }
3363              
3364             # end of split
3365 87 100       7009 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ewindows1258::split' . $e; }
  2 100       9  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3366              
3367             # split scalar value
3368 1         3 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ewindows1258::split' . $e . e_string($1); }
3369              
3370             # split literal space
3371 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ewindows1258::split' . $e . qq {qq$1 $2}; }
3372 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3373 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3374 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3375 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3376 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3377 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ewindows1258::split' . $e . qq {q$1 $2}; }
3378 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3379 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3380 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3381 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3382 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3383 10         51 elsif (/\G ' [ ] ' /oxgc) { return 'Ewindows1258::split' . $e . qq {' '}; }
3384 0         0 elsif (/\G " [ ] " /oxgc) { return 'Ewindows1258::split' . $e . qq {" "}; }
3385              
3386             # split qq//
3387             elsif (/\G \b (qq) \b /oxgc) {
3388 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3389             else {
3390 0         0 while (not /\G \z/oxgc) {
3391 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3392 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3393 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3394 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3395 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3396 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3397 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3398             }
3399 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3400             }
3401             }
3402              
3403             # split qr//
3404             elsif (/\G \b (qr) \b /oxgc) {
3405 12 50       450 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3406             else {
3407 12         55 while (not /\G \z/oxgc) {
3408 12 50       3352 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3409 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3410 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3411 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3412 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3413 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3414 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3415 12         64 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3416             }
3417 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3418             }
3419             }
3420              
3421             # split q//
3422             elsif (/\G \b (q) \b /oxgc) {
3423 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3424             else {
3425 0         0 while (not /\G \z/oxgc) {
3426 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3427 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3428 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3429 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3430 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3431 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3432 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3433             }
3434 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3435             }
3436             }
3437              
3438             # split m//
3439             elsif (/\G \b (m) \b /oxgc) {
3440 18 50       570 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3441             else {
3442 18         82 while (not /\G \z/oxgc) {
3443 18 50       3965 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3444 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3445 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3446 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3447 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3448 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3449 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3450 18         111 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3451             }
3452 0         0 die __FILE__, ": Search pattern not terminated\n";
3453             }
3454             }
3455              
3456             # split ''
3457             elsif (/\G (\') /oxgc) {
3458 0         0 my $q_string = '';
3459 0         0 while (not /\G \z/oxgc) {
3460 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3461 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3462 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3463 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3464             }
3465 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3466             }
3467              
3468             # split ""
3469             elsif (/\G (\") /oxgc) {
3470 0         0 my $qq_string = '';
3471 0         0 while (not /\G \z/oxgc) {
3472 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3473 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3474 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3475 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3476             }
3477 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3478             }
3479              
3480             # split //
3481             elsif (/\G (\/) /oxgc) {
3482 44         100 my $regexp = '';
3483 44         142 while (not /\G \z/oxgc) {
3484 381 50       1411 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3485 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3486 44         198 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3487 337         576 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3488             }
3489 0         0 die __FILE__, ": Search pattern not terminated\n";
3490             }
3491             }
3492              
3493             # tr/// or y///
3494              
3495             # about [cdsrbB]* (/B modifier)
3496             #
3497             # P.559 appendix C
3498             # of ISBN 4-89052-384-7 Programming perl
3499             # (Japanese title is: Perl puroguramingu)
3500              
3501             elsif (/\G \b ( tr | y ) \b /oxgc) {
3502 3         9 my $ope = $1;
3503              
3504             # $1 $2 $3 $4 $5 $6
3505 3 50       71 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3506 0         0 my @tr = ($tr_variable,$2);
3507 0         0 return e_tr(@tr,'',$4,$6);
3508             }
3509             else {
3510 3         4 my $e = '';
3511 3         11 while (not /\G \z/oxgc) {
3512 3 50       360 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3513             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3514 0         0 my @tr = ($tr_variable,$2);
3515 0         0 while (not /\G \z/oxgc) {
3516 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3517 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3518 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3519 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3520 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3521 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3522             }
3523 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3524             }
3525             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3526 0         0 my @tr = ($tr_variable,$2);
3527 0         0 while (not /\G \z/oxgc) {
3528 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3529 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3530 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3531 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3532 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3533 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3534             }
3535 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3536             }
3537             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3538 0         0 my @tr = ($tr_variable,$2);
3539 0         0 while (not /\G \z/oxgc) {
3540 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3541 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3542 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3543 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3544 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3545 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3546             }
3547 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3548             }
3549             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3550 0         0 my @tr = ($tr_variable,$2);
3551 0         0 while (not /\G \z/oxgc) {
3552 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3553 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3554 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3555 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3556 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3557 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3558             }
3559 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561             # $1 $2 $3 $4 $5 $6
3562             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3563 3         12 my @tr = ($tr_variable,$2);
3564 3         10 return e_tr(@tr,'',$4,$6);
3565             }
3566             }
3567 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3568             }
3569             }
3570              
3571             # qq//
3572             elsif (/\G \b (qq) \b /oxgc) {
3573 2130         3865 my $ope = $1;
3574              
3575             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3576 2130 50       3325 if (/\G (\#) /oxgc) { # qq# #
3577 0         0 my $qq_string = '';
3578 0         0 while (not /\G \z/oxgc) {
3579 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3580 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3581 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3582 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3583             }
3584 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3585             }
3586              
3587             else {
3588 2130         2109 my $e = '';
3589 2130         4583 while (not /\G \z/oxgc) {
3590 2130 50       7741 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3591              
3592             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3593             elsif (/\G (\() /oxgc) { # qq ( )
3594 0         0 my $qq_string = '';
3595 0         0 local $nest = 1;
3596 0         0 while (not /\G \z/oxgc) {
3597 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3598 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3599 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3600             elsif (/\G (\)) /oxgc) {
3601 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3602 0         0 else { $qq_string .= $1; }
3603             }
3604 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3605             }
3606 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3607             }
3608              
3609             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3610             elsif (/\G (\{) /oxgc) { # qq { }
3611 2100         1903 my $qq_string = '';
3612 2100         2385 local $nest = 1;
3613 2100         3965 while (not /\G \z/oxgc) {
3614 82709 100       261274 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  722 50       1466  
    100          
    100          
    50          
3615 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3616 1103         1116 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1103         1769  
3617             elsif (/\G (\}) /oxgc) {
3618 3203 100       4012 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2100         4148  
3619 1103         2100 else { $qq_string .= $1; }
3620             }
3621 77681         136830 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3622             }
3623 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3624             }
3625              
3626             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3627             elsif (/\G (\[) /oxgc) { # qq [ ]
3628 0         0 my $qq_string = '';
3629 0         0 local $nest = 1;
3630 0         0 while (not /\G \z/oxgc) {
3631 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3632 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3633 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3634             elsif (/\G (\]) /oxgc) {
3635 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3636 0         0 else { $qq_string .= $1; }
3637             }
3638 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3639             }
3640 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3641             }
3642              
3643             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3644             elsif (/\G (\<) /oxgc) { # qq < >
3645 30         42 my $qq_string = '';
3646 30         51 local $nest = 1;
3647 30         96 while (not /\G \z/oxgc) {
3648 1166 100       4434 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       53  
    50          
    100          
    50          
3649 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3650 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3651             elsif (/\G (\>) /oxgc) {
3652 30 50       72 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         75  
3653 0         0 else { $qq_string .= $1; }
3654             }
3655 1114         2183 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3656             }
3657 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3658             }
3659              
3660             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3661             elsif (/\G (\S) /oxgc) { # qq * *
3662 0         0 my $delimiter = $1;
3663 0         0 my $qq_string = '';
3664 0         0 while (not /\G \z/oxgc) {
3665 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3666 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3667 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3668 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3669             }
3670 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3671             }
3672             }
3673 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3674             }
3675             }
3676              
3677             # qr//
3678             elsif (/\G \b (qr) \b /oxgc) {
3679 0         0 my $ope = $1;
3680 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3681 0         0 return e_qr($ope,$1,$3,$2,$4);
3682             }
3683             else {
3684 0         0 my $e = '';
3685 0         0 while (not /\G \z/oxgc) {
3686 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3687 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3688 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3689 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3690 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3691 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3692 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3693 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3694             }
3695 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3696             }
3697             }
3698              
3699             # qw//
3700             elsif (/\G \b (qw) \b /oxgc) {
3701 16         37 my $ope = $1;
3702 16 50       75 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3703 0         0 return e_qw($ope,$1,$3,$2);
3704             }
3705             else {
3706 16         27 my $e = '';
3707 16         51 while (not /\G \z/oxgc) {
3708 16 50       117 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3709              
3710 16         73 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3711 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3712              
3713 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3714 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3715              
3716 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3717 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3718              
3719 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3720 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3721              
3722 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3723 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3724             }
3725 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3726             }
3727             }
3728              
3729             # qx//
3730             elsif (/\G \b (qx) \b /oxgc) {
3731 0         0 my $ope = $1;
3732 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3733 0         0 return e_qq($ope,$1,$3,$2);
3734             }
3735             else {
3736 0         0 my $e = '';
3737 0         0 while (not /\G \z/oxgc) {
3738 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3739 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3740 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3741 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3742 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3743 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3744 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3745             }
3746 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3747             }
3748             }
3749              
3750             # q//
3751             elsif (/\G \b (q) \b /oxgc) {
3752 245         599 my $ope = $1;
3753              
3754             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3755              
3756             # avoid "Error: Runtime exception" of perl version 5.005_03
3757             # (and so on)
3758              
3759 245 50       700 if (/\G (\#) /oxgc) { # q# #
3760 0         0 my $q_string = '';
3761 0         0 while (not /\G \z/oxgc) {
3762 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3763 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3764 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3765 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3766             }
3767 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3768             }
3769              
3770             else {
3771 245         373 my $e = '';
3772 245         817 while (not /\G \z/oxgc) {
3773 245 50       1521 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3774              
3775             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3776             elsif (/\G (\() /oxgc) { # q ( )
3777 0         0 my $q_string = '';
3778 0         0 local $nest = 1;
3779 0         0 while (not /\G \z/oxgc) {
3780 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3781 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3782 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3783 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3784             elsif (/\G (\)) /oxgc) {
3785 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3786 0         0 else { $q_string .= $1; }
3787             }
3788 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3789             }
3790 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3791             }
3792              
3793             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3794             elsif (/\G (\{) /oxgc) { # q { }
3795 239         361 my $q_string = '';
3796 239         390 local $nest = 1;
3797 239         746 while (not /\G \z/oxgc) {
3798 3702 50       16186 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3799 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3800 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3801 107         127 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  107         171  
3802             elsif (/\G (\}) /oxgc) {
3803 346 100       674 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  239         773  
3804 107         229 else { $q_string .= $1; }
3805             }
3806 3249         5560 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3807             }
3808 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3809             }
3810              
3811             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3812             elsif (/\G (\[) /oxgc) { # q [ ]
3813 0         0 my $q_string = '';
3814 0         0 local $nest = 1;
3815 0         0 while (not /\G \z/oxgc) {
3816 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3817 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3818 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3819 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3820             elsif (/\G (\]) /oxgc) {
3821 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3822 0         0 else { $q_string .= $1; }
3823             }
3824 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3827             }
3828              
3829             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3830             elsif (/\G (\<) /oxgc) { # q < >
3831 5         7 my $q_string = '';
3832 5         25 local $nest = 1;
3833 5         59 while (not /\G \z/oxgc) {
3834 88 50       369 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3835 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3836 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3837 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3838             elsif (/\G (\>) /oxgc) {
3839 5 50       12 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         11  
3840 0         0 else { $q_string .= $1; }
3841             }
3842 83         129 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3845             }
3846              
3847             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3848             elsif (/\G (\S) /oxgc) { # q * *
3849 1         2 my $delimiter = $1;
3850 1         1 my $q_string = '';
3851 1         4 while (not /\G \z/oxgc) {
3852 14 50       66 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3853 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3854 1         3 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3855 13         23 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3856             }
3857 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3858             }
3859             }
3860 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3861             }
3862             }
3863              
3864             # m//
3865             elsif (/\G \b (m) \b /oxgc) {
3866 209         423 my $ope = $1;
3867 209 50       1849 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3868 0         0 return e_qr($ope,$1,$3,$2,$4);
3869             }
3870             else {
3871 209         269 my $e = '';
3872 209         552 while (not /\G \z/oxgc) {
3873 209 50       12935 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3874 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3875 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3876 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3877 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3878 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3879 10         31 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3880 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3881 199         602 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3882             }
3883 0         0 die __FILE__, ": Search pattern not terminated\n";
3884             }
3885             }
3886              
3887             # s///
3888              
3889             # about [cegimosxpradlunbB]* (/cg modifier)
3890             #
3891             # P.67 Pattern-Matching Operators
3892             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3893              
3894             elsif (/\G \b (s) \b /oxgc) {
3895 97         331 my $ope = $1;
3896              
3897             # $1 $2 $3 $4 $5 $6
3898 97 100       1959 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3899 1         5 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3900             }
3901             else {
3902 96         144 my $e = '';
3903 96         317 while (not /\G \z/oxgc) {
3904 96 50       12046 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3905             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3906 0         0 my @s = ($1,$2,$3);
3907 0         0 while (not /\G \z/oxgc) {
3908 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3909             # $1 $2 $3 $4
3910 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919             }
3920 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3921             }
3922             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3923 0         0 my @s = ($1,$2,$3);
3924 0         0 while (not /\G \z/oxgc) {
3925 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3926             # $1 $2 $3 $4
3927 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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 (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936             }
3937 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3938             }
3939             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3940 0         0 my @s = ($1,$2,$3);
3941 0         0 while (not /\G \z/oxgc) {
3942 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3943             # $1 $2 $3 $4
3944 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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_angle)*?) (\>) /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          
    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 (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968             }
3969 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3970             }
3971             # $1 $2 $3 $4 $5 $6
3972             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3973 21         57 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3974             }
3975             # $1 $2 $3 $4 $5 $6
3976             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3977 0         0 return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3978             }
3979             # $1 $2 $3 $4 $5 $6
3980             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3981 0         0 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3982             }
3983             # $1 $2 $3 $4 $5 $6
3984             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3985 75         313 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3986             }
3987             }
3988 0         0 die __FILE__, ": Substitution pattern not terminated\n";
3989             }
3990             }
3991              
3992             # require ignore module
3993 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3994 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3995 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3996              
3997             # use strict; --> use strict; no strict qw(refs);
3998 36         339 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3999 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4000 0         0 elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4001              
4002             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4003             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4004 2 50 33     25 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
4005 0         0 return "use $1; no strict qw(refs);";
4006             }
4007             else {
4008 2         12 return "use $1;";
4009             }
4010             }
4011             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4012 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4013 0         0 return "use $1; no strict qw(refs);";
4014             }
4015             else {
4016 0         0 return "use $1;";
4017             }
4018             }
4019              
4020             # ignore use module
4021 2         13 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4022 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4023 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4024              
4025             # ignore no module
4026 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4027 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4028 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4029              
4030             # use else
4031 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
4032              
4033             # use else
4034 2         10 elsif (/\G \b no \b /oxmsgc) { return "no"; }
4035              
4036             # ''
4037             elsif (/\G (?
4038 841         1218 my $q_string = '';
4039 841         2026 while (not /\G \z/oxgc) {
4040 8274 100       26445 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       13  
    100          
    50          
4041 48         75 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4042 841         1784 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4043 7381         13179 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4044             }
4045 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4046             }
4047              
4048             # ""
4049             elsif (/\G (\") /oxgc) {
4050 1717         2275 my $qq_string = '';
4051 1717         3814 while (not /\G \z/oxgc) {
4052 35119 100       97533 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       187  
    100          
    50          
4053 12         21 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4054 1717         3633 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4055 33323         57617 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4056             }
4057 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4058             }
4059              
4060             # ``
4061             elsif (/\G (\`) /oxgc) {
4062 1         4 my $qx_string = '';
4063 1         6 while (not /\G \z/oxgc) {
4064 19 50       131 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
4065 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4066 1         6 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4067 18         55 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4068             }
4069 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4070             }
4071              
4072             # // --- not divide operator (num / num), not defined-or
4073             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4074 452         710 my $regexp = '';
4075 452         1184 while (not /\G \z/oxgc) {
4076 4490 50       15121 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
4077 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4078 452         1181 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4079 4038         7235 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4080             }
4081 0         0 die __FILE__, ": Search pattern not terminated\n";
4082             }
4083              
4084             # ?? --- not conditional operator (condition ? then : else)
4085             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4086 0         0 my $regexp = '';
4087 0         0 while (not /\G \z/oxgc) {
4088 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4089 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4090 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4091 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4092             }
4093 0         0 die __FILE__, ": Search pattern not terminated\n";
4094             }
4095              
4096             # <<>> (a safer ARGV)
4097 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4098              
4099             # << (bit shift) --- not here document
4100 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4101              
4102             # <<'HEREDOC'
4103             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4104 72         78 $slash = 'm//';
4105 72         121 my $here_quote = $1;
4106 72         88 my $delimiter = $2;
4107              
4108             # get here document
4109 72 50       124 if ($here_script eq '') {
4110 72         303 $here_script = CORE::substr $_, pos $_;
4111 72         320 $here_script =~ s/.*?\n//oxm;
4112             }
4113 72 50       516 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4114 72         176 push @heredoc, $1 . qq{\n$delimiter\n};
4115 72         81 push @heredoc_delimiter, $delimiter;
4116             }
4117             else {
4118 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4119             }
4120 72         236 return $here_quote;
4121             }
4122              
4123             # <<\HEREDOC
4124              
4125             # P.66 2.6.6. "Here" Documents
4126             # in Chapter 2: Bits and Pieces
4127             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4128              
4129             # P.73 "Here" Documents
4130             # in Chapter 2: Bits and Pieces
4131             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4132              
4133             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4134 0         0 $slash = 'm//';
4135 0         0 my $here_quote = $1;
4136 0         0 my $delimiter = $2;
4137              
4138             # get here document
4139 0 0       0 if ($here_script eq '') {
4140 0         0 $here_script = CORE::substr $_, pos $_;
4141 0         0 $here_script =~ s/.*?\n//oxm;
4142             }
4143 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4144 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4145 0         0 push @heredoc_delimiter, $delimiter;
4146             }
4147             else {
4148 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4149             }
4150 0         0 return $here_quote;
4151             }
4152              
4153             # <<"HEREDOC"
4154             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4155 36         67 $slash = 'm//';
4156 36         86 my $here_quote = $1;
4157 36         506 my $delimiter = $2;
4158              
4159             # get here document
4160 36 50       98 if ($here_script eq '') {
4161 36         251 $here_script = CORE::substr $_, pos $_;
4162 36         208 $here_script =~ s/.*?\n//oxm;
4163             }
4164 36 50       876 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4165 36         111 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4166 36         172 push @heredoc_delimiter, $delimiter;
4167             }
4168             else {
4169 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4170             }
4171 36         164 return $here_quote;
4172             }
4173              
4174             # <
4175             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4176 42         74 $slash = 'm//';
4177 42         76 my $here_quote = $1;
4178 42         94 my $delimiter = $2;
4179              
4180             # get here document
4181 42 50       112 if ($here_script eq '') {
4182 42         307 $here_script = CORE::substr $_, pos $_;
4183 42         276 $here_script =~ s/.*?\n//oxm;
4184             }
4185 42 50       657 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4186 42         130 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4187 42         83 push @heredoc_delimiter, $delimiter;
4188             }
4189             else {
4190 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4191             }
4192 42         168 return $here_quote;
4193             }
4194              
4195             # <<`HEREDOC`
4196             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4197 0         0 $slash = 'm//';
4198 0         0 my $here_quote = $1;
4199 0         0 my $delimiter = $2;
4200              
4201             # get here document
4202 0 0       0 if ($here_script eq '') {
4203 0         0 $here_script = CORE::substr $_, pos $_;
4204 0         0 $here_script =~ s/.*?\n//oxm;
4205             }
4206 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4207 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4208 0         0 push @heredoc_delimiter, $delimiter;
4209             }
4210             else {
4211 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4212             }
4213 0         0 return $here_quote;
4214             }
4215              
4216             # <<= <=> <= < operator
4217             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4218 11         61 return $1;
4219             }
4220              
4221             #
4222             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4223 0         0 return $1;
4224             }
4225              
4226             # --- glob
4227              
4228             # avoid "Error: Runtime exception" of perl version 5.005_03
4229              
4230             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4231 0         0 return 'Ewindows1258::glob("' . $1 . '")';
4232             }
4233              
4234             # __DATA__
4235 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4236              
4237             # __END__
4238 200         1379 elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4239              
4240             # \cD Control-D
4241              
4242             # P.68 2.6.8. Other Literal Tokens
4243             # in Chapter 2: Bits and Pieces
4244             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4245              
4246             # P.76 Other Literal Tokens
4247             # in Chapter 2: Bits and Pieces
4248             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4249              
4250 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4251              
4252             # \cZ Control-Z
4253 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4254              
4255             # any operator before div
4256             elsif (/\G (
4257             -- | \+\+ |
4258             [\)\}\]]
4259              
4260 4824         5829 ) /oxgc) { $slash = 'div'; return $1; }
  4824         18814  
4261              
4262             # yada-yada or triple-dot operator
4263             elsif (/\G (
4264             \.\.\.
4265              
4266 7         7 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         21  
4267              
4268             # any operator before m//
4269              
4270             # //, //= (defined-or)
4271              
4272             # P.164 Logical Operators
4273             # in Chapter 10: More Control Structures
4274             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4275              
4276             # P.119 C-Style Logical (Short-Circuit) Operators
4277             # in Chapter 3: Unary and Binary Operators
4278             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4279              
4280             # (and so on)
4281              
4282             # ~~
4283              
4284             # P.221 The Smart Match Operator
4285             # in Chapter 15: Smart Matching and given-when
4286             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4287              
4288             # P.112 Smartmatch Operator
4289             # in Chapter 3: Unary and Binary Operators
4290             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4291              
4292             # (and so on)
4293              
4294             elsif (/\G ((?>
4295              
4296             !~~ | !~ | != | ! |
4297             %= | % |
4298             &&= | && | &= | &\.= | &\. | & |
4299             -= | -> | - |
4300             :(?>\s*)= |
4301             : |
4302             <<>> |
4303             <<= | <=> | <= | < |
4304             == | => | =~ | = |
4305             >>= | >> | >= | > |
4306             \*\*= | \*\* | \*= | \* |
4307             \+= | \+ |
4308             \.\. | \.= | \. |
4309             \/\/= | \/\/ |
4310             \/= | \/ |
4311             \? |
4312             \\ |
4313             \^= | \^\.= | \^\. | \^ |
4314             \b x= |
4315             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4316             ~~ | ~\. | ~ |
4317             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4318             \b(?: print )\b |
4319              
4320             [,;\(\{\[]
4321              
4322 8470         9404 )) /oxgc) { $slash = 'm//'; return $1; }
  8470         33239  
4323              
4324             # other any character
4325 15360         15957 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  15360         58537  
4326              
4327             # system error
4328             else {
4329 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4330             }
4331             }
4332              
4333             # escape Windows-1258 string
4334             sub e_string {
4335 1718     1718 0 2980 my($string) = @_;
4336 1718         1770 my $e_string = '';
4337              
4338 1718         1982 local $slash = 'm//';
4339              
4340             # P.1024 Appendix W.10 Multibyte Processing
4341             # of ISBN 1-56592-224-7 CJKV Information Processing
4342             # (and so on)
4343              
4344 1718         14409 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4345              
4346             # without { ... }
4347 1718 100 66     7222 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4348 1701 50       3312 if ($string !~ /<
4349 1701         3731 return $string;
4350             }
4351             }
4352              
4353             E_STRING_LOOP:
4354 17         50 while ($string !~ /\G \z/oxgc) {
4355 190 50       12962 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          
4356             }
4357              
4358             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ewindows1258::PREMATCH()]}
4359 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4360 0         0 $e_string .= q{Ewindows1258::PREMATCH()};
4361 0         0 $slash = 'div';
4362             }
4363              
4364             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ewindows1258::MATCH()]}
4365             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4366 0         0 $e_string .= q{Ewindows1258::MATCH()};
4367 0         0 $slash = 'div';
4368             }
4369              
4370             # $', ${'} --> $', ${'}
4371             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4372 0         0 $e_string .= $1;
4373 0         0 $slash = 'div';
4374             }
4375              
4376             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ewindows1258::POSTMATCH()]}
4377             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4378 0         0 $e_string .= q{Ewindows1258::POSTMATCH()};
4379 0         0 $slash = 'div';
4380             }
4381              
4382             # bareword
4383             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4384 0         0 $e_string .= $1;
4385 0         0 $slash = 'div';
4386             }
4387              
4388             # $0 --> $0
4389             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4390 0         0 $e_string .= $1;
4391 0         0 $slash = 'div';
4392             }
4393             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4394 0         0 $e_string .= $1;
4395 0         0 $slash = 'div';
4396             }
4397              
4398             # $$ --> $$
4399             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4400 0         0 $e_string .= $1;
4401 0         0 $slash = 'div';
4402             }
4403              
4404             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4405             # $1, $2, $3 --> $1, $2, $3 otherwise
4406             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4407 0         0 $e_string .= e_capture($1);
4408 0         0 $slash = 'div';
4409             }
4410             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4411 0         0 $e_string .= e_capture($1);
4412 0         0 $slash = 'div';
4413             }
4414              
4415             # $$foo[ ... ] --> $ $foo->[ ... ]
4416             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4417 0         0 $e_string .= e_capture($1.'->'.$2);
4418 0         0 $slash = 'div';
4419             }
4420              
4421             # $$foo{ ... } --> $ $foo->{ ... }
4422             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4423 0         0 $e_string .= e_capture($1.'->'.$2);
4424 0         0 $slash = 'div';
4425             }
4426              
4427             # $$foo
4428             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4429 0         0 $e_string .= e_capture($1);
4430 0         0 $slash = 'div';
4431             }
4432              
4433             # ${ foo }
4434             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4435 0         0 $e_string .= '${' . $1 . '}';
4436 0         0 $slash = 'div';
4437             }
4438              
4439             # ${ ... }
4440             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4441 3         10 $e_string .= e_capture($1);
4442 3         13 $slash = 'div';
4443             }
4444              
4445             # variable or function
4446             # $ @ % & * $ #
4447             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) {
4448 7         14 $e_string .= $1;
4449 7         21 $slash = 'div';
4450             }
4451             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4452             # $ @ # \ ' " / ? ( ) [ ] < >
4453             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4454 0         0 $e_string .= $1;
4455 0         0 $slash = 'div';
4456             }
4457              
4458             # subroutines of package Ewindows1258
4459 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4460 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4461 0         0 elsif ($string =~ /\G \b Windows1258::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4462 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4463 0         0 elsif ($string =~ /\G \b Windows1258::eval \b /oxgc) { $e_string .= 'eval Windows1258::escape'; $slash = 'm//'; }
  0         0  
4464 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4465 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ewindows1258::chop'; $slash = 'm//'; }
  0         0  
4466 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4467 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4468 0         0 elsif ($string =~ /\G \b Windows1258::index \b /oxgc) { $e_string .= 'Windows1258::index'; $slash = 'm//'; }
  0         0  
4469 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ewindows1258::index'; $slash = 'm//'; }
  0         0  
4470 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4471 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4472 0         0 elsif ($string =~ /\G \b Windows1258::rindex \b /oxgc) { $e_string .= 'Windows1258::rindex'; $slash = 'm//'; }
  0         0  
4473 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ewindows1258::rindex'; $slash = 'm//'; }
  0         0  
4474 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::lc'; $slash = 'm//'; }
  0         0  
4475 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::lcfirst'; $slash = 'm//'; }
  0         0  
4476 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::uc'; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::ucfirst'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::fc'; $slash = 'm//'; }
  0         0  
4479              
4480             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4481 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4482 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  
4483 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  
4484 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  
4485 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  
4486 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  
4487 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  
4488              
4489 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4490 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  
4491 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  
4492 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  
4493 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  
4494 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  
4495 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  
4496              
4497             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4498 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4499 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4500 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4501 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4502              
4503 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4504 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4505 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::chr'; $slash = 'm//'; }
  0         0  
4506 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4507 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4508 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1258::glob'; $slash = 'm//'; }
  0         0  
4509 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ewindows1258::lc_'; $slash = 'm//'; }
  0         0  
4510 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ewindows1258::lcfirst_'; $slash = 'm//'; }
  0         0  
4511 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ewindows1258::uc_'; $slash = 'm//'; }
  0         0  
4512 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ewindows1258::ucfirst_'; $slash = 'm//'; }
  0         0  
4513 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ewindows1258::fc_'; $slash = 'm//'; }
  0         0  
4514 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4515              
4516 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4517 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4518 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ewindows1258::chr_'; $slash = 'm//'; }
  0         0  
4519 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4520 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ewindows1258::glob_'; $slash = 'm//'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4524             # split
4525             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4526 0         0 $slash = 'm//';
4527              
4528 0         0 my $e = '';
4529 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4530 0         0 $e .= $1;
4531             }
4532              
4533             # end of split
4534 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ewindows1258::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          
4535              
4536             # split scalar value
4537 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4538              
4539             # split literal space
4540 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4541 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4542 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4543 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4544 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4545 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4546 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4547 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4548 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4549 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4550 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4551 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4552 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4553 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ewindows1258::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4554              
4555             # split qq//
4556             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4557 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  
4558             else {
4559 0         0 while ($string !~ /\G \z/oxgc) {
4560 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4561 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  
4562 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  
4563 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  
4564 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  
4565 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4566 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  
4567             }
4568 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4569             }
4570             }
4571              
4572             # split qr//
4573             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4574 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  
4575             else {
4576 0         0 while ($string !~ /\G \z/oxgc) {
4577 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4578 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  
4579 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  
4580 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  
4581 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  
4582 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  
4583 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  
4584 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  
4585             }
4586 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4587             }
4588             }
4589              
4590             # split q//
4591             elsif ($string =~ /\G \b (q) \b /oxgc) {
4592 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  
4593             else {
4594 0         0 while ($string !~ /\G \z/oxgc) {
4595 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4596 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  
4597 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  
4598 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  
4599 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  
4600 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  
4601 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  
4602             }
4603 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4604             }
4605             }
4606              
4607             # split m//
4608             elsif ($string =~ /\G \b (m) \b /oxgc) {
4609 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  
4610             else {
4611 0         0 while ($string !~ /\G \z/oxgc) {
4612 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4613 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  
4614 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  
4615 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  
4616 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  
4617 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  
4618 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  
4619 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  
4620             }
4621 0         0 die __FILE__, ": Search pattern not terminated\n";
4622             }
4623             }
4624              
4625             # split ''
4626             elsif ($string =~ /\G (\') /oxgc) {
4627 0         0 my $q_string = '';
4628 0         0 while ($string !~ /\G \z/oxgc) {
4629 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4630 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4631 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4632 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4633             }
4634 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4635             }
4636              
4637             # split ""
4638             elsif ($string =~ /\G (\") /oxgc) {
4639 0         0 my $qq_string = '';
4640 0         0 while ($string !~ /\G \z/oxgc) {
4641 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4642 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4643 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4644 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4645             }
4646 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4647             }
4648              
4649             # split //
4650             elsif ($string =~ /\G (\/) /oxgc) {
4651 0         0 my $regexp = '';
4652 0         0 while ($string !~ /\G \z/oxgc) {
4653 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4654 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4655 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4656 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4657             }
4658 0         0 die __FILE__, ": Search pattern not terminated\n";
4659             }
4660             }
4661              
4662             # qq//
4663             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4664 0         0 my $ope = $1;
4665 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4666 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4667             }
4668             else {
4669 0         0 my $e = '';
4670 0         0 while ($string !~ /\G \z/oxgc) {
4671 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4672 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4673 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4674 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4675 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4676 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  
4677             }
4678 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4679             }
4680             }
4681              
4682             # qx//
4683             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4684 0         0 my $ope = $1;
4685 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4686 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4687             }
4688             else {
4689 0         0 my $e = '';
4690 0         0 while ($string !~ /\G \z/oxgc) {
4691 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4692 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4693 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4694 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4695 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4696 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4697 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  
4698             }
4699 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4700             }
4701             }
4702              
4703             # q//
4704             elsif ($string =~ /\G \b (q) \b /oxgc) {
4705 0         0 my $ope = $1;
4706 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4707 0         0 $e_string .= e_q($ope,$1,$3,$2);
4708             }
4709             else {
4710 0         0 my $e = '';
4711 0         0 while ($string !~ /\G \z/oxgc) {
4712 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4713 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4714 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4715 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4716 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4717 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  
4718             }
4719 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4720             }
4721             }
4722              
4723             # ''
4724 0         0 elsif ($string =~ /\G (?
4725              
4726             # ""
4727 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4728              
4729             # ``
4730 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4731              
4732             # <<>> (a safer ARGV)
4733 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4734              
4735             # <<= <=> <= < operator
4736 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4737              
4738             #
4739 0         0 elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4740              
4741             # --- glob
4742             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4743 0         0 $e_string .= 'Ewindows1258::glob("' . $1 . '")';
4744             }
4745              
4746             # << (bit shift) --- not here document
4747 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4748              
4749             # <<'HEREDOC'
4750             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4751 0         0 $slash = 'm//';
4752 0         0 my $here_quote = $1;
4753 0         0 my $delimiter = $2;
4754              
4755             # get here document
4756 0 0       0 if ($here_script eq '') {
4757 0         0 $here_script = CORE::substr $_, pos $_;
4758 0         0 $here_script =~ s/.*?\n//oxm;
4759             }
4760 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4761 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4762 0         0 push @heredoc_delimiter, $delimiter;
4763             }
4764             else {
4765 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4766             }
4767 0         0 $e_string .= $here_quote;
4768             }
4769              
4770             # <<\HEREDOC
4771             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4772 0         0 $slash = 'm//';
4773 0         0 my $here_quote = $1;
4774 0         0 my $delimiter = $2;
4775              
4776             # get here document
4777 0 0       0 if ($here_script eq '') {
4778 0         0 $here_script = CORE::substr $_, pos $_;
4779 0         0 $here_script =~ s/.*?\n//oxm;
4780             }
4781 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4782 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4783 0         0 push @heredoc_delimiter, $delimiter;
4784             }
4785             else {
4786 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4787             }
4788 0         0 $e_string .= $here_quote;
4789             }
4790              
4791             # <<"HEREDOC"
4792             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4793 0         0 $slash = 'm//';
4794 0         0 my $here_quote = $1;
4795 0         0 my $delimiter = $2;
4796              
4797             # get here document
4798 0 0       0 if ($here_script eq '') {
4799 0         0 $here_script = CORE::substr $_, pos $_;
4800 0         0 $here_script =~ s/.*?\n//oxm;
4801             }
4802 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4803 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4804 0         0 push @heredoc_delimiter, $delimiter;
4805             }
4806             else {
4807 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4808             }
4809 0         0 $e_string .= $here_quote;
4810             }
4811              
4812             # <
4813             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4814 0         0 $slash = 'm//';
4815 0         0 my $here_quote = $1;
4816 0         0 my $delimiter = $2;
4817              
4818             # get here document
4819 0 0       0 if ($here_script eq '') {
4820 0         0 $here_script = CORE::substr $_, pos $_;
4821 0         0 $here_script =~ s/.*?\n//oxm;
4822             }
4823 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4824 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4825 0         0 push @heredoc_delimiter, $delimiter;
4826             }
4827             else {
4828 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4829             }
4830 0         0 $e_string .= $here_quote;
4831             }
4832              
4833             # <<`HEREDOC`
4834             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4835 0         0 $slash = 'm//';
4836 0         0 my $here_quote = $1;
4837 0         0 my $delimiter = $2;
4838              
4839             # get here document
4840 0 0       0 if ($here_script eq '') {
4841 0         0 $here_script = CORE::substr $_, pos $_;
4842 0         0 $here_script =~ s/.*?\n//oxm;
4843             }
4844 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4845 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4846 0         0 push @heredoc_delimiter, $delimiter;
4847             }
4848             else {
4849 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4850             }
4851 0         0 $e_string .= $here_quote;
4852             }
4853              
4854             # any operator before div
4855             elsif ($string =~ /\G (
4856             -- | \+\+ |
4857             [\)\}\]]
4858              
4859 18         29 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  18         57  
4860              
4861             # yada-yada or triple-dot operator
4862             elsif ($string =~ /\G (
4863             \.\.\.
4864              
4865 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         0  
4866              
4867             # any operator before m//
4868             elsif ($string =~ /\G ((?>
4869              
4870             !~~ | !~ | != | ! |
4871             %= | % |
4872             &&= | && | &= | &\.= | &\. | & |
4873             -= | -> | - |
4874             :(?>\s*)= |
4875             : |
4876             <<>> |
4877             <<= | <=> | <= | < |
4878             == | => | =~ | = |
4879             >>= | >> | >= | > |
4880             \*\*= | \*\* | \*= | \* |
4881             \+= | \+ |
4882             \.\. | \.= | \. |
4883             \/\/= | \/\/ |
4884             \/= | \/ |
4885             \? |
4886             \\ |
4887             \^= | \^\.= | \^\. | \^ |
4888             \b x= |
4889             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4890             ~~ | ~\. | ~ |
4891             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4892             \b(?: print )\b |
4893              
4894             [,;\(\{\[]
4895              
4896 31         41 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  31         119  
4897              
4898             # other any character
4899 131         346 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4900              
4901             # system error
4902             else {
4903 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4904             }
4905             }
4906              
4907 17         68 return $e_string;
4908             }
4909              
4910             #
4911             # character class
4912             #
4913             sub character_class {
4914 1914     1914 0 2857 my($char,$modifier) = @_;
4915              
4916 1914 100       2492 if ($char eq '.') {
4917 52 100       88 if ($modifier =~ /s/) {
4918 17         39 return '${Ewindows1258::dot_s}';
4919             }
4920             else {
4921 35         66 return '${Ewindows1258::dot}';
4922             }
4923             }
4924             else {
4925 1862         2707 return Ewindows1258::classic_character_class($char);
4926             }
4927             }
4928              
4929             #
4930             # escape capture ($1, $2, $3, ...)
4931             #
4932             sub e_capture {
4933              
4934 212     212 0 816 return join '', '${', $_[0], '}';
4935             }
4936              
4937             #
4938             # escape transliteration (tr/// or y///)
4939             #
4940             sub e_tr {
4941 3     3 0 10 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4942 3         5 my $e_tr = '';
4943 3   50     9 $modifier ||= '';
4944              
4945 3         6 $slash = 'div';
4946              
4947             # quote character class 1
4948 3         6 $charclass = q_tr($charclass);
4949              
4950             # quote character class 2
4951 3         7 $charclass2 = q_tr($charclass2);
4952              
4953             # /b /B modifier
4954 3 50       10 if ($modifier =~ tr/bB//d) {
4955 0 0       0 if ($variable eq '') {
4956 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4957             }
4958             else {
4959 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4960             }
4961             }
4962             else {
4963 3 100       8 if ($variable eq '') {
4964 2         9 $e_tr = qq{Ewindows1258::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4965             }
4966             else {
4967 1         7 $e_tr = qq{Ewindows1258::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4968             }
4969             }
4970              
4971             # clear tr/// variable
4972 3         5 $tr_variable = '';
4973 3         5 $bind_operator = '';
4974              
4975 3         21 return $e_tr;
4976             }
4977              
4978             #
4979             # quote for escape transliteration (tr/// or y///)
4980             #
4981             sub q_tr {
4982 6     6 0 8 my($charclass) = @_;
4983              
4984             # quote character class
4985 6 50       14 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4986 6         12 return e_q('', "'", "'", $charclass); # --> q' '
4987             }
4988             elsif ($charclass !~ /\//oxms) {
4989 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
4990             }
4991             elsif ($charclass !~ /\#/oxms) {
4992 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
4993             }
4994             elsif ($charclass !~ /[\<\>]/oxms) {
4995 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
4996             }
4997             elsif ($charclass !~ /[\(\)]/oxms) {
4998 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
4999             }
5000             elsif ($charclass !~ /[\{\}]/oxms) {
5001 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
5002             }
5003             else {
5004 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5005 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
5006 0         0 return e_q('q', $char, $char, $charclass);
5007             }
5008             }
5009             }
5010              
5011 0         0 return e_q('q', '{', '}', $charclass);
5012             }
5013              
5014             #
5015             # escape q string (q//, '')
5016             #
5017             sub e_q {
5018 1092     1092 0 1927 my($ope,$delimiter,$end_delimiter,$string) = @_;
5019              
5020 1092         1193 $slash = 'div';
5021              
5022 1092         5261 return join '', $ope, $delimiter, $string, $end_delimiter;
5023             }
5024              
5025             #
5026             # escape qq string (qq//, "", qx//, ``)
5027             #
5028             sub e_qq {
5029 3929     3929 0 6319 my($ope,$delimiter,$end_delimiter,$string) = @_;
5030              
5031 3929         3860 $slash = 'div';
5032              
5033 3929         3386 my $left_e = 0;
5034 3929         2903 my $right_e = 0;
5035              
5036             # split regexp
5037 3929         134692 my @char = $string =~ /\G((?>
5038             [^\\\$] |
5039             \\x\{ (?>[0-9A-Fa-f]+) \} |
5040             \\o\{ (?>[0-7]+) \} |
5041             \\N\{ (?>[^0-9\}][^\}]*) \} |
5042             \\ $q_char |
5043             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5044             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5045             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5046             \$ (?>\s* [0-9]+) |
5047             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5048             \$ \$ (?![\w\{]) |
5049             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5050             $q_char
5051             ))/oxmsg;
5052              
5053 3929         13533 for (my $i=0; $i <= $#char; $i++) {
5054              
5055             # "\L\u" --> "\u\L"
5056 112772 50 33     426432 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5057 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5058             }
5059              
5060             # "\U\l" --> "\l\U"
5061             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5062 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5063             }
5064              
5065             # octal escape sequence
5066             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5067 1         4 $char[$i] = Ewindows1258::octchr($1);
5068             }
5069              
5070             # hexadecimal escape sequence
5071             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5072 1         3 $char[$i] = Ewindows1258::hexchr($1);
5073             }
5074              
5075             # \N{CHARNAME} --> N{CHARNAME}
5076             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5077 0         0 $char[$i] = $1;
5078             }
5079              
5080 112772 100       1158782 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5081             }
5082              
5083             # \F
5084             #
5085             # P.69 Table 2-6. Translation escapes
5086             # in Chapter 2: Bits and Pieces
5087             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5088             # (and so on)
5089              
5090             # \u \l \U \L \F \Q \E
5091 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5092 484 50       1176 if ($right_e < $left_e) {
5093 0         0 $char[$i] = '\\' . $char[$i];
5094             }
5095             }
5096             elsif ($char[$i] eq '\u') {
5097              
5098             # "STRING @{[ LIST EXPR ]} MORE STRING"
5099              
5100             # P.257 Other Tricks You Can Do with Hard References
5101             # in Chapter 8: References
5102             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5103              
5104             # P.353 Other Tricks You Can Do with Hard References
5105             # in Chapter 8: References
5106             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5107              
5108             # (and so on)
5109              
5110 0         0 $char[$i] = '@{[Ewindows1258::ucfirst qq<';
5111 0         0 $left_e++;
5112             }
5113             elsif ($char[$i] eq '\l') {
5114 0         0 $char[$i] = '@{[Ewindows1258::lcfirst qq<';
5115 0         0 $left_e++;
5116             }
5117             elsif ($char[$i] eq '\U') {
5118 0         0 $char[$i] = '@{[Ewindows1258::uc qq<';
5119 0         0 $left_e++;
5120             }
5121             elsif ($char[$i] eq '\L') {
5122 0         0 $char[$i] = '@{[Ewindows1258::lc qq<';
5123 0         0 $left_e++;
5124             }
5125             elsif ($char[$i] eq '\F') {
5126 24         20 $char[$i] = '@{[Ewindows1258::fc qq<';
5127 24         40 $left_e++;
5128             }
5129             elsif ($char[$i] eq '\Q') {
5130 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5131 0         0 $left_e++;
5132             }
5133             elsif ($char[$i] eq '\E') {
5134 24 50       29 if ($right_e < $left_e) {
5135 24         24 $char[$i] = '>]}';
5136 24         38 $right_e++;
5137             }
5138             else {
5139 0         0 $char[$i] = '';
5140             }
5141             }
5142             elsif ($char[$i] eq '\Q') {
5143 0         0 while (1) {
5144 0 0       0 if (++$i > $#char) {
5145 0         0 last;
5146             }
5147 0 0       0 if ($char[$i] eq '\E') {
5148 0         0 last;
5149             }
5150             }
5151             }
5152             elsif ($char[$i] eq '\E') {
5153             }
5154              
5155             # $0 --> $0
5156             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5157             }
5158             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5159             }
5160              
5161             # $$ --> $$
5162             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5163             }
5164              
5165             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5166             # $1, $2, $3 --> $1, $2, $3 otherwise
5167             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5168 205         325 $char[$i] = e_capture($1);
5169             }
5170             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5171 0         0 $char[$i] = e_capture($1);
5172             }
5173              
5174             # $$foo[ ... ] --> $ $foo->[ ... ]
5175             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5176 0         0 $char[$i] = e_capture($1.'->'.$2);
5177             }
5178              
5179             # $$foo{ ... } --> $ $foo->{ ... }
5180             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5181 0         0 $char[$i] = e_capture($1.'->'.$2);
5182             }
5183              
5184             # $$foo
5185             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5186 0         0 $char[$i] = e_capture($1);
5187             }
5188              
5189             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1258::PREMATCH()
5190             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5191 44         110 $char[$i] = '@{[Ewindows1258::PREMATCH()]}';
5192             }
5193              
5194             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1258::MATCH()
5195             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5196 45         118 $char[$i] = '@{[Ewindows1258::MATCH()]}';
5197             }
5198              
5199             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1258::POSTMATCH()
5200             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5201 33         76 $char[$i] = '@{[Ewindows1258::POSTMATCH()]}';
5202             }
5203              
5204             # ${ foo } --> ${ foo }
5205             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5206             }
5207              
5208             # ${ ... }
5209             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5210 0         0 $char[$i] = e_capture($1);
5211             }
5212             }
5213              
5214             # return string
5215 3929 50       6392 if ($left_e > $right_e) {
5216 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5217             }
5218 3929         34296 return join '', $ope, $delimiter, @char, $end_delimiter;
5219             }
5220              
5221             #
5222             # escape qw string (qw//)
5223             #
5224             sub e_qw {
5225 16     16 0 78 my($ope,$delimiter,$end_delimiter,$string) = @_;
5226              
5227 16         22 $slash = 'div';
5228              
5229             # choice again delimiter
5230 16         200 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  483         535  
5231 16 50       93 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5232 16         149 return join '', $ope, $delimiter, $string, $end_delimiter;
5233             }
5234             elsif (not $octet{')'}) {
5235 0         0 return join '', $ope, '(', $string, ')';
5236             }
5237             elsif (not $octet{'}'}) {
5238 0         0 return join '', $ope, '{', $string, '}';
5239             }
5240             elsif (not $octet{']'}) {
5241 0         0 return join '', $ope, '[', $string, ']';
5242             }
5243             elsif (not $octet{'>'}) {
5244 0         0 return join '', $ope, '<', $string, '>';
5245             }
5246             else {
5247 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5248 0 0       0 if (not $octet{$char}) {
5249 0         0 return join '', $ope, $char, $string, $char;
5250             }
5251             }
5252             }
5253              
5254             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5255 0         0 my @string = CORE::split(/\s+/, $string);
5256 0         0 for my $string (@string) {
5257 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5258 0         0 for my $octet (@octet) {
5259 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5260 0         0 $octet = '\\' . $1;
5261             }
5262             }
5263 0         0 $string = join '', @octet;
5264             }
5265 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5266             }
5267              
5268             #
5269             # escape here document (<<"HEREDOC", <
5270             #
5271             sub e_heredoc {
5272 78     78 0 169 my($string) = @_;
5273              
5274 78         99 $slash = 'm//';
5275              
5276 78         306 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5277              
5278 78         92 my $left_e = 0;
5279 78         77 my $right_e = 0;
5280              
5281             # split regexp
5282 78         7625 my @char = $string =~ /\G((?>
5283             [^\\\$] |
5284             \\x\{ (?>[0-9A-Fa-f]+) \} |
5285             \\o\{ (?>[0-7]+) \} |
5286             \\N\{ (?>[^0-9\}][^\}]*) \} |
5287             \\ $q_char |
5288             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5289             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5290             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5291             \$ (?>\s* [0-9]+) |
5292             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5293             \$ \$ (?![\w\{]) |
5294             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5295             $q_char
5296             ))/oxmsg;
5297              
5298 78         434 for (my $i=0; $i <= $#char; $i++) {
5299              
5300             # "\L\u" --> "\u\L"
5301 3012 50 33     11578 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5302 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5303             }
5304              
5305             # "\U\l" --> "\l\U"
5306             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5307 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5308             }
5309              
5310             # octal escape sequence
5311             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5312 1         3 $char[$i] = Ewindows1258::octchr($1);
5313             }
5314              
5315             # hexadecimal escape sequence
5316             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5317 1         2 $char[$i] = Ewindows1258::hexchr($1);
5318             }
5319              
5320             # \N{CHARNAME} --> N{CHARNAME}
5321             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5322 0         0 $char[$i] = $1;
5323             }
5324              
5325 3012 50       33353 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5326             }
5327              
5328             # \u \l \U \L \F \Q \E
5329 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5330 0 0       0 if ($right_e < $left_e) {
5331 0         0 $char[$i] = '\\' . $char[$i];
5332             }
5333             }
5334             elsif ($char[$i] eq '\u') {
5335 0         0 $char[$i] = '@{[Ewindows1258::ucfirst qq<';
5336 0         0 $left_e++;
5337             }
5338             elsif ($char[$i] eq '\l') {
5339 0         0 $char[$i] = '@{[Ewindows1258::lcfirst qq<';
5340 0         0 $left_e++;
5341             }
5342             elsif ($char[$i] eq '\U') {
5343 0         0 $char[$i] = '@{[Ewindows1258::uc qq<';
5344 0         0 $left_e++;
5345             }
5346             elsif ($char[$i] eq '\L') {
5347 0         0 $char[$i] = '@{[Ewindows1258::lc qq<';
5348 0         0 $left_e++;
5349             }
5350             elsif ($char[$i] eq '\F') {
5351 0         0 $char[$i] = '@{[Ewindows1258::fc qq<';
5352 0         0 $left_e++;
5353             }
5354             elsif ($char[$i] eq '\Q') {
5355 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5356 0         0 $left_e++;
5357             }
5358             elsif ($char[$i] eq '\E') {
5359 0 0       0 if ($right_e < $left_e) {
5360 0         0 $char[$i] = '>]}';
5361 0         0 $right_e++;
5362             }
5363             else {
5364 0         0 $char[$i] = '';
5365             }
5366             }
5367             elsif ($char[$i] eq '\Q') {
5368 0         0 while (1) {
5369 0 0       0 if (++$i > $#char) {
5370 0         0 last;
5371             }
5372 0 0       0 if ($char[$i] eq '\E') {
5373 0         0 last;
5374             }
5375             }
5376             }
5377             elsif ($char[$i] eq '\E') {
5378             }
5379              
5380             # $0 --> $0
5381             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5382             }
5383             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5384             }
5385              
5386             # $$ --> $$
5387             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5388             }
5389              
5390             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5391             # $1, $2, $3 --> $1, $2, $3 otherwise
5392             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5393 0         0 $char[$i] = e_capture($1);
5394             }
5395             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5396 0         0 $char[$i] = e_capture($1);
5397             }
5398              
5399             # $$foo[ ... ] --> $ $foo->[ ... ]
5400             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5401 0         0 $char[$i] = e_capture($1.'->'.$2);
5402             }
5403              
5404             # $$foo{ ... } --> $ $foo->{ ... }
5405             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5406 0         0 $char[$i] = e_capture($1.'->'.$2);
5407             }
5408              
5409             # $$foo
5410             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5411 0         0 $char[$i] = e_capture($1);
5412             }
5413              
5414             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1258::PREMATCH()
5415             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5416 8         41 $char[$i] = '@{[Ewindows1258::PREMATCH()]}';
5417             }
5418              
5419             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1258::MATCH()
5420             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5421 8         40 $char[$i] = '@{[Ewindows1258::MATCH()]}';
5422             }
5423              
5424             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1258::POSTMATCH()
5425             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5426 6         31 $char[$i] = '@{[Ewindows1258::POSTMATCH()]}';
5427             }
5428              
5429             # ${ foo } --> ${ foo }
5430             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5431             }
5432              
5433             # ${ ... }
5434             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5435 0         0 $char[$i] = e_capture($1);
5436             }
5437             }
5438              
5439             # return string
5440 78 50       178 if ($left_e > $right_e) {
5441 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5442             }
5443 78         695 return join '', @char;
5444             }
5445              
5446             #
5447             # escape regexp (m//, qr//)
5448             #
5449             sub e_qr {
5450 651     651 0 1692 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5451 651   100     2145 $modifier ||= '';
5452              
5453 651         959 $modifier =~ tr/p//d;
5454 651 50       1510 if ($modifier =~ /([adlu])/oxms) {
5455 0         0 my $line = 0;
5456 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5457 0 0       0 if ($filename ne __FILE__) {
5458 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5459 0         0 last;
5460             }
5461             }
5462 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5463             }
5464              
5465 651         806 $slash = 'div';
5466              
5467             # literal null string pattern
5468 651 100       2020 if ($string eq '') {
    100          
5469 8         10 $modifier =~ tr/bB//d;
5470 8         11 $modifier =~ tr/i//d;
5471 8         44 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5472             }
5473              
5474             # /b /B modifier
5475             elsif ($modifier =~ tr/bB//d) {
5476              
5477             # choice again delimiter
5478 2 50       12 if ($delimiter =~ / [\@:] /oxms) {
5479 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5480 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5481 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5482 0         0 $delimiter = '(';
5483 0         0 $end_delimiter = ')';
5484             }
5485             elsif (not $octet{'}'}) {
5486 0         0 $delimiter = '{';
5487 0         0 $end_delimiter = '}';
5488             }
5489             elsif (not $octet{']'}) {
5490 0         0 $delimiter = '[';
5491 0         0 $end_delimiter = ']';
5492             }
5493             elsif (not $octet{'>'}) {
5494 0         0 $delimiter = '<';
5495 0         0 $end_delimiter = '>';
5496             }
5497             else {
5498 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5499 0 0       0 if (not $octet{$char}) {
5500 0         0 $delimiter = $char;
5501 0         0 $end_delimiter = $char;
5502 0         0 last;
5503             }
5504             }
5505             }
5506             }
5507              
5508 2 50 33     11 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5509 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5510             }
5511             else {
5512 2         9 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5513             }
5514             }
5515              
5516 641 100       1432 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5517 641         2325 my $metachar = qr/[\@\\|[\]{^]/oxms;
5518              
5519             # split regexp
5520 641         62112 my @char = $string =~ /\G((?>
5521             [^\\\$\@\[\(] |
5522             \\x (?>[0-9A-Fa-f]{1,2}) |
5523             \\ (?>[0-7]{2,3}) |
5524             \\c [\x40-\x5F] |
5525             \\x\{ (?>[0-9A-Fa-f]+) \} |
5526             \\o\{ (?>[0-7]+) \} |
5527             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5528             \\ $q_char |
5529             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5530             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5531             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5532             [\$\@] $qq_variable |
5533             \$ (?>\s* [0-9]+) |
5534             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5535             \$ \$ (?![\w\{]) |
5536             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5537             \[\^ |
5538             \[\: (?>[a-z]+) :\] |
5539             \[\:\^ (?>[a-z]+) :\] |
5540             \(\? |
5541             $q_char
5542             ))/oxmsg;
5543              
5544             # choice again delimiter
5545 641 50       2909 if ($delimiter =~ / [\@:] /oxms) {
5546 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5547 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5548 0         0 $delimiter = '(';
5549 0         0 $end_delimiter = ')';
5550             }
5551             elsif (not $octet{'}'}) {
5552 0         0 $delimiter = '{';
5553 0         0 $end_delimiter = '}';
5554             }
5555             elsif (not $octet{']'}) {
5556 0         0 $delimiter = '[';
5557 0         0 $end_delimiter = ']';
5558             }
5559             elsif (not $octet{'>'}) {
5560 0         0 $delimiter = '<';
5561 0         0 $end_delimiter = '>';
5562             }
5563             else {
5564 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5565 0 0       0 if (not $octet{$char}) {
5566 0         0 $delimiter = $char;
5567 0         0 $end_delimiter = $char;
5568 0         0 last;
5569             }
5570             }
5571             }
5572             }
5573              
5574 641         766 my $left_e = 0;
5575 641         657 my $right_e = 0;
5576 641         1713 for (my $i=0; $i <= $#char; $i++) {
5577              
5578             # "\L\u" --> "\u\L"
5579 1867 50 66     10889 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5580 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5581             }
5582              
5583             # "\U\l" --> "\l\U"
5584             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5585 0         0 @char[$i,$i+1] = @char[$i+1,$i];
5586             }
5587              
5588             # octal escape sequence
5589             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5590 1         3 $char[$i] = Ewindows1258::octchr($1);
5591             }
5592              
5593             # hexadecimal escape sequence
5594             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5595 1         2 $char[$i] = Ewindows1258::hexchr($1);
5596             }
5597              
5598             # \b{...} --> b\{...}
5599             # \B{...} --> B\{...}
5600             # \N{CHARNAME} --> N\{CHARNAME}
5601             # \p{PROPERTY} --> p\{PROPERTY}
5602             # \P{PROPERTY} --> P\{PROPERTY}
5603             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5604 6         20 $char[$i] = $1 . '\\' . $2;
5605             }
5606              
5607             # \p, \P, \X --> p, P, X
5608             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5609 4         9 $char[$i] = $1;
5610             }
5611              
5612 1867 100 100     5540 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          
5613             }
5614              
5615             # join separated multiple-octet
5616 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5617 6 50 33     98 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        
5618 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
5619             }
5620             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)) {
5621 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
5622             }
5623             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)) {
5624 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
5625             }
5626             }
5627              
5628             # open character class [...]
5629             elsif ($char[$i] eq '[') {
5630 328         355 my $left = $i;
5631              
5632             # [] make die "Unmatched [] in regexp ...\n"
5633             # (and so on)
5634              
5635 328 100       840 if ($char[$i+1] eq ']') {
5636 3         5 $i++;
5637             }
5638              
5639 328         311 while (1) {
5640 1379 50       1773 if (++$i > $#char) {
5641 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5642             }
5643 1379 100       2025 if ($char[$i] eq ']') {
5644 328         349 my $right = $i;
5645              
5646             # [...]
5647 328 100       1932 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5648 30         51 splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1258::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         100  
5649             }
5650             else {
5651 298         1139 splice @char, $left, $right-$left+1, Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
5652             }
5653              
5654 328         452 $i = $left;
5655 328         1201 last;
5656             }
5657             }
5658             }
5659              
5660             # open character class [^...]
5661             elsif ($char[$i] eq '[^') {
5662 74         68 my $left = $i;
5663              
5664             # [^] make die "Unmatched [] in regexp ...\n"
5665             # (and so on)
5666              
5667 74 100       156 if ($char[$i+1] eq ']') {
5668 4         4 $i++;
5669             }
5670              
5671 74         55 while (1) {
5672 272 50       329 if (++$i > $#char) {
5673 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5674             }
5675 272 100       421 if ($char[$i] eq ']') {
5676 74         54 my $right = $i;
5677              
5678             # [^...]
5679 74 100       360 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5680 30         50 splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1258::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         104  
5681             }
5682             else {
5683 44         154 splice @char, $left, $right-$left+1, Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5684             }
5685              
5686 74         90 $i = $left;
5687 74         188 last;
5688             }
5689             }
5690             }
5691              
5692             # rewrite character class or escape character
5693             elsif (my $char = character_class($char[$i],$modifier)) {
5694 139         511 $char[$i] = $char;
5695             }
5696              
5697             # /i modifier
5698             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1258::uc($char[$i]) ne Ewindows1258::fc($char[$i]))) {
5699 20 50       26 if (CORE::length(Ewindows1258::fc($char[$i])) == 1) {
5700 20         24 $char[$i] = '[' . Ewindows1258::uc($char[$i]) . Ewindows1258::fc($char[$i]) . ']';
5701             }
5702             else {
5703 0         0 $char[$i] = '(?:' . Ewindows1258::uc($char[$i]) . '|' . Ewindows1258::fc($char[$i]) . ')';
5704             }
5705             }
5706              
5707             # \u \l \U \L \F \Q \E
5708             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5709 1 50       5 if ($right_e < $left_e) {
5710 0         0 $char[$i] = '\\' . $char[$i];
5711             }
5712             }
5713             elsif ($char[$i] eq '\u') {
5714 0         0 $char[$i] = '@{[Ewindows1258::ucfirst qq<';
5715 0         0 $left_e++;
5716             }
5717             elsif ($char[$i] eq '\l') {
5718 0         0 $char[$i] = '@{[Ewindows1258::lcfirst qq<';
5719 0         0 $left_e++;
5720             }
5721             elsif ($char[$i] eq '\U') {
5722 1         3 $char[$i] = '@{[Ewindows1258::uc qq<';
5723 1         7 $left_e++;
5724             }
5725             elsif ($char[$i] eq '\L') {
5726 1         3 $char[$i] = '@{[Ewindows1258::lc qq<';
5727 1         7 $left_e++;
5728             }
5729             elsif ($char[$i] eq '\F') {
5730 18         17 $char[$i] = '@{[Ewindows1258::fc qq<';
5731 18         75 $left_e++;
5732             }
5733             elsif ($char[$i] eq '\Q') {
5734 1         2 $char[$i] = '@{[CORE::quotemeta qq<';
5735 1         8 $left_e++;
5736             }
5737             elsif ($char[$i] eq '\E') {
5738 21 50       38 if ($right_e < $left_e) {
5739 21         22 $char[$i] = '>]}';
5740 21         76 $right_e++;
5741             }
5742             else {
5743 0         0 $char[$i] = '';
5744             }
5745             }
5746             elsif ($char[$i] eq '\Q') {
5747 0         0 while (1) {
5748 0 0       0 if (++$i > $#char) {
5749 0         0 last;
5750             }
5751 0 0       0 if ($char[$i] eq '\E') {
5752 0         0 last;
5753             }
5754             }
5755             }
5756             elsif ($char[$i] eq '\E') {
5757             }
5758              
5759             # $0 --> $0
5760             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5761 0 0       0 if ($ignorecase) {
5762 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5763             }
5764             }
5765             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5766 0 0       0 if ($ignorecase) {
5767 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5768             }
5769             }
5770              
5771             # $$ --> $$
5772             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5773             }
5774              
5775             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5776             # $1, $2, $3 --> $1, $2, $3 otherwise
5777             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5778 0         0 $char[$i] = e_capture($1);
5779 0 0       0 if ($ignorecase) {
5780 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5781             }
5782             }
5783             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5784 0         0 $char[$i] = e_capture($1);
5785 0 0       0 if ($ignorecase) {
5786 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5787             }
5788             }
5789              
5790             # $$foo[ ... ] --> $ $foo->[ ... ]
5791             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5792 0         0 $char[$i] = e_capture($1.'->'.$2);
5793 0 0       0 if ($ignorecase) {
5794 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5795             }
5796             }
5797              
5798             # $$foo{ ... } --> $ $foo->{ ... }
5799             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5800 0         0 $char[$i] = e_capture($1.'->'.$2);
5801 0 0       0 if ($ignorecase) {
5802 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5803             }
5804             }
5805              
5806             # $$foo
5807             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5808 0         0 $char[$i] = e_capture($1);
5809 0 0       0 if ($ignorecase) {
5810 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5811             }
5812             }
5813              
5814             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1258::PREMATCH()
5815             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5816 8 50       20 if ($ignorecase) {
5817 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::PREMATCH())]}';
5818             }
5819             else {
5820 8         37 $char[$i] = '@{[Ewindows1258::PREMATCH()]}';
5821             }
5822             }
5823              
5824             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1258::MATCH()
5825             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5826 8 50       22 if ($ignorecase) {
5827 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::MATCH())]}';
5828             }
5829             else {
5830 8         35 $char[$i] = '@{[Ewindows1258::MATCH()]}';
5831             }
5832             }
5833              
5834             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1258::POSTMATCH()
5835             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5836 6 50       15 if ($ignorecase) {
5837 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::POSTMATCH())]}';
5838             }
5839             else {
5840 6         32 $char[$i] = '@{[Ewindows1258::POSTMATCH()]}';
5841             }
5842             }
5843              
5844             # ${ foo }
5845             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5846 0 0       0 if ($ignorecase) {
5847 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5848             }
5849             }
5850              
5851             # ${ ... }
5852             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5853 0         0 $char[$i] = e_capture($1);
5854 0 0       0 if ($ignorecase) {
5855 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5856             }
5857             }
5858              
5859             # $scalar or @array
5860             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5861 21         39 $char[$i] = e_string($char[$i]);
5862 21 100       87 if ($ignorecase) {
5863 11         54 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5864             }
5865             }
5866              
5867             # quote character before ? + * {
5868             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5869 138 100 33     1101 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5870             }
5871             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5872 0         0 my $char = $char[$i-1];
5873 0 0       0 if ($char[$i] eq '{') {
5874 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5875             }
5876             else {
5877 0         0 die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5878             }
5879             }
5880             else {
5881 127         777 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5882             }
5883             }
5884             }
5885              
5886             # make regexp string
5887 641         865 $modifier =~ tr/i//d;
5888 641 50       1263 if ($left_e > $right_e) {
5889 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5890 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5891             }
5892             else {
5893 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5894             }
5895             }
5896 641 50 33     3633 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5897 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5898             }
5899             else {
5900 641         5114 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5901             }
5902             }
5903              
5904             #
5905             # double quote stuff
5906             #
5907             sub qq_stuff {
5908 180     180 0 155 my($delimiter,$end_delimiter,$stuff) = @_;
5909              
5910             # scalar variable or array variable
5911 180 100       299 if ($stuff =~ /\A [\$\@] /oxms) {
5912 100         280 return $stuff;
5913             }
5914              
5915             # quote by delimiter
5916 80         137 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         197  
5917 80         143 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5918 80 50       137 next if $char eq $delimiter;
5919 80 50       108 next if $char eq $end_delimiter;
5920 80 50       128 if (not $octet{$char}) {
5921 80         321 return join '', 'qq', $char, $stuff, $char;
5922             }
5923             }
5924 0         0 return join '', 'qq', '<', $stuff, '>';
5925             }
5926              
5927             #
5928             # escape regexp (m'', qr'', and m''b, qr''b)
5929             #
5930             sub e_qr_q {
5931 10     10 0 29 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5932 10   50     37 $modifier ||= '';
5933              
5934 10         14 $modifier =~ tr/p//d;
5935 10 50       23 if ($modifier =~ /([adlu])/oxms) {
5936 0         0 my $line = 0;
5937 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5938 0 0       0 if ($filename ne __FILE__) {
5939 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5940 0         0 last;
5941             }
5942             }
5943 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5944             }
5945              
5946 10         12 $slash = 'div';
5947              
5948             # literal null string pattern
5949 10 100       22 if ($string eq '') {
    50          
5950 8         8 $modifier =~ tr/bB//d;
5951 8         8 $modifier =~ tr/i//d;
5952 8         43 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5953             }
5954              
5955             # with /b /B modifier
5956             elsif ($modifier =~ tr/bB//d) {
5957 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5958             }
5959              
5960             # without /b /B modifier
5961             else {
5962 2         5 return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5963             }
5964             }
5965              
5966             #
5967             # escape regexp (m'', qr'')
5968             #
5969             sub e_qr_qt {
5970 2     2 0 5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5971              
5972 2 50       7 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5973              
5974             # split regexp
5975 2         77 my @char = $string =~ /\G((?>
5976             [^\\\[\$\@\/] |
5977             [\x00-\xFF] |
5978             \[\^ |
5979             \[\: (?>[a-z]+) \:\] |
5980             \[\:\^ (?>[a-z]+) \:\] |
5981             [\$\@\/] |
5982             \\ (?:$q_char) |
5983             (?:$q_char)
5984             ))/oxmsg;
5985              
5986             # unescape character
5987 2         11 for (my $i=0; $i <= $#char; $i++) {
5988 2 50 33     20 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
5989             }
5990              
5991             # open character class [...]
5992 0         0 elsif ($char[$i] eq '[') {
5993 0         0 my $left = $i;
5994 0 0       0 if ($char[$i+1] eq ']') {
5995 0         0 $i++;
5996             }
5997 0         0 while (1) {
5998 0 0       0 if (++$i > $#char) {
5999 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6000             }
6001 0 0       0 if ($char[$i] eq ']') {
6002 0         0 my $right = $i;
6003              
6004             # [...]
6005 0         0 splice @char, $left, $right-$left+1, Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
6006              
6007 0         0 $i = $left;
6008 0         0 last;
6009             }
6010             }
6011             }
6012              
6013             # open character class [^...]
6014             elsif ($char[$i] eq '[^') {
6015 0         0 my $left = $i;
6016 0 0       0 if ($char[$i+1] eq ']') {
6017 0         0 $i++;
6018             }
6019 0         0 while (1) {
6020 0 0       0 if (++$i > $#char) {
6021 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6022             }
6023 0 0       0 if ($char[$i] eq ']') {
6024 0         0 my $right = $i;
6025              
6026             # [^...]
6027 0         0 splice @char, $left, $right-$left+1, Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6028              
6029 0         0 $i = $left;
6030 0         0 last;
6031             }
6032             }
6033             }
6034              
6035             # escape $ @ / and \
6036             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6037 0         0 $char[$i] = '\\' . $char[$i];
6038             }
6039              
6040             # rewrite character class or escape character
6041             elsif (my $char = character_class($char[$i],$modifier)) {
6042 0         0 $char[$i] = $char;
6043             }
6044              
6045             # /i modifier
6046             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1258::uc($char[$i]) ne Ewindows1258::fc($char[$i]))) {
6047 0 0       0 if (CORE::length(Ewindows1258::fc($char[$i])) == 1) {
6048 0         0 $char[$i] = '[' . Ewindows1258::uc($char[$i]) . Ewindows1258::fc($char[$i]) . ']';
6049             }
6050             else {
6051 0         0 $char[$i] = '(?:' . Ewindows1258::uc($char[$i]) . '|' . Ewindows1258::fc($char[$i]) . ')';
6052             }
6053             }
6054              
6055             # quote character before ? + * {
6056             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6057 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6058             }
6059             else {
6060 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6061             }
6062             }
6063             }
6064              
6065 2         4 $delimiter = '/';
6066 2         2 $end_delimiter = '/';
6067              
6068 2         4 $modifier =~ tr/i//d;
6069 2         14 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6070             }
6071              
6072             #
6073             # escape regexp (m''b, qr''b)
6074             #
6075             sub e_qr_qb {
6076 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6077              
6078             # split regexp
6079 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6080              
6081             # unescape character
6082 0         0 for (my $i=0; $i <= $#char; $i++) {
6083 0 0       0 if (0) {
    0          
6084             }
6085              
6086             # remain \\
6087 0         0 elsif ($char[$i] eq '\\\\') {
6088             }
6089              
6090             # escape $ @ / and \
6091             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6092 0         0 $char[$i] = '\\' . $char[$i];
6093             }
6094             }
6095              
6096 0         0 $delimiter = '/';
6097 0         0 $end_delimiter = '/';
6098 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6099             }
6100              
6101             #
6102             # escape regexp (s/here//)
6103             #
6104             sub e_s1 {
6105 76     76 0 169 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6106 76   100     268 $modifier ||= '';
6107              
6108 76         93 $modifier =~ tr/p//d;
6109 76 50       197 if ($modifier =~ /([adlu])/oxms) {
6110 0         0 my $line = 0;
6111 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6112 0 0       0 if ($filename ne __FILE__) {
6113 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6114 0         0 last;
6115             }
6116             }
6117 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6118             }
6119              
6120 76         113 $slash = 'div';
6121              
6122             # literal null string pattern
6123 76 100       312 if ($string eq '') {
    50          
6124 8         8 $modifier =~ tr/bB//d;
6125 8         8 $modifier =~ tr/i//d;
6126 8         58 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6127             }
6128              
6129             # /b /B modifier
6130             elsif ($modifier =~ tr/bB//d) {
6131              
6132             # choice again delimiter
6133 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
6134 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6135 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6136 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6137 0         0 $delimiter = '(';
6138 0         0 $end_delimiter = ')';
6139             }
6140             elsif (not $octet{'}'}) {
6141 0         0 $delimiter = '{';
6142 0         0 $end_delimiter = '}';
6143             }
6144             elsif (not $octet{']'}) {
6145 0         0 $delimiter = '[';
6146 0         0 $end_delimiter = ']';
6147             }
6148             elsif (not $octet{'>'}) {
6149 0         0 $delimiter = '<';
6150 0         0 $end_delimiter = '>';
6151             }
6152             else {
6153 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6154 0 0       0 if (not $octet{$char}) {
6155 0         0 $delimiter = $char;
6156 0         0 $end_delimiter = $char;
6157 0         0 last;
6158             }
6159             }
6160             }
6161             }
6162              
6163 0         0 my $prematch = '';
6164 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6165             }
6166              
6167 68 100       172 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6168 68         279 my $metachar = qr/[\@\\|[\]{^]/oxms;
6169              
6170             # split regexp
6171 68         16330 my @char = $string =~ /\G((?>
6172             [^\\\$\@\[\(] |
6173             \\ (?>[1-9][0-9]*) |
6174             \\g (?>\s*) (?>[1-9][0-9]*) |
6175             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6176             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6177             \\x (?>[0-9A-Fa-f]{1,2}) |
6178             \\ (?>[0-7]{2,3}) |
6179             \\c [\x40-\x5F] |
6180             \\x\{ (?>[0-9A-Fa-f]+) \} |
6181             \\o\{ (?>[0-7]+) \} |
6182             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6183             \\ $q_char |
6184             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6185             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6186             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6187             [\$\@] $qq_variable |
6188             \$ (?>\s* [0-9]+) |
6189             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6190             \$ \$ (?![\w\{]) |
6191             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6192             \[\^ |
6193             \[\: (?>[a-z]+) :\] |
6194             \[\:\^ (?>[a-z]+) :\] |
6195             \(\? |
6196             $q_char
6197             ))/oxmsg;
6198              
6199             # choice again delimiter
6200 68 50       545 if ($delimiter =~ / [\@:] /oxms) {
6201 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6202 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6203 0         0 $delimiter = '(';
6204 0         0 $end_delimiter = ')';
6205             }
6206             elsif (not $octet{'}'}) {
6207 0         0 $delimiter = '{';
6208 0         0 $end_delimiter = '}';
6209             }
6210             elsif (not $octet{']'}) {
6211 0         0 $delimiter = '[';
6212 0         0 $end_delimiter = ']';
6213             }
6214             elsif (not $octet{'>'}) {
6215 0         0 $delimiter = '<';
6216 0         0 $end_delimiter = '>';
6217             }
6218             else {
6219 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6220 0 0       0 if (not $octet{$char}) {
6221 0         0 $delimiter = $char;
6222 0         0 $end_delimiter = $char;
6223 0         0 last;
6224             }
6225             }
6226             }
6227             }
6228              
6229             # count '('
6230 68         124 my $parens = grep { $_ eq '(' } @char;
  253         380  
6231              
6232 68         81 my $left_e = 0;
6233 68         79 my $right_e = 0;
6234 68         213 for (my $i=0; $i <= $#char; $i++) {
6235              
6236             # "\L\u" --> "\u\L"
6237 195 50 33     1572 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6238 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6239             }
6240              
6241             # "\U\l" --> "\l\U"
6242             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6243 0         0 @char[$i,$i+1] = @char[$i+1,$i];
6244             }
6245              
6246             # octal escape sequence
6247             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6248 1         4 $char[$i] = Ewindows1258::octchr($1);
6249             }
6250              
6251             # hexadecimal escape sequence
6252             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6253 1         2 $char[$i] = Ewindows1258::hexchr($1);
6254             }
6255              
6256             # \b{...} --> b\{...}
6257             # \B{...} --> B\{...}
6258             # \N{CHARNAME} --> N\{CHARNAME}
6259             # \p{PROPERTY} --> p\{PROPERTY}
6260             # \P{PROPERTY} --> P\{PROPERTY}
6261             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6262 0         0 $char[$i] = $1 . '\\' . $2;
6263             }
6264              
6265             # \p, \P, \X --> p, P, X
6266             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6267 0         0 $char[$i] = $1;
6268             }
6269              
6270 195 50 66     772 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          
6271             }
6272              
6273             # join separated multiple-octet
6274 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6275 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        
6276 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
6277             }
6278             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)) {
6279 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
6280             }
6281             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)) {
6282 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
6283             }
6284             }
6285              
6286             # open character class [...]
6287             elsif ($char[$i] eq '[') {
6288 13         16 my $left = $i;
6289 13 50       36 if ($char[$i+1] eq ']') {
6290 0         0 $i++;
6291             }
6292 13         13 while (1) {
6293 58 50       80 if (++$i > $#char) {
6294 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6295             }
6296 58 100       79 if ($char[$i] eq ']') {
6297 13         15 my $right = $i;
6298              
6299             # [...]
6300 13 50       70 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6301 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1258::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6302             }
6303             else {
6304 13         69 splice @char, $left, $right-$left+1, Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
6305             }
6306              
6307 13         18 $i = $left;
6308 13         36 last;
6309             }
6310             }
6311             }
6312              
6313             # open character class [^...]
6314             elsif ($char[$i] eq '[^') {
6315 0         0 my $left = $i;
6316 0 0       0 if ($char[$i+1] eq ']') {
6317 0         0 $i++;
6318             }
6319 0         0 while (1) {
6320 0 0       0 if (++$i > $#char) {
6321 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6322             }
6323 0 0       0 if ($char[$i] eq ']') {
6324 0         0 my $right = $i;
6325              
6326             # [^...]
6327 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6328 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1258::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6329             }
6330             else {
6331 0         0 splice @char, $left, $right-$left+1, Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6332             }
6333              
6334 0         0 $i = $left;
6335 0         0 last;
6336             }
6337             }
6338             }
6339              
6340             # rewrite character class or escape character
6341             elsif (my $char = character_class($char[$i],$modifier)) {
6342 7         17 $char[$i] = $char;
6343             }
6344              
6345             # /i modifier
6346             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1258::uc($char[$i]) ne Ewindows1258::fc($char[$i]))) {
6347 3 50       6 if (CORE::length(Ewindows1258::fc($char[$i])) == 1) {
6348 3         5 $char[$i] = '[' . Ewindows1258::uc($char[$i]) . Ewindows1258::fc($char[$i]) . ']';
6349             }
6350             else {
6351 0         0 $char[$i] = '(?:' . Ewindows1258::uc($char[$i]) . '|' . Ewindows1258::fc($char[$i]) . ')';
6352             }
6353             }
6354              
6355             # \u \l \U \L \F \Q \E
6356             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6357 0 0       0 if ($right_e < $left_e) {
6358 0         0 $char[$i] = '\\' . $char[$i];
6359             }
6360             }
6361             elsif ($char[$i] eq '\u') {
6362 0         0 $char[$i] = '@{[Ewindows1258::ucfirst qq<';
6363 0         0 $left_e++;
6364             }
6365             elsif ($char[$i] eq '\l') {
6366 0         0 $char[$i] = '@{[Ewindows1258::lcfirst qq<';
6367 0         0 $left_e++;
6368             }
6369             elsif ($char[$i] eq '\U') {
6370 0         0 $char[$i] = '@{[Ewindows1258::uc qq<';
6371 0         0 $left_e++;
6372             }
6373             elsif ($char[$i] eq '\L') {
6374 0         0 $char[$i] = '@{[Ewindows1258::lc qq<';
6375 0         0 $left_e++;
6376             }
6377             elsif ($char[$i] eq '\F') {
6378 0         0 $char[$i] = '@{[Ewindows1258::fc qq<';
6379 0         0 $left_e++;
6380             }
6381             elsif ($char[$i] eq '\Q') {
6382 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6383 0         0 $left_e++;
6384             }
6385             elsif ($char[$i] eq '\E') {
6386 0 0       0 if ($right_e < $left_e) {
6387 0         0 $char[$i] = '>]}';
6388 0         0 $right_e++;
6389             }
6390             else {
6391 0         0 $char[$i] = '';
6392             }
6393             }
6394             elsif ($char[$i] eq '\Q') {
6395 0         0 while (1) {
6396 0 0       0 if (++$i > $#char) {
6397 0         0 last;
6398             }
6399 0 0       0 if ($char[$i] eq '\E') {
6400 0         0 last;
6401             }
6402             }
6403             }
6404             elsif ($char[$i] eq '\E') {
6405             }
6406              
6407             # \0 --> \0
6408             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6409             }
6410              
6411             # \g{N}, \g{-N}
6412              
6413             # P.108 Using Simple Patterns
6414             # in Chapter 7: In the World of Regular Expressions
6415             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6416              
6417             # P.221 Capturing
6418             # in Chapter 5: Pattern Matching
6419             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6420              
6421             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6422             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6423             }
6424              
6425             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6426             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6427             }
6428              
6429             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6430             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6431             }
6432              
6433             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6434             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6435             }
6436              
6437             # $0 --> $0
6438             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6439 0 0       0 if ($ignorecase) {
6440 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6441             }
6442             }
6443             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6444 0 0       0 if ($ignorecase) {
6445 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6446             }
6447             }
6448              
6449             # $$ --> $$
6450             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6451             }
6452              
6453             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6454             # $1, $2, $3 --> $1, $2, $3 otherwise
6455             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6456 0         0 $char[$i] = e_capture($1);
6457 0 0       0 if ($ignorecase) {
6458 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6459             }
6460             }
6461             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6462 0         0 $char[$i] = e_capture($1);
6463 0 0       0 if ($ignorecase) {
6464 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6465             }
6466             }
6467              
6468             # $$foo[ ... ] --> $ $foo->[ ... ]
6469             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6470 0         0 $char[$i] = e_capture($1.'->'.$2);
6471 0 0       0 if ($ignorecase) {
6472 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6473             }
6474             }
6475              
6476             # $$foo{ ... } --> $ $foo->{ ... }
6477             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6478 0         0 $char[$i] = e_capture($1.'->'.$2);
6479 0 0       0 if ($ignorecase) {
6480 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6481             }
6482             }
6483              
6484             # $$foo
6485             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6486 0         0 $char[$i] = e_capture($1);
6487 0 0       0 if ($ignorecase) {
6488 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6489             }
6490             }
6491              
6492             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1258::PREMATCH()
6493             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6494 4 50       10 if ($ignorecase) {
6495 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::PREMATCH())]}';
6496             }
6497             else {
6498 4         22 $char[$i] = '@{[Ewindows1258::PREMATCH()]}';
6499             }
6500             }
6501              
6502             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1258::MATCH()
6503             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6504 4 50       12 if ($ignorecase) {
6505 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::MATCH())]}';
6506             }
6507             else {
6508 4         19 $char[$i] = '@{[Ewindows1258::MATCH()]}';
6509             }
6510             }
6511              
6512             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1258::POSTMATCH()
6513             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6514 3 50       11 if ($ignorecase) {
6515 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::POSTMATCH())]}';
6516             }
6517             else {
6518 3         17 $char[$i] = '@{[Ewindows1258::POSTMATCH()]}';
6519             }
6520             }
6521              
6522             # ${ foo }
6523             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6524 0 0       0 if ($ignorecase) {
6525 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6526             }
6527             }
6528              
6529             # ${ ... }
6530             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6531 0         0 $char[$i] = e_capture($1);
6532 0 0       0 if ($ignorecase) {
6533 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6534             }
6535             }
6536              
6537             # $scalar or @array
6538             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6539 4         14 $char[$i] = e_string($char[$i]);
6540 4 50       46 if ($ignorecase) {
6541 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6542             }
6543             }
6544              
6545             # quote character before ? + * {
6546             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6547 13 50       51 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6548             }
6549             else {
6550 13         79 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6551             }
6552             }
6553             }
6554              
6555             # make regexp string
6556 68         120 my $prematch = '';
6557 68         114 $modifier =~ tr/i//d;
6558 68 50       218 if ($left_e > $right_e) {
6559 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6560             }
6561 68         855 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6562             }
6563              
6564             #
6565             # escape regexp (s'here'' or s'here''b)
6566             #
6567             sub e_s1_q {
6568 21     21 0 31 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6569 21   100     65 $modifier ||= '';
6570              
6571 21         19 $modifier =~ tr/p//d;
6572 21 50       41 if ($modifier =~ /([adlu])/oxms) {
6573 0         0 my $line = 0;
6574 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6575 0 0       0 if ($filename ne __FILE__) {
6576 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6577 0         0 last;
6578             }
6579             }
6580 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6581             }
6582              
6583 21         26 $slash = 'div';
6584              
6585             # literal null string pattern
6586 21 100       45 if ($string eq '') {
    50          
6587 8         8 $modifier =~ tr/bB//d;
6588 8         8 $modifier =~ tr/i//d;
6589 8         51 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6590             }
6591              
6592             # with /b /B modifier
6593             elsif ($modifier =~ tr/bB//d) {
6594 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6595             }
6596              
6597             # without /b /B modifier
6598             else {
6599 13         26 return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6600             }
6601             }
6602              
6603             #
6604             # escape regexp (s'here'')
6605             #
6606             sub e_s1_qt {
6607 13     13 0 21 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6608              
6609 13 50       22 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6610              
6611             # split regexp
6612 13         218 my @char = $string =~ /\G((?>
6613             [^\\\[\$\@\/] |
6614             [\x00-\xFF] |
6615             \[\^ |
6616             \[\: (?>[a-z]+) \:\] |
6617             \[\:\^ (?>[a-z]+) \:\] |
6618             [\$\@\/] |
6619             \\ (?:$q_char) |
6620             (?:$q_char)
6621             ))/oxmsg;
6622              
6623             # unescape character
6624 13         38 for (my $i=0; $i <= $#char; $i++) {
6625 25 50 33     103 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6626             }
6627              
6628             # open character class [...]
6629 0         0 elsif ($char[$i] eq '[') {
6630 0         0 my $left = $i;
6631 0 0       0 if ($char[$i+1] eq ']') {
6632 0         0 $i++;
6633             }
6634 0         0 while (1) {
6635 0 0       0 if (++$i > $#char) {
6636 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6637             }
6638 0 0       0 if ($char[$i] eq ']') {
6639 0         0 my $right = $i;
6640              
6641             # [...]
6642 0         0 splice @char, $left, $right-$left+1, Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
6643              
6644 0         0 $i = $left;
6645 0         0 last;
6646             }
6647             }
6648             }
6649              
6650             # open character class [^...]
6651             elsif ($char[$i] eq '[^') {
6652 0         0 my $left = $i;
6653 0 0       0 if ($char[$i+1] eq ']') {
6654 0         0 $i++;
6655             }
6656 0         0 while (1) {
6657 0 0       0 if (++$i > $#char) {
6658 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6659             }
6660 0 0       0 if ($char[$i] eq ']') {
6661 0         0 my $right = $i;
6662              
6663             # [^...]
6664 0         0 splice @char, $left, $right-$left+1, Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6665              
6666 0         0 $i = $left;
6667 0         0 last;
6668             }
6669             }
6670             }
6671              
6672             # escape $ @ / and \
6673             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6674 0         0 $char[$i] = '\\' . $char[$i];
6675             }
6676              
6677             # rewrite character class or escape character
6678             elsif (my $char = character_class($char[$i],$modifier)) {
6679 6         11 $char[$i] = $char;
6680             }
6681              
6682             # /i modifier
6683             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1258::uc($char[$i]) ne Ewindows1258::fc($char[$i]))) {
6684 0 0       0 if (CORE::length(Ewindows1258::fc($char[$i])) == 1) {
6685 0         0 $char[$i] = '[' . Ewindows1258::uc($char[$i]) . Ewindows1258::fc($char[$i]) . ']';
6686             }
6687             else {
6688 0         0 $char[$i] = '(?:' . Ewindows1258::uc($char[$i]) . '|' . Ewindows1258::fc($char[$i]) . ')';
6689             }
6690             }
6691              
6692             # quote character before ? + * {
6693             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6694 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6695             }
6696             else {
6697 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6698             }
6699             }
6700             }
6701              
6702 13         15 $modifier =~ tr/i//d;
6703 13         14 $delimiter = '/';
6704 13         12 $end_delimiter = '/';
6705 13         11 my $prematch = '';
6706 13         89 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6707             }
6708              
6709             #
6710             # escape regexp (s'here''b)
6711             #
6712             sub e_s1_qb {
6713 0     0 0 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6714              
6715             # split regexp
6716 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6717              
6718             # unescape character
6719 0         0 for (my $i=0; $i <= $#char; $i++) {
6720 0 0       0 if (0) {
    0          
6721             }
6722              
6723             # remain \\
6724 0         0 elsif ($char[$i] eq '\\\\') {
6725             }
6726              
6727             # escape $ @ / and \
6728             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6729 0         0 $char[$i] = '\\' . $char[$i];
6730             }
6731             }
6732              
6733 0         0 $delimiter = '/';
6734 0         0 $end_delimiter = '/';
6735 0         0 my $prematch = '';
6736 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6737             }
6738              
6739             #
6740             # escape regexp (s''here')
6741             #
6742             sub e_s2_q {
6743 16     16 0 25 my($ope,$delimiter,$end_delimiter,$string) = @_;
6744              
6745 16         19 $slash = 'div';
6746              
6747 16         107 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6748 16         50 for (my $i=0; $i <= $#char; $i++) {
6749 9 100       27 if (0) {
    100          
6750             }
6751              
6752             # not escape \\
6753 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6754             }
6755              
6756             # escape $ @ / and \
6757             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6758 5         12 $char[$i] = '\\' . $char[$i];
6759             }
6760             }
6761              
6762 16         45 return join '', $ope, $delimiter, @char, $end_delimiter;
6763             }
6764              
6765             #
6766             # escape regexp (s/here/and here/modifier)
6767             #
6768             sub e_sub {
6769 97     97 0 477 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6770 97   100     354 $modifier ||= '';
6771              
6772 97         162 $modifier =~ tr/p//d;
6773 97 50       281 if ($modifier =~ /([adlu])/oxms) {
6774 0         0 my $line = 0;
6775 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6776 0 0       0 if ($filename ne __FILE__) {
6777 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6778 0         0 last;
6779             }
6780             }
6781 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6782             }
6783              
6784 97 100       245 if ($variable eq '') {
6785 36         37 $variable = '$_';
6786 36         50 $bind_operator = ' =~ ';
6787             }
6788              
6789 97         129 $slash = 'div';
6790              
6791             # P.128 Start of match (or end of previous match): \G
6792             # P.130 Advanced Use of \G with Perl
6793             # in Chapter 3: Overview of Regular Expression Features and Flavors
6794             # P.312 Iterative Matching: Scalar Context, with /g
6795             # in Chapter 7: Perl
6796             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6797              
6798             # P.181 Where You Left Off: The \G Assertion
6799             # in Chapter 5: Pattern Matching
6800             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6801              
6802             # P.220 Where You Left Off: The \G Assertion
6803             # in Chapter 5: Pattern Matching
6804             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6805              
6806 97         127 my $e_modifier = $modifier =~ tr/e//d;
6807 97         131 my $r_modifier = $modifier =~ tr/r//d;
6808              
6809 97         117 my $my = '';
6810 97 50       238 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6811 0         0 $my = $variable;
6812 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6813 0         0 $variable =~ s/ = .+ \z//oxms;
6814             }
6815              
6816 97         217 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6817 97         147 $variable_basename =~ s/ \s+ \z//oxms;
6818              
6819             # quote replacement string
6820 97         113 my $e_replacement = '';
6821 97 100       206 if ($e_modifier >= 1) {
6822 17         35 $e_replacement = e_qq('', '', '', $replacement);
6823 17         22 $e_modifier--;
6824             }
6825             else {
6826 80 100       165 if ($delimiter2 eq "'") {
6827 16         30 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6828             }
6829             else {
6830 64         162 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6831             }
6832             }
6833              
6834 97         157 my $sub = '';
6835              
6836             # with /r
6837 97 100       204 if ($r_modifier) {
6838 8 100       18 if (0) {
6839             }
6840              
6841             # s///gr without multibyte anchoring
6842 0         0 elsif ($modifier =~ /g/oxms) {
6843 4 50       14 $sub = sprintf(
6844             # 1 2 3 4 5
6845             q,
6846              
6847             $variable, # 1
6848             ($delimiter1 eq "'") ? # 2
6849             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6850             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6851             $s_matched, # 3
6852             $e_replacement, # 4
6853             '$Windows1258::re_r=CORE::eval $Windows1258::re_r; ' x $e_modifier, # 5
6854             );
6855             }
6856              
6857             # s///r
6858             else {
6859              
6860 4         6 my $prematch = q{$`};
6861              
6862 4 50       17 $sub = sprintf(
6863             # 1 2 3 4 5 6 7
6864             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Windows1258::re_r=%s; %s"%s$Windows1258::re_r$'" } : %s>,
6865              
6866             $variable, # 1
6867             ($delimiter1 eq "'") ? # 2
6868             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6869             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6870             $s_matched, # 3
6871             $e_replacement, # 4
6872             '$Windows1258::re_r=CORE::eval $Windows1258::re_r; ' x $e_modifier, # 5
6873             $prematch, # 6
6874             $variable, # 7
6875             );
6876             }
6877              
6878             # $var !~ s///r doesn't make sense
6879 8 50       22 if ($bind_operator =~ / !~ /oxms) {
6880 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6881             }
6882             }
6883              
6884             # without /r
6885             else {
6886 89 100       198 if (0) {
6887             }
6888              
6889             # s///g without multibyte anchoring
6890 0         0 elsif ($modifier =~ /g/oxms) {
6891 22 100       89 $sub = sprintf(
    100          
6892             # 1 2 3 4 5 6 7 8
6893             q,
6894              
6895             $variable, # 1
6896             ($delimiter1 eq "'") ? # 2
6897             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6898             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6899             $s_matched, # 3
6900             $e_replacement, # 4
6901             '$Windows1258::re_r=CORE::eval $Windows1258::re_r; ' x $e_modifier, # 5
6902             $variable, # 6
6903             $variable, # 7
6904             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6905             );
6906             }
6907              
6908             # s///
6909             else {
6910              
6911 67         114 my $prematch = q{$`};
6912              
6913 67 100       407 $sub = sprintf(
    100          
6914              
6915             ($bind_operator =~ / =~ /oxms) ?
6916              
6917             # 1 2 3 4 5 6 7 8
6918             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Windows1258::re_r=%s; %s%s="%s$Windows1258::re_r$'"; 1 } : undef> :
6919              
6920             # 1 2 3 4 5 6 7 8
6921             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Windows1258::re_r=%s; %s%s="%s$Windows1258::re_r$'"; undef }>,
6922              
6923             $variable, # 1
6924             $bind_operator, # 2
6925             ($delimiter1 eq "'") ? # 3
6926             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6927             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6928             $s_matched, # 4
6929             $e_replacement, # 5
6930             '$Windows1258::re_r=CORE::eval $Windows1258::re_r; ' x $e_modifier, # 6
6931             $variable, # 7
6932             $prematch, # 8
6933             );
6934             }
6935             }
6936              
6937             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6938 97 50       276 if ($my ne '') {
6939 0         0 $sub = "($my, $sub)[1]";
6940             }
6941              
6942             # clear s/// variable
6943 97         131 $sub_variable = '';
6944 97         104 $bind_operator = '';
6945              
6946 97         784 return $sub;
6947             }
6948              
6949             #
6950             # escape regexp of split qr//
6951             #
6952             sub e_split {
6953 74     74 0 226 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6954 74   100     320 $modifier ||= '';
6955              
6956 74         100 $modifier =~ tr/p//d;
6957 74 50       317 if ($modifier =~ /([adlu])/oxms) {
6958 0         0 my $line = 0;
6959 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6960 0 0       0 if ($filename ne __FILE__) {
6961 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6962 0         0 last;
6963             }
6964             }
6965 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6966             }
6967              
6968 74         99 $slash = 'div';
6969              
6970             # /b /B modifier
6971 74 50       155 if ($modifier =~ tr/bB//d) {
6972 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6973             }
6974              
6975 74 50       173 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6976 74         333 my $metachar = qr/[\@\\|[\]{^]/oxms;
6977              
6978             # split regexp
6979 74         8544 my @char = $string =~ /\G((?>
6980             [^\\\$\@\[\(] |
6981             \\x (?>[0-9A-Fa-f]{1,2}) |
6982             \\ (?>[0-7]{2,3}) |
6983             \\c [\x40-\x5F] |
6984             \\x\{ (?>[0-9A-Fa-f]+) \} |
6985             \\o\{ (?>[0-7]+) \} |
6986             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6987             \\ $q_char |
6988             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6989             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6990             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6991             [\$\@] $qq_variable |
6992             \$ (?>\s* [0-9]+) |
6993             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6994             \$ \$ (?![\w\{]) |
6995             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6996             \[\^ |
6997             \[\: (?>[a-z]+) :\] |
6998             \[\:\^ (?>[a-z]+) :\] |
6999             \(\? |
7000             $q_char
7001             ))/oxmsg;
7002              
7003 74         249 my $left_e = 0;
7004 74         131 my $right_e = 0;
7005 74         280 for (my $i=0; $i <= $#char; $i++) {
7006              
7007             # "\L\u" --> "\u\L"
7008 249 50 33     1511 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
7009 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7010             }
7011              
7012             # "\U\l" --> "\l\U"
7013             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7014 0         0 @char[$i,$i+1] = @char[$i+1,$i];
7015             }
7016              
7017             # octal escape sequence
7018             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7019 1         2 $char[$i] = Ewindows1258::octchr($1);
7020             }
7021              
7022             # hexadecimal escape sequence
7023             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7024 1         3 $char[$i] = Ewindows1258::hexchr($1);
7025             }
7026              
7027             # \b{...} --> b\{...}
7028             # \B{...} --> B\{...}
7029             # \N{CHARNAME} --> N\{CHARNAME}
7030             # \p{PROPERTY} --> p\{PROPERTY}
7031             # \P{PROPERTY} --> P\{PROPERTY}
7032             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7033 0         0 $char[$i] = $1 . '\\' . $2;
7034             }
7035              
7036             # \p, \P, \X --> p, P, X
7037             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7038 0         0 $char[$i] = $1;
7039             }
7040              
7041 249 50 100     832 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          
7042             }
7043              
7044             # join separated multiple-octet
7045 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7046 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        
7047 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
7048             }
7049             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)) {
7050 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
7051             }
7052             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)) {
7053 0         0 $char[$i] .= join '', splice @char, $i+1, 1;
7054             }
7055             }
7056              
7057             # open character class [...]
7058             elsif ($char[$i] eq '[') {
7059 3         5 my $left = $i;
7060 3 50       9 if ($char[$i+1] eq ']') {
7061 0         0 $i++;
7062             }
7063 3         5 while (1) {
7064 7 50       17 if (++$i > $#char) {
7065 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7066             }
7067 7 100       12 if ($char[$i] eq ']') {
7068 3         4 my $right = $i;
7069              
7070             # [...]
7071 3 50       18 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7072 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1258::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7073             }
7074             else {
7075 3         12 splice @char, $left, $right-$left+1, Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
7076             }
7077              
7078 3         4 $i = $left;
7079 3         6 last;
7080             }
7081             }
7082             }
7083              
7084             # open character class [^...]
7085             elsif ($char[$i] eq '[^') {
7086 0         0 my $left = $i;
7087 0 0       0 if ($char[$i+1] eq ']') {
7088 0         0 $i++;
7089             }
7090 0         0 while (1) {
7091 0 0       0 if (++$i > $#char) {
7092 0         0 die __FILE__, ": Unmatched [] in regexp\n";
7093             }
7094 0 0       0 if ($char[$i] eq ']') {
7095 0         0 my $right = $i;
7096              
7097             # [^...]
7098 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7099 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1258::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7100             }
7101             else {
7102 0         0 splice @char, $left, $right-$left+1, Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7103             }
7104              
7105 0         0 $i = $left;
7106 0         0 last;
7107             }
7108             }
7109             }
7110              
7111             # rewrite character class or escape character
7112             elsif (my $char = character_class($char[$i],$modifier)) {
7113 1         3 $char[$i] = $char;
7114             }
7115              
7116             # P.794 29.2.161. split
7117             # in Chapter 29: Functions
7118             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7119              
7120             # P.951 split
7121             # in Chapter 27: Functions
7122             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7123              
7124             # said "The //m modifier is assumed when you split on the pattern /^/",
7125             # but perl5.008 is not so. Therefore, this software adds //m.
7126             # (and so on)
7127              
7128             # split(m/^/) --> split(m/^/m)
7129             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7130 7         41 $modifier .= 'm';
7131             }
7132              
7133             # /i modifier
7134             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1258::uc($char[$i]) ne Ewindows1258::fc($char[$i]))) {
7135 0 0       0 if (CORE::length(Ewindows1258::fc($char[$i])) == 1) {
7136 0         0 $char[$i] = '[' . Ewindows1258::uc($char[$i]) . Ewindows1258::fc($char[$i]) . ']';
7137             }
7138             else {
7139 0         0 $char[$i] = '(?:' . Ewindows1258::uc($char[$i]) . '|' . Ewindows1258::fc($char[$i]) . ')';
7140             }
7141             }
7142              
7143             # \u \l \U \L \F \Q \E
7144             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7145 0 0       0 if ($right_e < $left_e) {
7146 0         0 $char[$i] = '\\' . $char[$i];
7147             }
7148             }
7149             elsif ($char[$i] eq '\u') {
7150 0         0 $char[$i] = '@{[Ewindows1258::ucfirst qq<';
7151 0         0 $left_e++;
7152             }
7153             elsif ($char[$i] eq '\l') {
7154 0         0 $char[$i] = '@{[Ewindows1258::lcfirst qq<';
7155 0         0 $left_e++;
7156             }
7157             elsif ($char[$i] eq '\U') {
7158 0         0 $char[$i] = '@{[Ewindows1258::uc qq<';
7159 0         0 $left_e++;
7160             }
7161             elsif ($char[$i] eq '\L') {
7162 0         0 $char[$i] = '@{[Ewindows1258::lc qq<';
7163 0         0 $left_e++;
7164             }
7165             elsif ($char[$i] eq '\F') {
7166 0         0 $char[$i] = '@{[Ewindows1258::fc qq<';
7167 0         0 $left_e++;
7168             }
7169             elsif ($char[$i] eq '\Q') {
7170 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7171 0         0 $left_e++;
7172             }
7173             elsif ($char[$i] eq '\E') {
7174 0 0       0 if ($right_e < $left_e) {
7175 0         0 $char[$i] = '>]}';
7176 0         0 $right_e++;
7177             }
7178             else {
7179 0         0 $char[$i] = '';
7180             }
7181             }
7182             elsif ($char[$i] eq '\Q') {
7183 0         0 while (1) {
7184 0 0       0 if (++$i > $#char) {
7185 0         0 last;
7186             }
7187 0 0       0 if ($char[$i] eq '\E') {
7188 0         0 last;
7189             }
7190             }
7191             }
7192             elsif ($char[$i] eq '\E') {
7193             }
7194              
7195             # $0 --> $0
7196             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7197 0 0       0 if ($ignorecase) {
7198 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7199             }
7200             }
7201             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7202 0 0       0 if ($ignorecase) {
7203 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7204             }
7205             }
7206              
7207             # $$ --> $$
7208             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7209             }
7210              
7211             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7212             # $1, $2, $3 --> $1, $2, $3 otherwise
7213             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7214 0         0 $char[$i] = e_capture($1);
7215 0 0       0 if ($ignorecase) {
7216 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7217             }
7218             }
7219             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7220 0         0 $char[$i] = e_capture($1);
7221 0 0       0 if ($ignorecase) {
7222 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7223             }
7224             }
7225              
7226             # $$foo[ ... ] --> $ $foo->[ ... ]
7227             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7228 0         0 $char[$i] = e_capture($1.'->'.$2);
7229 0 0       0 if ($ignorecase) {
7230 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7231             }
7232             }
7233              
7234             # $$foo{ ... } --> $ $foo->{ ... }
7235             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7236 0         0 $char[$i] = e_capture($1.'->'.$2);
7237 0 0       0 if ($ignorecase) {
7238 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7239             }
7240             }
7241              
7242             # $$foo
7243             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7244 0         0 $char[$i] = e_capture($1);
7245 0 0       0 if ($ignorecase) {
7246 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7247             }
7248             }
7249              
7250             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1258::PREMATCH()
7251             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7252 12 50       22 if ($ignorecase) {
7253 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::PREMATCH())]}';
7254             }
7255             else {
7256 12         74 $char[$i] = '@{[Ewindows1258::PREMATCH()]}';
7257             }
7258             }
7259              
7260             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1258::MATCH()
7261             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7262 12 50       23 if ($ignorecase) {
7263 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::MATCH())]}';
7264             }
7265             else {
7266 12         88 $char[$i] = '@{[Ewindows1258::MATCH()]}';
7267             }
7268             }
7269              
7270             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1258::POSTMATCH()
7271             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7272 9 50       16 if ($ignorecase) {
7273 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(Ewindows1258::POSTMATCH())]}';
7274             }
7275             else {
7276 9         54 $char[$i] = '@{[Ewindows1258::POSTMATCH()]}';
7277             }
7278             }
7279              
7280             # ${ foo }
7281             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7282 0 0       0 if ($ignorecase) {
7283 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $1 . ')]}';
7284             }
7285             }
7286              
7287             # ${ ... }
7288             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7289 0         0 $char[$i] = e_capture($1);
7290 0 0       0 if ($ignorecase) {
7291 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7292             }
7293             }
7294              
7295             # $scalar or @array
7296             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7297 3         10 $char[$i] = e_string($char[$i]);
7298 3 50       23 if ($ignorecase) {
7299 0         0 $char[$i] = '@{[Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7300             }
7301             }
7302              
7303             # quote character before ? + * {
7304             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7305 1 50       8 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7306             }
7307             else {
7308 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7309             }
7310             }
7311             }
7312              
7313             # make regexp string
7314 74         241 $modifier =~ tr/i//d;
7315 74 50       169 if ($left_e > $right_e) {
7316 0         0 return join '', 'Ewindows1258::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7317             }
7318 74         736 return join '', 'Ewindows1258::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7319             }
7320              
7321             #
7322             # escape regexp of split qr''
7323             #
7324             sub e_split_q {
7325 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7326 0   0       $modifier ||= '';
7327              
7328 0           $modifier =~ tr/p//d;
7329 0 0         if ($modifier =~ /([adlu])/oxms) {
7330 0           my $line = 0;
7331 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7332 0 0         if ($filename ne __FILE__) {
7333 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7334 0           last;
7335             }
7336             }
7337 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7338             }
7339              
7340 0           $slash = 'div';
7341              
7342             # /b /B modifier
7343 0 0         if ($modifier =~ tr/bB//d) {
7344 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7345             }
7346              
7347 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7348              
7349             # split regexp
7350 0           my @char = $string =~ /\G((?>
7351             [^\\\[] |
7352             [\x00-\xFF] |
7353             \[\^ |
7354             \[\: (?>[a-z]+) \:\] |
7355             \[\:\^ (?>[a-z]+) \:\] |
7356             \\ (?:$q_char) |
7357             (?:$q_char)
7358             ))/oxmsg;
7359              
7360             # unescape character
7361 0           for (my $i=0; $i <= $#char; $i++) {
7362 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7363             }
7364              
7365             # open character class [...]
7366 0           elsif ($char[$i] eq '[') {
7367 0           my $left = $i;
7368 0 0         if ($char[$i+1] eq ']') {
7369 0           $i++;
7370             }
7371 0           while (1) {
7372 0 0         if (++$i > $#char) {
7373 0           die __FILE__, ": Unmatched [] in regexp\n";
7374             }
7375 0 0         if ($char[$i] eq ']') {
7376 0           my $right = $i;
7377              
7378             # [...]
7379 0           splice @char, $left, $right-$left+1, Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
7380              
7381 0           $i = $left;
7382 0           last;
7383             }
7384             }
7385             }
7386              
7387             # open character class [^...]
7388             elsif ($char[$i] eq '[^') {
7389 0           my $left = $i;
7390 0 0         if ($char[$i+1] eq ']') {
7391 0           $i++;
7392             }
7393 0           while (1) {
7394 0 0         if (++$i > $#char) {
7395 0           die __FILE__, ": Unmatched [] in regexp\n";
7396             }
7397 0 0         if ($char[$i] eq ']') {
7398 0           my $right = $i;
7399              
7400             # [^...]
7401 0           splice @char, $left, $right-$left+1, Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7402              
7403 0           $i = $left;
7404 0           last;
7405             }
7406             }
7407             }
7408              
7409             # rewrite character class or escape character
7410             elsif (my $char = character_class($char[$i],$modifier)) {
7411 0           $char[$i] = $char;
7412             }
7413              
7414             # split(m/^/) --> split(m/^/m)
7415             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7416 0           $modifier .= 'm';
7417             }
7418              
7419             # /i modifier
7420             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1258::uc($char[$i]) ne Ewindows1258::fc($char[$i]))) {
7421 0 0         if (CORE::length(Ewindows1258::fc($char[$i])) == 1) {
7422 0           $char[$i] = '[' . Ewindows1258::uc($char[$i]) . Ewindows1258::fc($char[$i]) . ']';
7423             }
7424             else {
7425 0           $char[$i] = '(?:' . Ewindows1258::uc($char[$i]) . '|' . Ewindows1258::fc($char[$i]) . ')';
7426             }
7427             }
7428              
7429             # quote character before ? + * {
7430             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7431 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7432             }
7433             else {
7434 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7435             }
7436             }
7437             }
7438              
7439 0           $modifier =~ tr/i//d;
7440 0           return join '', 'Ewindows1258::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7441             }
7442              
7443             #
7444             # instead of Carp::carp
7445             #
7446             sub carp {
7447 0     0 0   my($package,$filename,$line) = caller(1);
7448 0           print STDERR "@_ at $filename line $line.\n";
7449             }
7450              
7451             #
7452             # instead of Carp::croak
7453             #
7454             sub croak {
7455 0     0 0   my($package,$filename,$line) = caller(1);
7456 0           print STDERR "@_ at $filename line $line.\n";
7457 0           die "\n";
7458             }
7459              
7460             #
7461             # instead of Carp::cluck
7462             #
7463             sub cluck {
7464 0     0 0   my $i = 0;
7465 0           my @cluck = ();
7466 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7467 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7468 0           $i++;
7469             }
7470 0           print STDERR CORE::reverse @cluck;
7471 0           print STDERR "\n";
7472 0           carp @_;
7473             }
7474              
7475             #
7476             # instead of Carp::confess
7477             #
7478             sub confess {
7479 0     0 0   my $i = 0;
7480 0           my @confess = ();
7481 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7482 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7483 0           $i++;
7484             }
7485 0           print STDERR CORE::reverse @confess;
7486 0           print STDERR "\n";
7487 0           croak @_;
7488             }
7489              
7490             1;
7491              
7492             __END__