File Coverage

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


line stmt bran cond sub pod time code
1             package Ewindows1252;
2             ######################################################################
3             #
4             # Ewindows1252 - Run-time routines for Windows1252.pm
5             #
6             # http://search.cpan.org/dist/Char-Windows1252/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
9             ######################################################################
10              
11 200     200   4317 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         610  
  200         10641  
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   14696 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1158  
  200         317  
  200         33632  
27             $VERSION = '1.05';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1402 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         303 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         27115 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   13663 CORE::eval q{
  200     200   1181  
  200     64   309  
  200         25651  
  64         11110  
  78         13209  
  55         9069  
  69         11696  
  74         12114  
  60         9497  
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       103075 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
  0         0  
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
  0         0  
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65             BEGIN {
66 200     200   466 my $genpkg = "Symbol::";
67 200         8793 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) && (Ewindows1252::index($name, '::') == -1) && (Ewindows1252::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   407 if (CORE::eval { local $@; CORE::require strict }) {
  200         310  
  200         2008  
115 200         24439 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   14402 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1073  
  200         303  
  200         11874  
145 200     200   12337 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1024  
  200         272  
  200         11921  
146 200     200   11967 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   1017  
  200         271  
  200         13548  
147              
148             #
149             # Windows-1252 character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   12990 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   984  
  200         522  
  200         350231  
157              
158             #
159             # Windows-1252 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 Ewindows1252 \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: windows-?1252 ) \b /oxmsi;
180              
181             %lc = (%lc,
182             "\x8A" => "\x9A", # LATIN LETTER S WITH CARON
183             "\x8C" => "\x9C", # LATIN LIGATURE OE
184             "\x8E" => "\x9E", # LATIN LETTER Z WITH CARON
185             "\x9F" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
186             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
187             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
188             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
189             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
190             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
191             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
192             "\xC6" => "\xE6", # LATIN LETTER AE
193             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
194             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
195             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
196             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
197             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
198             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
199             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
200             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
201             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
202             "\xD0" => "\xF0", # LATIN LETTER ETH
203             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
204             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
205             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
206             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
207             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
208             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
209             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
210             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
211             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
212             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
213             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
214             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
215             "\xDE" => "\xFE", # LATIN LETTER THORN
216             );
217              
218             %uc = (%uc,
219             "\x9A" => "\x8A", # LATIN LETTER S WITH CARON
220             "\x9C" => "\x8C", # LATIN LIGATURE OE
221             "\x9E" => "\x8E", # LATIN LETTER Z WITH CARON
222             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
223             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
224             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
225             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
226             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
227             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
228             "\xE6" => "\xC6", # LATIN LETTER AE
229             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
230             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
231             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
232             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
233             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
234             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
235             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
236             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
237             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
238             "\xF0" => "\xD0", # LATIN LETTER ETH
239             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
240             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
241             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
242             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
243             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
244             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
245             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
246             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
247             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
248             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
249             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
250             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
251             "\xFE" => "\xDE", # LATIN LETTER THORN
252             "\xFF" => "\x9F", # LATIN LETTER Y WITH DIAERESIS
253             );
254              
255             %fc = (%fc,
256             "\x8A" => "\x9A", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
257             "\x8C" => "\x9C", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
258             "\x8E" => "\x9E", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
259             "\x9F" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
260             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
261             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
262             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
263             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
264             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
265             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
266             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
267             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
268             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
269             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
270             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
271             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
272             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
273             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
274             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
275             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
276             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
277             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
278             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
279             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
280             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
281             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
282             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
283             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
284             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
285             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
286             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
287             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
288             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
289             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
290             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
291             );
292             }
293              
294             else {
295             croak "Don't know my package name '@{[__PACKAGE__]}'";
296             }
297              
298             #
299             # @ARGV wildcard globbing
300             #
301             sub import {
302              
303 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
304 0         0 my @argv = ();
305 0         0 for (@ARGV) {
306              
307             # has space
308 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
309 0 0       0 if (my @glob = Ewindows1252::glob(qq{"$_"})) {
310 0         0 push @argv, @glob;
311             }
312             else {
313 0         0 push @argv, $_;
314             }
315             }
316              
317             # has wildcard metachar
318             elsif (/\A (?:$q_char)*? [*?] /oxms) {
319 0 0       0 if (my @glob = Ewindows1252::glob($_)) {
320 0         0 push @argv, @glob;
321             }
322             else {
323 0         0 push @argv, $_;
324             }
325             }
326              
327             # no wildcard globbing
328             else {
329 0         0 push @argv, $_;
330             }
331             }
332 0         0 @ARGV = @argv;
333             }
334              
335 0         0 *Char::ord = \&Windows1252::ord;
336 0         0 *Char::ord_ = \&Windows1252::ord_;
337 0         0 *Char::reverse = \&Windows1252::reverse;
338 0         0 *Char::getc = \&Windows1252::getc;
339 0         0 *Char::length = \&Windows1252::length;
340 0         0 *Char::substr = \&Windows1252::substr;
341 0         0 *Char::index = \&Windows1252::index;
342 0         0 *Char::rindex = \&Windows1252::rindex;
343 0         0 *Char::eval = \&Windows1252::eval;
344 0         0 *Char::escape = \&Windows1252::escape;
345 0         0 *Char::escape_token = \&Windows1252::escape_token;
346 0         0 *Char::escape_script = \&Windows1252::escape_script;
347             }
348              
349             # P.230 Care with Prototypes
350             # in Chapter 6: Subroutines
351             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
352             #
353             # If you aren't careful, you can get yourself into trouble with prototypes.
354             # But if you are careful, you can do a lot of neat things with them. This is
355             # all very powerful, of course, and should only be used in moderation to make
356             # the world a better place.
357              
358             # P.332 Care with Prototypes
359             # in Chapter 7: Subroutines
360             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
361             #
362             # If you aren't careful, you can get yourself into trouble with prototypes.
363             # But if you are careful, you can do a lot of neat things with them. This is
364             # all very powerful, of course, and should only be used in moderation to make
365             # the world a better place.
366              
367             #
368             # Prototypes of subroutines
369             #
370 0     0   0 sub unimport {}
371             sub Ewindows1252::split(;$$$);
372             sub Ewindows1252::tr($$$$;$);
373             sub Ewindows1252::chop(@);
374             sub Ewindows1252::index($$;$);
375             sub Ewindows1252::rindex($$;$);
376             sub Ewindows1252::lcfirst(@);
377             sub Ewindows1252::lcfirst_();
378             sub Ewindows1252::lc(@);
379             sub Ewindows1252::lc_();
380             sub Ewindows1252::ucfirst(@);
381             sub Ewindows1252::ucfirst_();
382             sub Ewindows1252::uc(@);
383             sub Ewindows1252::uc_();
384             sub Ewindows1252::fc(@);
385             sub Ewindows1252::fc_();
386             sub Ewindows1252::ignorecase;
387             sub Ewindows1252::classic_character_class;
388             sub Ewindows1252::capture;
389             sub Ewindows1252::chr(;$);
390             sub Ewindows1252::chr_();
391             sub Ewindows1252::glob($);
392             sub Ewindows1252::glob_();
393              
394             sub Windows1252::ord(;$);
395             sub Windows1252::ord_();
396             sub Windows1252::reverse(@);
397             sub Windows1252::getc(;*@);
398             sub Windows1252::length(;$);
399             sub Windows1252::substr($$;$$);
400             sub Windows1252::index($$;$);
401             sub Windows1252::rindex($$;$);
402             sub Windows1252::escape(;$);
403              
404             #
405             # Regexp work
406             #
407 200     200   15280 BEGIN { CORE::eval q{ use vars qw(
  200     200   1275  
  200         344  
  200         78605  
408             $Windows1252::re_a
409             $Windows1252::re_t
410             $Windows1252::re_n
411             $Windows1252::re_r
412             ) } }
413              
414             #
415             # Character class
416             #
417 200     200   32343 BEGIN { CORE::eval q{ use vars qw(
  200     200   1154  
  200         340  
  200         2713546  
418             $dot
419             $dot_s
420             $eD
421             $eS
422             $eW
423             $eH
424             $eV
425             $eR
426             $eN
427             $not_alnum
428             $not_alpha
429             $not_ascii
430             $not_blank
431             $not_cntrl
432             $not_digit
433             $not_graph
434             $not_lower
435             $not_lower_i
436             $not_print
437             $not_punct
438             $not_space
439             $not_upper
440             $not_upper_i
441             $not_word
442             $not_xdigit
443             $eb
444             $eB
445             ) } }
446              
447             ${Ewindows1252::dot} = qr{(?>[^\x0A])};
448             ${Ewindows1252::dot_s} = qr{(?>[\x00-\xFF])};
449             ${Ewindows1252::eD} = qr{(?>[^0-9])};
450              
451             # Vertical tabs are now whitespace
452             # \s in a regex now matches a vertical tab in all circumstances.
453             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
454             # ${Ewindows1252::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
455             # ${Ewindows1252::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
456             ${Ewindows1252::eS} = qr{(?>[^\s])};
457              
458             ${Ewindows1252::eW} = qr{(?>[^0-9A-Z_a-z])};
459             ${Ewindows1252::eH} = qr{(?>[^\x09\x20])};
460             ${Ewindows1252::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
461             ${Ewindows1252::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
462             ${Ewindows1252::eN} = qr{(?>[^\x0A])};
463             ${Ewindows1252::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
464             ${Ewindows1252::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
465             ${Ewindows1252::not_ascii} = qr{(?>[^\x00-\x7F])};
466             ${Ewindows1252::not_blank} = qr{(?>[^\x09\x20])};
467             ${Ewindows1252::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
468             ${Ewindows1252::not_digit} = qr{(?>[^\x30-\x39])};
469             ${Ewindows1252::not_graph} = qr{(?>[^\x21-\x7F])};
470             ${Ewindows1252::not_lower} = qr{(?>[^\x61-\x7A])};
471             ${Ewindows1252::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
472             # ${Ewindows1252::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
473             ${Ewindows1252::not_print} = qr{(?>[^\x20-\x7F])};
474             ${Ewindows1252::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
475             ${Ewindows1252::not_space} = qr{(?>[^\s\x0B])};
476             ${Ewindows1252::not_upper} = qr{(?>[^\x41-\x5A])};
477             ${Ewindows1252::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
478             # ${Ewindows1252::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
479             ${Ewindows1252::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
480             ${Ewindows1252::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
481             ${Ewindows1252::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
482             ${Ewindows1252::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
483              
484             # avoid: Name "Ewindows1252::foo" used only once: possible typo at here.
485             ${Ewindows1252::dot} = ${Ewindows1252::dot};
486             ${Ewindows1252::dot_s} = ${Ewindows1252::dot_s};
487             ${Ewindows1252::eD} = ${Ewindows1252::eD};
488             ${Ewindows1252::eS} = ${Ewindows1252::eS};
489             ${Ewindows1252::eW} = ${Ewindows1252::eW};
490             ${Ewindows1252::eH} = ${Ewindows1252::eH};
491             ${Ewindows1252::eV} = ${Ewindows1252::eV};
492             ${Ewindows1252::eR} = ${Ewindows1252::eR};
493             ${Ewindows1252::eN} = ${Ewindows1252::eN};
494             ${Ewindows1252::not_alnum} = ${Ewindows1252::not_alnum};
495             ${Ewindows1252::not_alpha} = ${Ewindows1252::not_alpha};
496             ${Ewindows1252::not_ascii} = ${Ewindows1252::not_ascii};
497             ${Ewindows1252::not_blank} = ${Ewindows1252::not_blank};
498             ${Ewindows1252::not_cntrl} = ${Ewindows1252::not_cntrl};
499             ${Ewindows1252::not_digit} = ${Ewindows1252::not_digit};
500             ${Ewindows1252::not_graph} = ${Ewindows1252::not_graph};
501             ${Ewindows1252::not_lower} = ${Ewindows1252::not_lower};
502             ${Ewindows1252::not_lower_i} = ${Ewindows1252::not_lower_i};
503             ${Ewindows1252::not_print} = ${Ewindows1252::not_print};
504             ${Ewindows1252::not_punct} = ${Ewindows1252::not_punct};
505             ${Ewindows1252::not_space} = ${Ewindows1252::not_space};
506             ${Ewindows1252::not_upper} = ${Ewindows1252::not_upper};
507             ${Ewindows1252::not_upper_i} = ${Ewindows1252::not_upper_i};
508             ${Ewindows1252::not_word} = ${Ewindows1252::not_word};
509             ${Ewindows1252::not_xdigit} = ${Ewindows1252::not_xdigit};
510             ${Ewindows1252::eb} = ${Ewindows1252::eb};
511             ${Ewindows1252::eB} = ${Ewindows1252::eB};
512              
513             #
514             # Windows-1252 split
515             #
516             sub Ewindows1252::split(;$$$) {
517              
518             # P.794 29.2.161. split
519             # in Chapter 29: Functions
520             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
521              
522             # P.951 split
523             # in Chapter 27: Functions
524             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
525              
526 0     0 0 0 my $pattern = $_[0];
527 0         0 my $string = $_[1];
528 0         0 my $limit = $_[2];
529              
530             # if $pattern is also omitted or is the literal space, " "
531 0 0       0 if (not defined $pattern) {
532 0         0 $pattern = ' ';
533             }
534              
535             # if $string is omitted, the function splits the $_ string
536 0 0       0 if (not defined $string) {
537 0 0       0 if (defined $_) {
538 0         0 $string = $_;
539             }
540             else {
541 0         0 $string = '';
542             }
543             }
544              
545 0         0 my @split = ();
546              
547             # when string is empty
548 0 0       0 if ($string eq '') {
    0          
549              
550             # resulting list value in list context
551 0 0       0 if (wantarray) {
552 0         0 return @split;
553             }
554              
555             # count of substrings in scalar context
556             else {
557 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
558 0         0 @_ = @split;
559 0         0 return scalar @_;
560             }
561             }
562              
563             # split's first argument is more consistently interpreted
564             #
565             # After some changes earlier in v5.17, split's behavior has been simplified:
566             # if the PATTERN argument evaluates to a string containing one space, it is
567             # treated the way that a literal string containing one space once was.
568             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
569              
570             # if $pattern is also omitted or is the literal space, " ", the function splits
571             # on whitespace, /\s+/, after skipping any leading whitespace
572             # (and so on)
573              
574             elsif ($pattern eq ' ') {
575 0 0       0 if (not defined $limit) {
576 0         0 return CORE::split(' ', $string);
577             }
578             else {
579 0         0 return CORE::split(' ', $string, $limit);
580             }
581             }
582              
583             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
584 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
585              
586             # a pattern capable of matching either the null string or something longer than the
587             # null string will split the value of $string into separate characters wherever it
588             # matches the null string between characters
589             # (and so on)
590              
591 0 0       0 if ('' =~ / \A $pattern \z /xms) {
592 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
593 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
594              
595             # P.1024 Appendix W.10 Multibyte Processing
596             # of ISBN 1-56592-224-7 CJKV Information Processing
597             # (and so on)
598              
599             # the //m modifier is assumed when you split on the pattern /^/
600             # (and so on)
601              
602             # V
603 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
604              
605             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
606             # is included in the resulting list, interspersed with the fields that are ordinarily returned
607             # (and so on)
608              
609 0         0 local $@;
610 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
611 0         0 push @split, CORE::eval('$' . $digit);
612             }
613             }
614             }
615              
616             else {
617 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
618              
619             # V
620 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
621 0         0 local $@;
622 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
623 0         0 push @split, CORE::eval('$' . $digit);
624             }
625             }
626             }
627             }
628              
629             elsif ($limit > 0) {
630 0 0       0 if ('' =~ / \A $pattern \z /xms) {
631 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
632 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
633              
634             # V
635 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
636 0         0 local $@;
637 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
638 0         0 push @split, CORE::eval('$' . $digit);
639             }
640             }
641             }
642             }
643             else {
644 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
645 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
646              
647             # V
648 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
649 0         0 local $@;
650 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
651 0         0 push @split, CORE::eval('$' . $digit);
652             }
653             }
654             }
655             }
656             }
657              
658 0 0       0 if (CORE::length($string) > 0) {
659 0         0 push @split, $string;
660             }
661              
662             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
663 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
664 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
665 0         0 pop @split;
666             }
667             }
668              
669             # resulting list value in list context
670 0 0       0 if (wantarray) {
671 0         0 return @split;
672             }
673              
674             # count of substrings in scalar context
675             else {
676 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
677 0         0 @_ = @split;
678 0         0 return scalar @_;
679             }
680             }
681              
682             #
683             # get last subexpression offsets
684             #
685             sub _last_subexpression_offsets {
686 0     0   0 my $pattern = $_[0];
687              
688             # remove comment
689 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
690              
691 0         0 my $modifier = '';
692 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
693 0         0 $modifier = $1;
694 0         0 $modifier =~ s/-[A-Za-z]*//;
695             }
696              
697             # with /x modifier
698 0         0 my @char = ();
699 0 0       0 if ($modifier =~ /x/oxms) {
700 0         0 @char = $pattern =~ /\G((?>
701             [^\\\#\[\(] |
702             \\ $q_char |
703             \# (?>[^\n]*) $ |
704             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
705             \(\? |
706             $q_char
707             ))/oxmsg;
708             }
709              
710             # without /x modifier
711             else {
712 0         0 @char = $pattern =~ /\G((?>
713             [^\\\[\(] |
714             \\ $q_char |
715             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
716             \(\? |
717             $q_char
718             ))/oxmsg;
719             }
720              
721 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
722             }
723              
724             #
725             # Windows-1252 transliteration (tr///)
726             #
727             sub Ewindows1252::tr($$$$;$) {
728              
729 0     0 0 0 my $bind_operator = $_[1];
730 0         0 my $searchlist = $_[2];
731 0         0 my $replacementlist = $_[3];
732 0   0     0 my $modifier = $_[4] || '';
733              
734 0 0       0 if ($modifier =~ /r/oxms) {
735 0 0       0 if ($bind_operator =~ / !~ /oxms) {
736 0         0 croak "Using !~ with tr///r doesn't make sense";
737             }
738             }
739              
740 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
741 0         0 my @searchlist = _charlist_tr($searchlist);
742 0         0 my @replacementlist = _charlist_tr($replacementlist);
743              
744 0         0 my %tr = ();
745 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
746 0 0       0 if (not exists $tr{$searchlist[$i]}) {
747 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
748 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
749             }
750             elsif ($modifier =~ /d/oxms) {
751 0         0 $tr{$searchlist[$i]} = '';
752             }
753             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
754 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
755             }
756             else {
757 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
758             }
759             }
760             }
761              
762 0         0 my $tr = 0;
763 0         0 my $replaced = '';
764 0 0       0 if ($modifier =~ /c/oxms) {
765 0         0 while (defined(my $char = shift @char)) {
766 0 0       0 if (not exists $tr{$char}) {
767 0 0       0 if (defined $replacementlist[0]) {
768 0         0 $replaced .= $replacementlist[0];
769             }
770 0         0 $tr++;
771 0 0       0 if ($modifier =~ /s/oxms) {
772 0   0     0 while (@char and (not exists $tr{$char[0]})) {
773 0         0 shift @char;
774 0         0 $tr++;
775             }
776             }
777             }
778             else {
779 0         0 $replaced .= $char;
780             }
781             }
782             }
783             else {
784 0         0 while (defined(my $char = shift @char)) {
785 0 0       0 if (exists $tr{$char}) {
786 0         0 $replaced .= $tr{$char};
787 0         0 $tr++;
788 0 0       0 if ($modifier =~ /s/oxms) {
789 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
790 0         0 shift @char;
791 0         0 $tr++;
792             }
793             }
794             }
795             else {
796 0         0 $replaced .= $char;
797             }
798             }
799             }
800              
801 0 0       0 if ($modifier =~ /r/oxms) {
802 0         0 return $replaced;
803             }
804             else {
805 0         0 $_[0] = $replaced;
806 0 0       0 if ($bind_operator =~ / !~ /oxms) {
807 0         0 return not $tr;
808             }
809             else {
810 0         0 return $tr;
811             }
812             }
813             }
814              
815             #
816             # Windows-1252 chop
817             #
818             sub Ewindows1252::chop(@) {
819              
820 0     0 0 0 my $chop;
821 0 0       0 if (@_ == 0) {
822 0         0 my @char = /\G (?>$q_char) /oxmsg;
823 0         0 $chop = pop @char;
824 0         0 $_ = join '', @char;
825             }
826             else {
827 0         0 for (@_) {
828 0         0 my @char = /\G (?>$q_char) /oxmsg;
829 0         0 $chop = pop @char;
830 0         0 $_ = join '', @char;
831             }
832             }
833 0         0 return $chop;
834             }
835              
836             #
837             # Windows-1252 index by octet
838             #
839             sub Ewindows1252::index($$;$) {
840              
841 0     0 1 0 my($str,$substr,$position) = @_;
842 0   0     0 $position ||= 0;
843 0         0 my $pos = 0;
844              
845 0         0 while ($pos < CORE::length($str)) {
846 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
847 0 0       0 if ($pos >= $position) {
848 0         0 return $pos;
849             }
850             }
851 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
852 0         0 $pos += CORE::length($1);
853             }
854             else {
855 0         0 $pos += 1;
856             }
857             }
858 0         0 return -1;
859             }
860              
861             #
862             # Windows-1252 reverse index
863             #
864             sub Ewindows1252::rindex($$;$) {
865              
866 0     0 0 0 my($str,$substr,$position) = @_;
867 0   0     0 $position ||= CORE::length($str) - 1;
868 0         0 my $pos = 0;
869 0         0 my $rindex = -1;
870              
871 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
872 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
873 0         0 $rindex = $pos;
874             }
875 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
876 0         0 $pos += CORE::length($1);
877             }
878             else {
879 0         0 $pos += 1;
880             }
881             }
882 0         0 return $rindex;
883             }
884              
885             #
886             # Windows-1252 lower case first with parameter
887             #
888             sub Ewindows1252::lcfirst(@) {
889 0 0   0 0 0 if (@_) {
890 0         0 my $s = shift @_;
891 0 0 0     0 if (@_ and wantarray) {
892 0         0 return Ewindows1252::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
893             }
894             else {
895 0         0 return Ewindows1252::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
896             }
897             }
898             else {
899 0         0 return Ewindows1252::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
900             }
901             }
902              
903             #
904             # Windows-1252 lower case first without parameter
905             #
906             sub Ewindows1252::lcfirst_() {
907 0     0 0 0 return Ewindows1252::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
908             }
909              
910             #
911             # Windows-1252 lower case with parameter
912             #
913             sub Ewindows1252::lc(@) {
914 0 0   0 0 0 if (@_) {
915 0         0 my $s = shift @_;
916 0 0 0     0 if (@_ and wantarray) {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
918             }
919             else {
920 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
921             }
922             }
923             else {
924 0         0 return Ewindows1252::lc_();
925             }
926             }
927              
928             #
929             # Windows-1252 lower case without parameter
930             #
931             sub Ewindows1252::lc_() {
932 0     0 0 0 my $s = $_;
933 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
934             }
935              
936             #
937             # Windows-1252 upper case first with parameter
938             #
939             sub Ewindows1252::ucfirst(@) {
940 0 0   0 0 0 if (@_) {
941 0         0 my $s = shift @_;
942 0 0 0     0 if (@_ and wantarray) {
943 0         0 return Ewindows1252::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
944             }
945             else {
946 0         0 return Ewindows1252::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
947             }
948             }
949             else {
950 0         0 return Ewindows1252::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
951             }
952             }
953              
954             #
955             # Windows-1252 upper case first without parameter
956             #
957             sub Ewindows1252::ucfirst_() {
958 0     0 0 0 return Ewindows1252::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
959             }
960              
961             #
962             # Windows-1252 upper case with parameter
963             #
964             sub Ewindows1252::uc(@) {
965 0 0   0 0 0 if (@_) {
966 0         0 my $s = shift @_;
967 0 0 0     0 if (@_ and wantarray) {
968 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
969             }
970             else {
971 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
972             }
973             }
974             else {
975 0         0 return Ewindows1252::uc_();
976             }
977             }
978              
979             #
980             # Windows-1252 upper case without parameter
981             #
982             sub Ewindows1252::uc_() {
983 0     0 0 0 my $s = $_;
984 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
985             }
986              
987             #
988             # Windows-1252 fold case with parameter
989             #
990             sub Ewindows1252::fc(@) {
991 0 0   0 0 0 if (@_) {
992 0         0 my $s = shift @_;
993 0 0 0     0 if (@_ and wantarray) {
994 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
995             }
996             else {
997 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
998             }
999             }
1000             else {
1001 0         0 return Ewindows1252::fc_();
1002             }
1003             }
1004              
1005             #
1006             # Windows-1252 fold case without parameter
1007             #
1008             sub Ewindows1252::fc_() {
1009 0     0 0 0 my $s = $_;
1010 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1011             }
1012              
1013             #
1014             # Windows-1252 regexp capture
1015             #
1016             {
1017             sub Ewindows1252::capture {
1018 0     0 1 0 return $_[0];
1019             }
1020             }
1021              
1022             #
1023             # Windows-1252 regexp ignore case modifier
1024             #
1025             sub Ewindows1252::ignorecase {
1026              
1027 0     0 0 0 my @string = @_;
1028 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1029              
1030             # ignore case of $scalar or @array
1031 0         0 for my $string (@string) {
1032              
1033             # split regexp
1034 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1035              
1036             # unescape character
1037 0         0 for (my $i=0; $i <= $#char; $i++) {
1038 0 0       0 next if not defined $char[$i];
1039              
1040             # open character class [...]
1041 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1042 0         0 my $left = $i;
1043              
1044             # [] make die "unmatched [] in regexp ...\n"
1045              
1046 0 0       0 if ($char[$i+1] eq ']') {
1047 0         0 $i++;
1048             }
1049              
1050 0         0 while (1) {
1051 0 0       0 if (++$i > $#char) {
1052 0         0 croak "Unmatched [] in regexp";
1053             }
1054 0 0       0 if ($char[$i] eq ']') {
1055 0         0 my $right = $i;
1056 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1057              
1058             # escape character
1059 0         0 for my $char (@charlist) {
1060 0 0       0 if (0) {
1061             }
1062              
1063 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1064 0         0 $char = '\\' . $char;
1065             }
1066             }
1067              
1068             # [...]
1069 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1070              
1071 0         0 $i = $left;
1072 0         0 last;
1073             }
1074             }
1075             }
1076              
1077             # open character class [^...]
1078             elsif ($char[$i] eq '[^') {
1079 0         0 my $left = $i;
1080              
1081             # [^] make die "unmatched [] in regexp ...\n"
1082              
1083 0 0       0 if ($char[$i+1] eq ']') {
1084 0         0 $i++;
1085             }
1086              
1087 0         0 while (1) {
1088 0 0       0 if (++$i > $#char) {
1089 0         0 croak "Unmatched [] in regexp";
1090             }
1091 0 0       0 if ($char[$i] eq ']') {
1092 0         0 my $right = $i;
1093 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1094              
1095             # escape character
1096 0         0 for my $char (@charlist) {
1097 0 0       0 if (0) {
1098             }
1099              
1100 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1101 0         0 $char = '\\' . $char;
1102             }
1103             }
1104              
1105             # [^...]
1106 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1107              
1108 0         0 $i = $left;
1109 0         0 last;
1110             }
1111             }
1112             }
1113              
1114             # rewrite classic character class or escape character
1115             elsif (my $char = classic_character_class($char[$i])) {
1116 0         0 $char[$i] = $char;
1117             }
1118              
1119             # with /i modifier
1120             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1121 0         0 my $uc = Ewindows1252::uc($char[$i]);
1122 0         0 my $fc = Ewindows1252::fc($char[$i]);
1123 0 0       0 if ($uc ne $fc) {
1124 0 0       0 if (CORE::length($fc) == 1) {
1125 0         0 $char[$i] = '[' . $uc . $fc . ']';
1126             }
1127             else {
1128 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1129             }
1130             }
1131             }
1132             }
1133              
1134             # characterize
1135 0         0 for (my $i=0; $i <= $#char; $i++) {
1136 0 0       0 next if not defined $char[$i];
1137              
1138 0 0       0 if (0) {
1139             }
1140              
1141             # quote character before ? + * {
1142 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1143 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1144 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1145             }
1146             }
1147             }
1148              
1149 0         0 $string = join '', @char;
1150             }
1151              
1152             # make regexp string
1153 0         0 return @string;
1154             }
1155              
1156             #
1157             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1158             #
1159             sub Ewindows1252::classic_character_class {
1160 0     0 0 0 my($char) = @_;
1161              
1162             return {
1163 0   0     0 '\D' => '${Ewindows1252::eD}',
1164             '\S' => '${Ewindows1252::eS}',
1165             '\W' => '${Ewindows1252::eW}',
1166             '\d' => '[0-9]',
1167              
1168             # Before Perl 5.6, \s only matched the five whitespace characters
1169             # tab, newline, form-feed, carriage return, and the space character
1170             # itself, which, taken together, is the character class [\t\n\f\r ].
1171              
1172             # Vertical tabs are now whitespace
1173             # \s in a regex now matches a vertical tab in all circumstances.
1174             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1175             # \t \n \v \f \r space
1176             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1177             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1178             '\s' => '\s',
1179              
1180             '\w' => '[0-9A-Z_a-z]',
1181             '\C' => '[\x00-\xFF]',
1182             '\X' => 'X',
1183              
1184             # \h \v \H \V
1185              
1186             # P.114 Character Class Shortcuts
1187             # in Chapter 7: In the World of Regular Expressions
1188             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1189              
1190             # P.357 13.2.3 Whitespace
1191             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1192             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1193             #
1194             # 0x00009 CHARACTER TABULATION h s
1195             # 0x0000a LINE FEED (LF) vs
1196             # 0x0000b LINE TABULATION v
1197             # 0x0000c FORM FEED (FF) vs
1198             # 0x0000d CARRIAGE RETURN (CR) vs
1199             # 0x00020 SPACE h s
1200              
1201             # P.196 Table 5-9. Alphanumeric regex metasymbols
1202             # in Chapter 5. Pattern Matching
1203             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1204              
1205             # (and so on)
1206              
1207             '\H' => '${Ewindows1252::eH}',
1208             '\V' => '${Ewindows1252::eV}',
1209             '\h' => '[\x09\x20]',
1210             '\v' => '[\x0A\x0B\x0C\x0D]',
1211             '\R' => '${Ewindows1252::eR}',
1212              
1213             # \N
1214             #
1215             # http://perldoc.perl.org/perlre.html
1216             # Character Classes and other Special Escapes
1217             # Any character but \n (experimental). Not affected by /s modifier
1218              
1219             '\N' => '${Ewindows1252::eN}',
1220              
1221             # \b \B
1222              
1223             # P.180 Boundaries: The \b and \B Assertions
1224             # in Chapter 5: Pattern Matching
1225             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1226              
1227             # P.219 Boundaries: The \b and \B Assertions
1228             # in Chapter 5: Pattern Matching
1229             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1230              
1231             # \b really means (?:(?<=\w)(?!\w)|(?
1232             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1233             '\b' => '${Ewindows1252::eb}',
1234              
1235             # \B really means (?:(?<=\w)(?=\w)|(?
1236             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1237             '\B' => '${Ewindows1252::eB}',
1238              
1239             }->{$char} || '';
1240             }
1241              
1242             #
1243             # prepare Windows-1252 characters per length
1244             #
1245              
1246             # 1 octet characters
1247             my @chars1 = ();
1248             sub chars1 {
1249 0 0   0 0 0 if (@chars1) {
1250 0         0 return @chars1;
1251             }
1252 0 0       0 if (exists $range_tr{1}) {
1253 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1254 0         0 while (my @range = splice(@ranges,0,1)) {
1255 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1256 0         0 push @chars1, pack 'C', $oct0;
1257             }
1258             }
1259             }
1260 0         0 return @chars1;
1261             }
1262              
1263             # 2 octets characters
1264             my @chars2 = ();
1265             sub chars2 {
1266 0 0   0 0 0 if (@chars2) {
1267 0         0 return @chars2;
1268             }
1269 0 0       0 if (exists $range_tr{2}) {
1270 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1271 0         0 while (my @range = splice(@ranges,0,2)) {
1272 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1273 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1274 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1275             }
1276             }
1277             }
1278             }
1279 0         0 return @chars2;
1280             }
1281              
1282             # 3 octets characters
1283             my @chars3 = ();
1284             sub chars3 {
1285 0 0   0 0 0 if (@chars3) {
1286 0         0 return @chars3;
1287             }
1288 0 0       0 if (exists $range_tr{3}) {
1289 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1290 0         0 while (my @range = splice(@ranges,0,3)) {
1291 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1292 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1293 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1294 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1295             }
1296             }
1297             }
1298             }
1299             }
1300 0         0 return @chars3;
1301             }
1302              
1303             # 4 octets characters
1304             my @chars4 = ();
1305             sub chars4 {
1306 0 0   0 0 0 if (@chars4) {
1307 0         0 return @chars4;
1308             }
1309 0 0       0 if (exists $range_tr{4}) {
1310 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1311 0         0 while (my @range = splice(@ranges,0,4)) {
1312 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1313 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1314 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1315 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1316 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1317             }
1318             }
1319             }
1320             }
1321             }
1322             }
1323 0         0 return @chars4;
1324             }
1325              
1326             #
1327             # Windows-1252 open character list for tr
1328             #
1329             sub _charlist_tr {
1330              
1331 0     0   0 local $_ = shift @_;
1332              
1333             # unescape character
1334 0         0 my @char = ();
1335 0         0 while (not /\G \z/oxmsgc) {
1336 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1337 0         0 push @char, '\-';
1338             }
1339             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(oct $1);
1341             }
1342             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1343 0         0 push @char, CORE::chr(hex $1);
1344             }
1345             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1346 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1347             }
1348             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1349 0         0 push @char, {
1350             '\0' => "\0",
1351             '\n' => "\n",
1352             '\r' => "\r",
1353             '\t' => "\t",
1354             '\f' => "\f",
1355             '\b' => "\x08", # \b means backspace in character class
1356             '\a' => "\a",
1357             '\e' => "\e",
1358             }->{$1};
1359             }
1360             elsif (/\G \\ ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             elsif (/\G ($q_char) /oxmsgc) {
1364 0         0 push @char, $1;
1365             }
1366             }
1367              
1368             # join separated multiple-octet
1369 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1370              
1371             # unescape '-'
1372 0         0 my @i = ();
1373 0         0 for my $i (0 .. $#char) {
1374 0 0       0 if ($char[$i] eq '\-') {
    0          
1375 0         0 $char[$i] = '-';
1376             }
1377             elsif ($char[$i] eq '-') {
1378 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1379 0         0 push @i, $i;
1380             }
1381             }
1382             }
1383              
1384             # open character list (reverse for splice)
1385 0         0 for my $i (CORE::reverse @i) {
1386 0         0 my @range = ();
1387              
1388             # range error
1389 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1390 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1391             }
1392              
1393             # range of multiple-octet code
1394 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1395 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1396 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1397             }
1398             elsif (CORE::length($char[$i+1]) == 2) {
1399 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1400 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1401             }
1402             elsif (CORE::length($char[$i+1]) == 3) {
1403 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1404 0         0 push @range, chars2();
1405 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1406             }
1407             elsif (CORE::length($char[$i+1]) == 4) {
1408 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1409 0         0 push @range, chars2();
1410 0         0 push @range, chars3();
1411 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1412             }
1413             else {
1414 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1415             }
1416             }
1417             elsif (CORE::length($char[$i-1]) == 2) {
1418 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1419 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1420             }
1421             elsif (CORE::length($char[$i+1]) == 3) {
1422 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1423 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1424             }
1425             elsif (CORE::length($char[$i+1]) == 4) {
1426 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1427 0         0 push @range, chars3();
1428 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1429             }
1430             else {
1431 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1432             }
1433             }
1434             elsif (CORE::length($char[$i-1]) == 3) {
1435 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1436 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1437             }
1438             elsif (CORE::length($char[$i+1]) == 4) {
1439 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1440 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1441             }
1442             else {
1443 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1444             }
1445             }
1446             elsif (CORE::length($char[$i-1]) == 4) {
1447 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1448 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1449             }
1450             else {
1451 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1452             }
1453             }
1454             else {
1455 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1456             }
1457              
1458 0         0 splice @char, $i-1, 3, @range;
1459             }
1460              
1461 0         0 return @char;
1462             }
1463              
1464             #
1465             # Windows-1252 open character class
1466             #
1467             sub _cc {
1468 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1469 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1470             }
1471             elsif (scalar(@_) == 1) {
1472 0         0 return sprintf('\x%02X',$_[0]);
1473             }
1474             elsif (scalar(@_) == 2) {
1475 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1476 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1477             }
1478             elsif ($_[0] == $_[1]) {
1479 0         0 return sprintf('\x%02X',$_[0]);
1480             }
1481             elsif (($_[0]+1) == $_[1]) {
1482 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1483             }
1484             else {
1485 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1486             }
1487             }
1488             else {
1489 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1490             }
1491             }
1492              
1493             #
1494             # Windows-1252 octet range
1495             #
1496             sub _octets {
1497 0     0   0 my $length = shift @_;
1498              
1499 0 0       0 if ($length == 1) {
1500 0         0 my($a1) = unpack 'C', $_[0];
1501 0         0 my($z1) = unpack 'C', $_[1];
1502              
1503 0 0       0 if ($a1 > $z1) {
1504 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1505             }
1506              
1507 0 0       0 if ($a1 == $z1) {
    0          
1508 0         0 return sprintf('\x%02X',$a1);
1509             }
1510             elsif (($a1+1) == $z1) {
1511 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1512             }
1513             else {
1514 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1515             }
1516             }
1517             else {
1518 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1519             }
1520             }
1521              
1522             #
1523             # Windows-1252 range regexp
1524             #
1525             sub _range_regexp {
1526 0     0   0 my($length,$first,$last) = @_;
1527              
1528 0         0 my @range_regexp = ();
1529 0 0       0 if (not exists $range_tr{$length}) {
1530 0         0 return @range_regexp;
1531             }
1532              
1533 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1534 0         0 while (my @range = splice(@ranges,0,$length)) {
1535 0         0 my $min = '';
1536 0         0 my $max = '';
1537 0         0 for (my $i=0; $i < $length; $i++) {
1538 0         0 $min .= pack 'C', $range[$i][0];
1539 0         0 $max .= pack 'C', $range[$i][-1];
1540             }
1541              
1542             # min___max
1543             # FIRST_____________LAST
1544             # (nothing)
1545              
1546 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1547             }
1548              
1549             # **********
1550             # min_________max
1551             # FIRST_____________LAST
1552             # **********
1553              
1554             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1555 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1556             }
1557              
1558             # **********************
1559             # min________________max
1560             # FIRST_____________LAST
1561             # **********************
1562              
1563             elsif (($min eq $first) and ($max eq $last)) {
1564 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1565             }
1566              
1567             # *********
1568             # min___max
1569             # FIRST_____________LAST
1570             # *********
1571              
1572             elsif (($first le $min) and ($max le $last)) {
1573 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1574             }
1575              
1576             # **********************
1577             # min__________________________max
1578             # FIRST_____________LAST
1579             # **********************
1580              
1581             elsif (($min le $first) and ($last le $max)) {
1582 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1583             }
1584              
1585             # *********
1586             # min________max
1587             # FIRST_____________LAST
1588             # *********
1589              
1590             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1591 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1592             }
1593              
1594             # min___max
1595             # FIRST_____________LAST
1596             # (nothing)
1597              
1598             elsif ($last lt $min) {
1599             }
1600              
1601             else {
1602 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1603             }
1604             }
1605              
1606 0         0 return @range_regexp;
1607             }
1608              
1609             #
1610             # Windows-1252 open character list for qr and not qr
1611             #
1612             sub _charlist {
1613              
1614 0     0   0 my $modifier = pop @_;
1615 0         0 my @char = @_;
1616              
1617 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1618              
1619             # unescape character
1620 0         0 for (my $i=0; $i <= $#char; $i++) {
1621              
1622             # escape - to ...
1623 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1624 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1625 0         0 $char[$i] = '...';
1626             }
1627             }
1628              
1629             # octal escape sequence
1630             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1631 0         0 $char[$i] = octchr($1);
1632             }
1633              
1634             # hexadecimal escape sequence
1635             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1636 0         0 $char[$i] = hexchr($1);
1637             }
1638              
1639             # \b{...} --> b\{...}
1640             # \B{...} --> B\{...}
1641             # \N{CHARNAME} --> N\{CHARNAME}
1642             # \p{PROPERTY} --> p\{PROPERTY}
1643             # \P{PROPERTY} --> P\{PROPERTY}
1644             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1645 0         0 $char[$i] = $1 . '\\' . $2;
1646             }
1647              
1648             # \p, \P, \X --> p, P, X
1649             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1650 0         0 $char[$i] = $1;
1651             }
1652              
1653             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr oct $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1657 0         0 $char[$i] = CORE::chr hex $1;
1658             }
1659             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1660 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1661             }
1662             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1663 0         0 $char[$i] = {
1664             '\0' => "\0",
1665             '\n' => "\n",
1666             '\r' => "\r",
1667             '\t' => "\t",
1668             '\f' => "\f",
1669             '\b' => "\x08", # \b means backspace in character class
1670             '\a' => "\a",
1671             '\e' => "\e",
1672             '\d' => '[0-9]',
1673              
1674             # Vertical tabs are now whitespace
1675             # \s in a regex now matches a vertical tab in all circumstances.
1676             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1677             # \t \n \v \f \r space
1678             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1679             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1680             '\s' => '\s',
1681              
1682             '\w' => '[0-9A-Z_a-z]',
1683             '\D' => '${Ewindows1252::eD}',
1684             '\S' => '${Ewindows1252::eS}',
1685             '\W' => '${Ewindows1252::eW}',
1686              
1687             '\H' => '${Ewindows1252::eH}',
1688             '\V' => '${Ewindows1252::eV}',
1689             '\h' => '[\x09\x20]',
1690             '\v' => '[\x0A\x0B\x0C\x0D]',
1691             '\R' => '${Ewindows1252::eR}',
1692              
1693             }->{$1};
1694             }
1695              
1696             # POSIX-style character classes
1697             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1698 0         0 $char[$i] = {
1699              
1700             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1701             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1702             '[:^lower:]' => '${Ewindows1252::not_lower_i}',
1703             '[:^upper:]' => '${Ewindows1252::not_upper_i}',
1704              
1705             }->{$1};
1706             }
1707             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1708 0         0 $char[$i] = {
1709              
1710             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1711             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1712             '[:ascii:]' => '[\x00-\x7F]',
1713             '[:blank:]' => '[\x09\x20]',
1714             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1715             '[:digit:]' => '[\x30-\x39]',
1716             '[:graph:]' => '[\x21-\x7F]',
1717             '[:lower:]' => '[\x61-\x7A]',
1718             '[:print:]' => '[\x20-\x7F]',
1719             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1720              
1721             # P.174 POSIX-Style Character Classes
1722             # in Chapter 5: Pattern Matching
1723             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1724              
1725             # P.311 11.2.4 Character Classes and other Special Escapes
1726             # in Chapter 11: perlre: Perl regular expressions
1727             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1728              
1729             # P.210 POSIX-Style Character Classes
1730             # in Chapter 5: Pattern Matching
1731             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1732              
1733             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1734              
1735             '[:upper:]' => '[\x41-\x5A]',
1736             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1737             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1738             '[:^alnum:]' => '${Ewindows1252::not_alnum}',
1739             '[:^alpha:]' => '${Ewindows1252::not_alpha}',
1740             '[:^ascii:]' => '${Ewindows1252::not_ascii}',
1741             '[:^blank:]' => '${Ewindows1252::not_blank}',
1742             '[:^cntrl:]' => '${Ewindows1252::not_cntrl}',
1743             '[:^digit:]' => '${Ewindows1252::not_digit}',
1744             '[:^graph:]' => '${Ewindows1252::not_graph}',
1745             '[:^lower:]' => '${Ewindows1252::not_lower}',
1746             '[:^print:]' => '${Ewindows1252::not_print}',
1747             '[:^punct:]' => '${Ewindows1252::not_punct}',
1748             '[:^space:]' => '${Ewindows1252::not_space}',
1749             '[:^upper:]' => '${Ewindows1252::not_upper}',
1750             '[:^word:]' => '${Ewindows1252::not_word}',
1751             '[:^xdigit:]' => '${Ewindows1252::not_xdigit}',
1752              
1753             }->{$1};
1754             }
1755             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1756 0         0 $char[$i] = $1;
1757             }
1758             }
1759              
1760             # open character list
1761 0         0 my @singleoctet = ();
1762 0         0 my @multipleoctet = ();
1763 0         0 for (my $i=0; $i <= $#char; ) {
1764              
1765             # escaped -
1766 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1767 0         0 $i += 1;
1768 0         0 next;
1769             }
1770              
1771             # make range regexp
1772             elsif ($char[$i] eq '...') {
1773              
1774             # range error
1775 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1776 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1777             }
1778             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1779 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1780 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1781             }
1782             }
1783              
1784             # make range regexp per length
1785 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1786 0         0 my @regexp = ();
1787              
1788             # is first and last
1789 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1790 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1791             }
1792              
1793             # is first
1794             elsif ($length == CORE::length($char[$i-1])) {
1795 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1796             }
1797              
1798             # is inside in first and last
1799             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1800 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1801             }
1802              
1803             # is last
1804             elsif ($length == CORE::length($char[$i+1])) {
1805 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1806             }
1807              
1808             else {
1809 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1810             }
1811              
1812 0 0       0 if ($length == 1) {
1813 0         0 push @singleoctet, @regexp;
1814             }
1815             else {
1816 0         0 push @multipleoctet, @regexp;
1817             }
1818             }
1819              
1820 0         0 $i += 2;
1821             }
1822              
1823             # with /i modifier
1824             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1825 0 0       0 if ($modifier =~ /i/oxms) {
1826 0         0 my $uc = Ewindows1252::uc($char[$i]);
1827 0         0 my $fc = Ewindows1252::fc($char[$i]);
1828 0 0       0 if ($uc ne $fc) {
1829 0 0       0 if (CORE::length($fc) == 1) {
1830 0         0 push @singleoctet, $uc, $fc;
1831             }
1832             else {
1833 0         0 push @singleoctet, $uc;
1834 0         0 push @multipleoctet, $fc;
1835             }
1836             }
1837             else {
1838 0         0 push @singleoctet, $char[$i];
1839             }
1840             }
1841             else {
1842 0         0 push @singleoctet, $char[$i];
1843             }
1844 0         0 $i += 1;
1845             }
1846              
1847             # single character of single octet code
1848             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1849 0         0 push @singleoctet, "\t", "\x20";
1850 0         0 $i += 1;
1851             }
1852             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1853 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1854 0         0 $i += 1;
1855             }
1856             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1857 0         0 push @singleoctet, $char[$i];
1858 0         0 $i += 1;
1859             }
1860              
1861             # single character of multiple-octet code
1862             else {
1863 0         0 push @multipleoctet, $char[$i];
1864 0         0 $i += 1;
1865             }
1866             }
1867              
1868             # quote metachar
1869 0         0 for (@singleoctet) {
1870 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1871 0         0 $_ = '-';
1872             }
1873             elsif (/\A \n \z/oxms) {
1874 0         0 $_ = '\n';
1875             }
1876             elsif (/\A \r \z/oxms) {
1877 0         0 $_ = '\r';
1878             }
1879             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1880 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1881             }
1882             elsif (/\A [\x00-\xFF] \z/oxms) {
1883 0         0 $_ = quotemeta $_;
1884             }
1885             }
1886              
1887             # return character list
1888 0         0 return \@singleoctet, \@multipleoctet;
1889             }
1890              
1891             #
1892             # Windows-1252 octal escape sequence
1893             #
1894             sub octchr {
1895 0     0 0 0 my($octdigit) = @_;
1896              
1897 0         0 my @binary = ();
1898 0         0 for my $octal (split(//,$octdigit)) {
1899 0         0 push @binary, {
1900             '0' => '000',
1901             '1' => '001',
1902             '2' => '010',
1903             '3' => '011',
1904             '4' => '100',
1905             '5' => '101',
1906             '6' => '110',
1907             '7' => '111',
1908             }->{$octal};
1909             }
1910 0         0 my $binary = join '', @binary;
1911              
1912 0         0 my $octchr = {
1913             # 1234567
1914             1 => pack('B*', "0000000$binary"),
1915             2 => pack('B*', "000000$binary"),
1916             3 => pack('B*', "00000$binary"),
1917             4 => pack('B*', "0000$binary"),
1918             5 => pack('B*', "000$binary"),
1919             6 => pack('B*', "00$binary"),
1920             7 => pack('B*', "0$binary"),
1921             0 => pack('B*', "$binary"),
1922              
1923             }->{CORE::length($binary) % 8};
1924              
1925 0         0 return $octchr;
1926             }
1927              
1928             #
1929             # Windows-1252 hexadecimal escape sequence
1930             #
1931             sub hexchr {
1932 0     0 0 0 my($hexdigit) = @_;
1933              
1934 0         0 my $hexchr = {
1935             1 => pack('H*', "0$hexdigit"),
1936             0 => pack('H*', "$hexdigit"),
1937              
1938             }->{CORE::length($_[0]) % 2};
1939              
1940 0         0 return $hexchr;
1941             }
1942              
1943             #
1944             # Windows-1252 open character list for qr
1945             #
1946             sub charlist_qr {
1947              
1948 0     0 0 0 my $modifier = pop @_;
1949 0         0 my @char = @_;
1950              
1951 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1952 0         0 my @singleoctet = @$singleoctet;
1953 0         0 my @multipleoctet = @$multipleoctet;
1954              
1955             # return character list
1956 0 0       0 if (scalar(@singleoctet) >= 1) {
1957              
1958             # with /i modifier
1959 0 0       0 if ($modifier =~ m/i/oxms) {
1960 0         0 my %singleoctet_ignorecase = ();
1961 0         0 for (@singleoctet) {
1962 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1963 0         0 for my $ord (hex($1) .. hex($2)) {
1964 0         0 my $char = CORE::chr($ord);
1965 0         0 my $uc = Ewindows1252::uc($char);
1966 0         0 my $fc = Ewindows1252::fc($char);
1967 0 0       0 if ($uc eq $fc) {
1968 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1969             }
1970             else {
1971 0 0       0 if (CORE::length($fc) == 1) {
1972 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1973 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1974             }
1975             else {
1976 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1977 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1978             }
1979             }
1980             }
1981             }
1982 0 0       0 if ($_ ne '') {
1983 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1984             }
1985             }
1986 0         0 my $i = 0;
1987 0         0 my @singleoctet_ignorecase = ();
1988 0         0 for my $ord (0 .. 255) {
1989 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1990 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1991             }
1992             else {
1993 0         0 $i++;
1994             }
1995             }
1996 0         0 @singleoctet = ();
1997 0         0 for my $range (@singleoctet_ignorecase) {
1998 0 0       0 if (ref $range) {
1999 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2000 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2001             }
2002             elsif (scalar(@{$range}) == 2) {
2003 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2004             }
2005             else {
2006 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2007             }
2008             }
2009             }
2010             }
2011              
2012 0         0 my $not_anchor = '';
2013              
2014 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2015             }
2016 0 0       0 if (scalar(@multipleoctet) >= 2) {
2017 0         0 return '(?:' . join('|', @multipleoctet) . ')';
2018             }
2019             else {
2020 0         0 return $multipleoctet[0];
2021             }
2022             }
2023              
2024             #
2025             # Windows-1252 open character list for not qr
2026             #
2027             sub charlist_not_qr {
2028              
2029 0     0 0 0 my $modifier = pop @_;
2030 0         0 my @char = @_;
2031              
2032 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2033 0         0 my @singleoctet = @$singleoctet;
2034 0         0 my @multipleoctet = @$multipleoctet;
2035              
2036             # with /i modifier
2037 0 0       0 if ($modifier =~ m/i/oxms) {
2038 0         0 my %singleoctet_ignorecase = ();
2039 0         0 for (@singleoctet) {
2040 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2041 0         0 for my $ord (hex($1) .. hex($2)) {
2042 0         0 my $char = CORE::chr($ord);
2043 0         0 my $uc = Ewindows1252::uc($char);
2044 0         0 my $fc = Ewindows1252::fc($char);
2045 0 0       0 if ($uc eq $fc) {
2046 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2047             }
2048             else {
2049 0 0       0 if (CORE::length($fc) == 1) {
2050 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2051 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2052             }
2053             else {
2054 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2055 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2056             }
2057             }
2058             }
2059             }
2060 0 0       0 if ($_ ne '') {
2061 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2062             }
2063             }
2064 0         0 my $i = 0;
2065 0         0 my @singleoctet_ignorecase = ();
2066 0         0 for my $ord (0 .. 255) {
2067 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2068 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2069             }
2070             else {
2071 0         0 $i++;
2072             }
2073             }
2074 0         0 @singleoctet = ();
2075 0         0 for my $range (@singleoctet_ignorecase) {
2076 0 0       0 if (ref $range) {
2077 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2078 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2079             }
2080             elsif (scalar(@{$range}) == 2) {
2081 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2082             }
2083             else {
2084 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2085             }
2086             }
2087             }
2088             }
2089              
2090             # return character list
2091 0 0       0 if (scalar(@multipleoctet) >= 1) {
2092 0 0       0 if (scalar(@singleoctet) >= 1) {
2093              
2094             # any character other than multiple-octet and single octet character class
2095 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2096             }
2097             else {
2098              
2099             # any character other than multiple-octet character class
2100 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2101             }
2102             }
2103             else {
2104 0 0       0 if (scalar(@singleoctet) >= 1) {
2105              
2106             # any character other than single octet character class
2107 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2108             }
2109             else {
2110              
2111             # any character
2112 0         0 return "(?:$your_char)";
2113             }
2114             }
2115             }
2116              
2117             #
2118             # open file in read mode
2119             #
2120             sub _open_r {
2121 200     200   575 my(undef,$file) = @_;
2122 200         754 $file =~ s#\A (\s) #./$1#oxms;
2123 200   33     16261 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2124             open($_[0],"< $file\0");
2125             }
2126              
2127             #
2128             # open file in write mode
2129             #
2130             sub _open_w {
2131 0     0   0 my(undef,$file) = @_;
2132 0         0 $file =~ s#\A (\s) #./$1#oxms;
2133 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2134             open($_[0],"> $file\0");
2135             }
2136              
2137             #
2138             # open file in append mode
2139             #
2140             sub _open_a {
2141 0     0   0 my(undef,$file) = @_;
2142 0         0 $file =~ s#\A (\s) #./$1#oxms;
2143 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2144             open($_[0],">> $file\0");
2145             }
2146              
2147             #
2148             # safe system
2149             #
2150             sub _systemx {
2151              
2152             # P.707 29.2.33. exec
2153             # in Chapter 29: Functions
2154             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2155             #
2156             # Be aware that in older releases of Perl, exec (and system) did not flush
2157             # your output buffer, so you needed to enable command buffering by setting $|
2158             # on one or more filehandles to avoid lost output in the case of exec, or
2159             # misordererd output in the case of system. This situation was largely remedied
2160             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2161              
2162             # P.855 exec
2163             # in Chapter 27: Functions
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165             #
2166             # In very old release of Perl (before v5.6), exec (and system) did not flush
2167             # your output buffer, so you needed to enable command buffering by setting $|
2168             # on one or more filehandles to avoid lost output with exec or misordered
2169             # output with system.
2170              
2171 200     200   673 $| = 1;
2172              
2173             # P.565 23.1.2. Cleaning Up Your Environment
2174             # in Chapter 23: Security
2175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2176              
2177             # P.656 Cleaning Up Your Environment
2178             # in Chapter 20: Security
2179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2180              
2181             # local $ENV{'PATH'} = '.';
2182 200         1879 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2183              
2184             # P.707 29.2.33. exec
2185             # in Chapter 29: Functions
2186             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2187             #
2188             # As we mentioned earlier, exec treats a discrete list of arguments as an
2189             # indication that it should bypass shell processing. However, there is one
2190             # place where you might still get tripped up. The exec call (and system, too)
2191             # will not distinguish between a single scalar argument and an array containing
2192             # only one element.
2193             #
2194             # @args = ("echo surprise"); # just one element in list
2195             # exec @args # still subject to shell escapes
2196             # or die "exec: $!"; # because @args == 1
2197             #
2198             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2199             # first argument as the pathname, which forces the rest of the arguments to be
2200             # interpreted as a list, even if there is only one of them:
2201             #
2202             # exec { $args[0] } @args # safe even with one-argument list
2203             # or die "can't exec @args: $!";
2204              
2205             # P.855 exec
2206             # in Chapter 27: Functions
2207             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2208             #
2209             # As we mentioned earlier, exec treats a discrete list of arguments as a
2210             # directive to bypass shell processing. However, there is one place where
2211             # you might still get tripped up. The exec call (and system, too) cannot
2212             # distinguish between a single scalar argument and an array containing
2213             # only one element.
2214             #
2215             # @args = ("echo surprise"); # just one element in list
2216             # exec @args # still subject to shell escapes
2217             # || die "exec: $!"; # because @args == 1
2218             #
2219             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2220             # argument as the pathname, which forces the rest of the arguments to be
2221             # interpreted as a list, even if there is only one of them:
2222             #
2223             # exec { $args[0] } @args # safe even with one-argument list
2224             # || die "can't exec @args: $!";
2225              
2226 200         408 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         20029359  
2227             }
2228              
2229             #
2230             # Windows-1252 order to character (with parameter)
2231             #
2232             sub Ewindows1252::chr(;$) {
2233              
2234 0 0   0 0   my $c = @_ ? $_[0] : $_;
2235              
2236 0 0         if ($c == 0x00) {
2237 0           return "\x00";
2238             }
2239             else {
2240 0           my @chr = ();
2241 0           while ($c > 0) {
2242 0           unshift @chr, ($c % 0x100);
2243 0           $c = int($c / 0x100);
2244             }
2245 0           return pack 'C*', @chr;
2246             }
2247             }
2248              
2249             #
2250             # Windows-1252 order to character (without parameter)
2251             #
2252             sub Ewindows1252::chr_() {
2253              
2254 0     0 0   my $c = $_;
2255              
2256 0 0         if ($c == 0x00) {
2257 0           return "\x00";
2258             }
2259             else {
2260 0           my @chr = ();
2261 0           while ($c > 0) {
2262 0           unshift @chr, ($c % 0x100);
2263 0           $c = int($c / 0x100);
2264             }
2265 0           return pack 'C*', @chr;
2266             }
2267             }
2268              
2269             #
2270             # Windows-1252 path globbing (with parameter)
2271             #
2272             sub Ewindows1252::glob($) {
2273              
2274 0 0   0 0   if (wantarray) {
2275 0           my @glob = _DOS_like_glob(@_);
2276 0           for my $glob (@glob) {
2277 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2278             }
2279 0           return @glob;
2280             }
2281             else {
2282 0           my $glob = _DOS_like_glob(@_);
2283 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2284 0           return $glob;
2285             }
2286             }
2287              
2288             #
2289             # Windows-1252 path globbing (without parameter)
2290             #
2291             sub Ewindows1252::glob_() {
2292              
2293 0 0   0 0   if (wantarray) {
2294 0           my @glob = _DOS_like_glob();
2295 0           for my $glob (@glob) {
2296 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2297             }
2298 0           return @glob;
2299             }
2300             else {
2301 0           my $glob = _DOS_like_glob();
2302 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2303 0           return $glob;
2304             }
2305             }
2306              
2307             #
2308             # Windows-1252 path globbing via File::DosGlob 1.10
2309             #
2310             # Often I confuse "_dosglob" and "_doglob".
2311             # So, I renamed "_dosglob" to "_DOS_like_glob".
2312             #
2313             my %iter;
2314             my %entries;
2315             sub _DOS_like_glob {
2316              
2317             # context (keyed by second cxix argument provided by core)
2318 0     0     my($expr,$cxix) = @_;
2319              
2320             # glob without args defaults to $_
2321 0 0         $expr = $_ if not defined $expr;
2322              
2323             # represents the current user's home directory
2324             #
2325             # 7.3. Expanding Tildes in Filenames
2326             # in Chapter 7. File Access
2327             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2328             #
2329             # and File::HomeDir, File::HomeDir::Windows module
2330              
2331             # DOS-like system
2332 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2333 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2334 0           { my_home_MSWin32() }oxmse;
2335             }
2336              
2337             # UNIX-like system
2338             else {
2339 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2340 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2341             }
2342              
2343             # assume global context if not provided one
2344 0 0         $cxix = '_G_' if not defined $cxix;
2345 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2346              
2347             # if we're just beginning, do it all first
2348 0 0         if ($iter{$cxix} == 0) {
2349 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2350             }
2351              
2352             # chuck it all out, quick or slow
2353 0 0         if (wantarray) {
2354 0           delete $iter{$cxix};
2355 0           return @{delete $entries{$cxix}};
  0            
2356             }
2357             else {
2358 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2359 0           return shift @{$entries{$cxix}};
  0            
2360             }
2361             else {
2362             # return undef for EOL
2363 0           delete $iter{$cxix};
2364 0           delete $entries{$cxix};
2365 0           return undef;
2366             }
2367             }
2368             }
2369              
2370             #
2371             # Windows-1252 path globbing subroutine
2372             #
2373             sub _do_glob {
2374              
2375 0     0     my($cond,@expr) = @_;
2376 0           my @glob = ();
2377 0           my $fix_drive_relative_paths = 0;
2378              
2379             OUTER:
2380 0           for my $expr (@expr) {
2381 0 0         next OUTER if not defined $expr;
2382 0 0         next OUTER if $expr eq '';
2383              
2384 0           my @matched = ();
2385 0           my @globdir = ();
2386 0           my $head = '.';
2387 0           my $pathsep = '/';
2388 0           my $tail;
2389              
2390             # if argument is within quotes strip em and do no globbing
2391 0 0         if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2392 0           $expr = $1;
2393 0 0         if ($cond eq 'd') {
2394 0 0         if (-d $expr) {
2395 0           push @glob, $expr;
2396             }
2397             }
2398             else {
2399 0 0         if (-e $expr) {
2400 0           push @glob, $expr;
2401             }
2402             }
2403 0           next OUTER;
2404             }
2405              
2406             # wildcards with a drive prefix such as h:*.pm must be changed
2407             # to h:./*.pm to expand correctly
2408 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2409 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2410 0           $fix_drive_relative_paths = 1;
2411             }
2412             }
2413              
2414 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2415 0 0         if ($tail eq '') {
2416 0           push @glob, $expr;
2417 0           next OUTER;
2418             }
2419 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2420 0 0         if (@globdir = _do_glob('d', $head)) {
2421 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2422 0           next OUTER;
2423             }
2424             }
2425 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2426 0           $head .= $pathsep;
2427             }
2428 0           $expr = $tail;
2429             }
2430              
2431             # If file component has no wildcards, we can avoid opendir
2432 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2433 0 0         if ($head eq '.') {
2434 0           $head = '';
2435             }
2436 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2437 0           $head .= $pathsep;
2438             }
2439 0           $head .= $expr;
2440 0 0         if ($cond eq 'd') {
2441 0 0         if (-d $head) {
2442 0           push @glob, $head;
2443             }
2444             }
2445             else {
2446 0 0         if (-e $head) {
2447 0           push @glob, $head;
2448             }
2449             }
2450 0           next OUTER;
2451             }
2452 0 0         opendir(*DIR, $head) or next OUTER;
2453 0           my @leaf = readdir DIR;
2454 0           closedir DIR;
2455              
2456 0 0         if ($head eq '.') {
2457 0           $head = '';
2458             }
2459 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2460 0           $head .= $pathsep;
2461             }
2462              
2463 0           my $pattern = '';
2464 0           while ($expr =~ / \G ($q_char) /oxgc) {
2465 0           my $char = $1;
2466              
2467             # 6.9. Matching Shell Globs as Regular Expressions
2468             # in Chapter 6. Pattern Matching
2469             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2470             # (and so on)
2471              
2472 0 0         if ($char eq '*') {
    0          
    0          
2473 0           $pattern .= "(?:$your_char)*",
2474             }
2475             elsif ($char eq '?') {
2476 0           $pattern .= "(?:$your_char)?", # DOS style
2477             # $pattern .= "(?:$your_char)", # UNIX style
2478             }
2479             elsif ((my $fc = Ewindows1252::fc($char)) ne $char) {
2480 0           $pattern .= $fc;
2481             }
2482             else {
2483 0           $pattern .= quotemeta $char;
2484             }
2485             }
2486 0     0     my $matchsub = sub { Ewindows1252::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2487              
2488             # if ($@) {
2489             # print STDERR "$0: $@\n";
2490             # next OUTER;
2491             # }
2492              
2493             INNER:
2494 0           for my $leaf (@leaf) {
2495 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2496 0           next INNER;
2497             }
2498 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2499 0           next INNER;
2500             }
2501              
2502 0 0         if (&$matchsub($leaf)) {
2503 0           push @matched, "$head$leaf";
2504 0           next INNER;
2505             }
2506              
2507             # [DOS compatibility special case]
2508             # Failed, add a trailing dot and try again, but only...
2509              
2510 0 0 0       if (Ewindows1252::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2511             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2512             Ewindows1252::index($pattern,'\\.') != -1 # pattern has a dot.
2513             ) {
2514 0 0         if (&$matchsub("$leaf.")) {
2515 0           push @matched, "$head$leaf";
2516 0           next INNER;
2517             }
2518             }
2519             }
2520 0 0         if (@matched) {
2521 0           push @glob, @matched;
2522             }
2523             }
2524 0 0         if ($fix_drive_relative_paths) {
2525 0           for my $glob (@glob) {
2526 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2527             }
2528             }
2529 0           return @glob;
2530             }
2531              
2532             #
2533             # Windows-1252 parse line
2534             #
2535             sub _parse_line {
2536              
2537 0     0     my($line) = @_;
2538              
2539 0           $line .= ' ';
2540 0           my @piece = ();
2541 0           while ($line =~ /
2542             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2543             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2544             /oxmsg
2545             ) {
2546 0 0         push @piece, defined($1) ? $1 : $2;
2547             }
2548 0           return @piece;
2549             }
2550              
2551             #
2552             # Windows-1252 parse path
2553             #
2554             sub _parse_path {
2555              
2556 0     0     my($path,$pathsep) = @_;
2557              
2558 0           $path .= '/';
2559 0           my @subpath = ();
2560 0           while ($path =~ /
2561             ((?: [^\/\\] )+?) [\/\\]
2562             /oxmsg
2563             ) {
2564 0           push @subpath, $1;
2565             }
2566              
2567 0           my $tail = pop @subpath;
2568 0           my $head = join $pathsep, @subpath;
2569 0           return $head, $tail;
2570             }
2571              
2572             #
2573             # via File::HomeDir::Windows 1.00
2574             #
2575             sub my_home_MSWin32 {
2576              
2577             # A lot of unix people and unix-derived tools rely on
2578             # the ability to overload HOME. We will support it too
2579             # so that they can replace raw HOME calls with File::HomeDir.
2580 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2581 0           return $ENV{'HOME'};
2582             }
2583              
2584             # Do we have a user profile?
2585             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2586 0           return $ENV{'USERPROFILE'};
2587             }
2588              
2589             # Some Windows use something like $ENV{'HOME'}
2590             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2591 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2592             }
2593              
2594 0           return undef;
2595             }
2596              
2597             #
2598             # via File::HomeDir::Unix 1.00
2599             #
2600             sub my_home {
2601 0     0 0   my $home;
2602              
2603 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2604 0           $home = $ENV{'HOME'};
2605             }
2606              
2607             # This is from the original code, but I'm guessing
2608             # it means "login directory" and exists on some Unixes.
2609             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2610 0           $home = $ENV{'LOGDIR'};
2611             }
2612              
2613             ### More-desperate methods
2614              
2615             # Light desperation on any (Unixish) platform
2616             else {
2617 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2618             }
2619              
2620             # On Unix in general, a non-existant home means "no home"
2621             # For example, "nobody"-like users might use /nonexistant
2622 0 0 0       if (defined $home and ! -d($home)) {
2623 0           $home = undef;
2624             }
2625 0           return $home;
2626             }
2627              
2628             #
2629             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2630             #
2631             sub Ewindows1252::PREMATCH {
2632 0     0 0   return $`;
2633             }
2634              
2635             #
2636             # ${^MATCH}, $MATCH, $& the string that matched
2637             #
2638             sub Ewindows1252::MATCH {
2639 0     0 0   return $&;
2640             }
2641              
2642             #
2643             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2644             #
2645             sub Ewindows1252::POSTMATCH {
2646 0     0 0   return $';
2647             }
2648              
2649             #
2650             # Windows-1252 character to order (with parameter)
2651             #
2652             sub Windows1252::ord(;$) {
2653              
2654 0 0   0 1   local $_ = shift if @_;
2655              
2656 0 0         if (/\A ($q_char) /oxms) {
2657 0           my @ord = unpack 'C*', $1;
2658 0           my $ord = 0;
2659 0           while (my $o = shift @ord) {
2660 0           $ord = $ord * 0x100 + $o;
2661             }
2662 0           return $ord;
2663             }
2664             else {
2665 0           return CORE::ord $_;
2666             }
2667             }
2668              
2669             #
2670             # Windows-1252 character to order (without parameter)
2671             #
2672             sub Windows1252::ord_() {
2673              
2674 0 0   0 0   if (/\A ($q_char) /oxms) {
2675 0           my @ord = unpack 'C*', $1;
2676 0           my $ord = 0;
2677 0           while (my $o = shift @ord) {
2678 0           $ord = $ord * 0x100 + $o;
2679             }
2680 0           return $ord;
2681             }
2682             else {
2683 0           return CORE::ord $_;
2684             }
2685             }
2686              
2687             #
2688             # Windows-1252 reverse
2689             #
2690             sub Windows1252::reverse(@) {
2691              
2692 0 0   0 0   if (wantarray) {
2693 0           return CORE::reverse @_;
2694             }
2695             else {
2696              
2697             # One of us once cornered Larry in an elevator and asked him what
2698             # problem he was solving with this, but he looked as far off into
2699             # the distance as he could in an elevator and said, "It seemed like
2700             # a good idea at the time."
2701              
2702 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2703             }
2704             }
2705              
2706             #
2707             # Windows-1252 getc (with parameter, without parameter)
2708             #
2709             sub Windows1252::getc(;*@) {
2710              
2711 0     0 0   my($package) = caller;
2712 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2713 0 0 0       croak 'Too many arguments for Windows1252::getc' if @_ and not wantarray;
2714              
2715 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2716 0           my $getc = '';
2717 0           for my $length ($length[0] .. $length[-1]) {
2718 0           $getc .= CORE::getc($fh);
2719 0 0         if (exists $range_tr{CORE::length($getc)}) {
2720 0 0         if ($getc =~ /\A ${Ewindows1252::dot_s} \z/oxms) {
2721 0 0         return wantarray ? ($getc,@_) : $getc;
2722             }
2723             }
2724             }
2725 0 0         return wantarray ? ($getc,@_) : $getc;
2726             }
2727              
2728             #
2729             # Windows-1252 length by character
2730             #
2731             sub Windows1252::length(;$) {
2732              
2733 0 0   0 1   local $_ = shift if @_;
2734              
2735 0           local @_ = /\G ($q_char) /oxmsg;
2736 0           return scalar @_;
2737             }
2738              
2739             #
2740             # Windows-1252 substr by character
2741             #
2742             BEGIN {
2743              
2744             # P.232 The lvalue Attribute
2745             # in Chapter 6: Subroutines
2746             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2747              
2748             # P.336 The lvalue Attribute
2749             # in Chapter 7: Subroutines
2750             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2751              
2752             # P.144 8.4 Lvalue subroutines
2753             # in Chapter 8: perlsub: Perl subroutines
2754             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2755              
2756 200 50 0 200 1 129920 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            
2757             # vv----------------------*******
2758             sub Windows1252::substr($$;$$) %s {
2759              
2760             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2761              
2762             # If the substring is beyond either end of the string, substr() returns the undefined
2763             # value and produces a warning. When used as an lvalue, specifying a substring that
2764             # is entirely outside the string raises an exception.
2765             # http://perldoc.perl.org/functions/substr.html
2766              
2767             # A return with no argument returns the scalar value undef in scalar context,
2768             # an empty list () in list context, and (naturally) nothing at all in void
2769             # context.
2770              
2771             my $offset = $_[1];
2772             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2773             return;
2774             }
2775              
2776             # substr($string,$offset,$length,$replacement)
2777             if (@_ == 4) {
2778             my(undef,undef,$length,$replacement) = @_;
2779             my $substr = join '', splice(@char, $offset, $length, $replacement);
2780             $_[0] = join '', @char;
2781              
2782             # return $substr; this doesn't work, don't say "return"
2783             $substr;
2784             }
2785              
2786             # substr($string,$offset,$length)
2787             elsif (@_ == 3) {
2788             my(undef,undef,$length) = @_;
2789             my $octet_offset = 0;
2790             my $octet_length = 0;
2791             if ($offset == 0) {
2792             $octet_offset = 0;
2793             }
2794             elsif ($offset > 0) {
2795             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2796             }
2797             else {
2798             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2799             }
2800             if ($length == 0) {
2801             $octet_length = 0;
2802             }
2803             elsif ($length > 0) {
2804             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2805             }
2806             else {
2807             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset, $octet_length);
2810             }
2811              
2812             # substr($string,$offset)
2813             else {
2814             my $octet_offset = 0;
2815             if ($offset == 0) {
2816             $octet_offset = 0;
2817             }
2818             elsif ($offset > 0) {
2819             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2820             }
2821             else {
2822             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2823             }
2824             CORE::substr($_[0], $octet_offset);
2825             }
2826             }
2827             END
2828             }
2829              
2830             #
2831             # Windows-1252 index by character
2832             #
2833             sub Windows1252::index($$;$) {
2834              
2835 0     0 1   my $index;
2836 0 0         if (@_ == 3) {
2837 0           $index = Ewindows1252::index($_[0], $_[1], CORE::length(Windows1252::substr($_[0], 0, $_[2])));
2838             }
2839             else {
2840 0           $index = Ewindows1252::index($_[0], $_[1]);
2841             }
2842              
2843 0 0         if ($index == -1) {
2844 0           return -1;
2845             }
2846             else {
2847 0           return Windows1252::length(CORE::substr $_[0], 0, $index);
2848             }
2849             }
2850              
2851             #
2852             # Windows-1252 rindex by character
2853             #
2854             sub Windows1252::rindex($$;$) {
2855              
2856 0     0 1   my $rindex;
2857 0 0         if (@_ == 3) {
2858 0           $rindex = Ewindows1252::rindex($_[0], $_[1], CORE::length(Windows1252::substr($_[0], 0, $_[2])));
2859             }
2860             else {
2861 0           $rindex = Ewindows1252::rindex($_[0], $_[1]);
2862             }
2863              
2864 0 0         if ($rindex == -1) {
2865 0           return -1;
2866             }
2867             else {
2868 0           return Windows1252::length(CORE::substr $_[0], 0, $rindex);
2869             }
2870             }
2871              
2872             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2873             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2874 200     200   17299 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   3304  
  200         382  
  200         14390  
2875              
2876             # ord() to ord() or Windows1252::ord()
2877 200     200   17103 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1259  
  200         390  
  200         11432  
2878              
2879             # ord to ord or Windows1252::ord_
2880 200     200   12932 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   1059  
  200         376  
  200         15867  
2881              
2882             # reverse to reverse or Windows1252::reverse
2883 200     200   12965 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1020  
  200         325  
  200         12008  
2884              
2885             # getc to getc or Windows1252::getc
2886 200     200   13965 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   1022  
  200         338  
  200         12107  
2887              
2888             # P.1023 Appendix W.9 Multibyte Anchoring
2889             # of ISBN 1-56592-224-7 CJKV Information Processing
2890              
2891             my $anchor = '';
2892              
2893 200     200   12685 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   1004  
  200         315  
  200         10631745  
2894              
2895             # regexp of nested parens in qqXX
2896              
2897             # P.340 Matching Nested Constructs with Embedded Code
2898             # in Chapter 7: Perl
2899             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2900              
2901             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2902             [^\\()] |
2903             \( (?{$nest++}) |
2904             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2905             \\ [^c] |
2906             \\c[\x40-\x5F] |
2907             [\x00-\xFF]
2908             }xms;
2909              
2910             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2911             [^\\{}] |
2912             \{ (?{$nest++}) |
2913             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2914             \\ [^c] |
2915             \\c[\x40-\x5F] |
2916             [\x00-\xFF]
2917             }xms;
2918              
2919             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2920             [^\\\[\]] |
2921             \[ (?{$nest++}) |
2922             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2923             \\ [^c] |
2924             \\c[\x40-\x5F] |
2925             [\x00-\xFF]
2926             }xms;
2927              
2928             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2929             [^\\<>] |
2930             \< (?{$nest++}) |
2931             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2932             \\ [^c] |
2933             \\c[\x40-\x5F] |
2934             [\x00-\xFF]
2935             }xms;
2936              
2937             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2938             (?: ::)? (?:
2939             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2940             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2941             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2942             ))
2943             }xms;
2944              
2945             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2946             (?: ::)? (?:
2947             (?>[0-9]+) |
2948             [^a-zA-Z_0-9\[\]] |
2949             ^[A-Z] |
2950             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2951             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2952             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2953             ))
2954             }xms;
2955              
2956             my $qq_substr = qr{(?> Char::substr | Windows1252::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2957             }xms;
2958              
2959             # regexp of nested parens in qXX
2960             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2961             [^()] |
2962             \( (?{$nest++}) |
2963             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2964             [\x00-\xFF]
2965             }xms;
2966              
2967             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2968             [^\{\}] |
2969             \{ (?{$nest++}) |
2970             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2971             [\x00-\xFF]
2972             }xms;
2973              
2974             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2975             [^\[\]] |
2976             \[ (?{$nest++}) |
2977             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2978             [\x00-\xFF]
2979             }xms;
2980              
2981             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2982             [^<>] |
2983             \< (?{$nest++}) |
2984             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2985             [\x00-\xFF]
2986             }xms;
2987              
2988             my $matched = '';
2989             my $s_matched = '';
2990              
2991             my $tr_variable = ''; # variable of tr///
2992             my $sub_variable = ''; # variable of s///
2993             my $bind_operator = ''; # =~ or !~
2994              
2995             my @heredoc = (); # here document
2996             my @heredoc_delimiter = ();
2997             my $here_script = ''; # here script
2998              
2999             #
3000             # escape Windows-1252 script
3001             #
3002             sub Windows1252::escape(;$) {
3003 0 0   0 0   local($_) = $_[0] if @_;
3004              
3005             # P.359 The Study Function
3006             # in Chapter 7: Perl
3007             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3008              
3009 0           study $_; # Yes, I studied study yesterday.
3010              
3011             # while all script
3012              
3013             # 6.14. Matching from Where the Last Pattern Left Off
3014             # in Chapter 6. Pattern Matching
3015             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3016             # (and so on)
3017              
3018             # one member of Tag-team
3019             #
3020             # P.128 Start of match (or end of previous match): \G
3021             # P.130 Advanced Use of \G with Perl
3022             # in Chapter 3: Overview of Regular Expression Features and Flavors
3023             # P.255 Use leading anchors
3024             # P.256 Expose ^ and \G at the front expressions
3025             # in Chapter 6: Crafting an Efficient Expression
3026             # P.315 "Tag-team" matching with /gc
3027             # in Chapter 7: Perl
3028             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3029              
3030 0           my $e_script = '';
3031 0           while (not /\G \z/oxgc) { # member
3032 0           $e_script .= Windows1252::escape_token();
3033             }
3034              
3035 0           return $e_script;
3036             }
3037              
3038             #
3039             # escape Windows-1252 token of script
3040             #
3041             sub Windows1252::escape_token {
3042              
3043             # \n output here document
3044              
3045 0     0 0   my $ignore_modules = join('|', qw(
3046             utf8
3047             bytes
3048             charnames
3049             I18N::Japanese
3050             I18N::Collate
3051             I18N::JExt
3052             File::DosGlob
3053             Wild
3054             Wildcard
3055             Japanese
3056             ));
3057              
3058             # another member of Tag-team
3059             #
3060             # P.315 "Tag-team" matching with /gc
3061             # in Chapter 7: Perl
3062             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3063              
3064 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3065 0           my $heredoc = '';
3066 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3067 0           $slash = 'm//';
3068              
3069 0           $heredoc = join '', @heredoc;
3070 0           @heredoc = ();
3071              
3072             # skip here document
3073 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3074 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3075             }
3076 0           @heredoc_delimiter = ();
3077              
3078 0           $here_script = '';
3079             }
3080 0           return "\n" . $heredoc;
3081             }
3082              
3083             # ignore space, comment
3084 0           elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3085              
3086             # if (, elsif (, unless (, while (, until (, given (, and when (
3087              
3088             # given, when
3089              
3090             # P.225 The given Statement
3091             # in Chapter 15: Smart Matching and given-when
3092             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3093              
3094             # P.133 The given Statement
3095             # in Chapter 4: Statements and Declarations
3096             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3097              
3098             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3099 0           $slash = 'm//';
3100 0           return $1;
3101             }
3102              
3103             # scalar variable ($scalar = ...) =~ tr///;
3104             # scalar variable ($scalar = ...) =~ s///;
3105              
3106             # state
3107              
3108             # P.68 Persistent, Private Variables
3109             # in Chapter 4: Subroutines
3110             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3111              
3112             # P.160 Persistent Lexically Scoped Variables: state
3113             # in Chapter 4: Statements and Declarations
3114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3115              
3116             # (and so on)
3117              
3118             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3119 0           my $e_string = e_string($1);
3120              
3121 0 0         if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3122 0           $tr_variable = $e_string . e_string($1);
3123 0           $bind_operator = $2;
3124 0           $slash = 'm//';
3125 0           return '';
3126             }
3127             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3128 0           $sub_variable = $e_string . e_string($1);
3129 0           $bind_operator = $2;
3130 0           $slash = 'm//';
3131 0           return '';
3132             }
3133             else {
3134 0           $slash = 'div';
3135 0           return $e_string;
3136             }
3137             }
3138              
3139             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
3140             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3141 0           $slash = 'div';
3142 0           return q{Ewindows1252::PREMATCH()};
3143             }
3144              
3145             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
3146             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3147 0           $slash = 'div';
3148 0           return q{Ewindows1252::MATCH()};
3149             }
3150              
3151             # $', ${'} --> $', ${'}
3152             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3153 0           $slash = 'div';
3154 0           return $1;
3155             }
3156              
3157             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
3158             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3159 0           $slash = 'div';
3160 0           return q{Ewindows1252::POSTMATCH()};
3161             }
3162              
3163             # scalar variable $scalar =~ tr///;
3164             # scalar variable $scalar =~ s///;
3165             # substr() =~ tr///;
3166             # substr() =~ s///;
3167             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3168 0           my $scalar = e_string($1);
3169              
3170 0 0         if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3171 0           $tr_variable = $scalar;
3172 0           $bind_operator = $1;
3173 0           $slash = 'm//';
3174 0           return '';
3175             }
3176             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3177 0           $sub_variable = $scalar;
3178 0           $bind_operator = $1;
3179 0           $slash = 'm//';
3180 0           return '';
3181             }
3182             else {
3183 0           $slash = 'div';
3184 0           return $scalar;
3185             }
3186             }
3187              
3188             # end of statement
3189             elsif (/\G ( [,;] ) /oxgc) {
3190 0           $slash = 'm//';
3191              
3192             # clear tr/// variable
3193 0           $tr_variable = '';
3194              
3195             # clear s/// variable
3196 0           $sub_variable = '';
3197              
3198 0           $bind_operator = '';
3199              
3200 0           return $1;
3201             }
3202              
3203             # bareword
3204             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3205 0           return $1;
3206             }
3207              
3208             # $0 --> $0
3209             elsif (/\G ( \$ 0 ) /oxmsgc) {
3210 0           $slash = 'div';
3211 0           return $1;
3212             }
3213             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3214 0           $slash = 'div';
3215 0           return $1;
3216             }
3217              
3218             # $$ --> $$
3219             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3220 0           $slash = 'div';
3221 0           return $1;
3222             }
3223              
3224             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3225             # $1, $2, $3 --> $1, $2, $3 otherwise
3226             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3227 0           $slash = 'div';
3228 0           return e_capture($1);
3229             }
3230             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3231 0           $slash = 'div';
3232 0           return e_capture($1);
3233             }
3234              
3235             # $$foo[ ... ] --> $ $foo->[ ... ]
3236             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3237 0           $slash = 'div';
3238 0           return e_capture($1.'->'.$2);
3239             }
3240              
3241             # $$foo{ ... } --> $ $foo->{ ... }
3242             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3243 0           $slash = 'div';
3244 0           return e_capture($1.'->'.$2);
3245             }
3246              
3247             # $$foo
3248             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3249 0           $slash = 'div';
3250 0           return e_capture($1);
3251             }
3252              
3253             # ${ foo }
3254             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3255 0           $slash = 'div';
3256 0           return '${' . $1 . '}';
3257             }
3258              
3259             # ${ ... }
3260             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3261 0           $slash = 'div';
3262 0           return e_capture($1);
3263             }
3264              
3265             # variable or function
3266             # $ @ % & * $ #
3267             elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
3268 0           $slash = 'div';
3269 0           return $1;
3270             }
3271             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3272             # $ @ # \ ' " / ? ( ) [ ] < >
3273             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3274 0           $slash = 'div';
3275 0           return $1;
3276             }
3277              
3278             # while ()
3279             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3280 0           return $1;
3281             }
3282              
3283             # while () --- glob
3284              
3285             # avoid "Error: Runtime exception" of perl version 5.005_03
3286              
3287             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3288 0           return 'while ($_ = Ewindows1252::glob("' . $1 . '"))';
3289             }
3290              
3291             # while (glob)
3292             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3293 0           return 'while ($_ = Ewindows1252::glob_)';
3294             }
3295              
3296             # while (glob(WILDCARD))
3297             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3298 0           return 'while ($_ = Ewindows1252::glob';
3299             }
3300              
3301             # doit if, doit unless, doit while, doit until, doit for, doit when
3302 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3303              
3304             # subroutines of package Ewindows1252
3305 0           elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3306 0           elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3307 0           elsif (/\G \b Windows1252::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3308 0           elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0            
3309 0           elsif (/\G \b Windows1252::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Windows1252::escape'; }
  0            
3310 0           elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3311 0           elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::chop'; }
  0            
3312 0           elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3313 0           elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0            
3314 0           elsif (/\G \b Windows1252::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Windows1252::index'; }
  0            
3315 0           elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::index'; }
  0            
3316 0           elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3317 0           elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0            
3318 0           elsif (/\G \b Windows1252::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Windows1252::rindex'; }
  0            
3319 0           elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::rindex'; }
  0            
3320 0           elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lc'; }
  0            
3321 0           elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lcfirst'; }
  0            
3322 0           elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::uc'; }
  0            
3323 0           elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::ucfirst'; }
  0            
3324 0           elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::fc'; }
  0            
3325              
3326             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3327 0           elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3328 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3329 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3330 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3331 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3332 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3333 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3334              
3335 0           elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3336 0           elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3337 0           elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3338 0           elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3339 0           elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3340 0           elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3341 0           elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3342              
3343             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3344 0           { $slash = 'm//'; return "-s $1"; }
  0            
3345 0           elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3346 0           elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3347 0           elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3348              
3349 0           elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3350 0           elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3351 0           elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::chr'; }
  0            
3352 0           elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3353 0           elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3354 0           elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::glob'; }
  0            
3355 0           elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lc_'; }
  0            
3356 0           elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lcfirst_'; }
  0            
3357 0           elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::uc_'; }
  0            
3358 0           elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::ucfirst_'; }
  0            
3359 0           elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::fc_'; }
  0            
3360 0           elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3361              
3362 0           elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3363 0           elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3364 0           elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::chr_'; }
  0            
3365 0           elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3366 0           elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3367 0           elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::glob_'; }
  0            
3368 0           elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3369 0           elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3370             # split
3371             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3372 0           $slash = 'm//';
3373              
3374 0           my $e = '';
3375 0           while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3376 0           $e .= $1;
3377             }
3378              
3379             # end of split
3380 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ewindows1252::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          
3381              
3382             # split scalar value
3383 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ewindows1252::split' . $e . e_string($1); }
3384              
3385             # split literal space
3386 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ewindows1252::split' . $e . qq {qq$1 $2}; }
3387 0           elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3388 0           elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3389 0           elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3390 0           elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3391 0           elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3392 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ewindows1252::split' . $e . qq {q$1 $2}; }
3393 0           elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3394 0           elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3395 0           elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3396 0           elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3397 0           elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3398 0           elsif (/\G ' [ ] ' /oxgc) { return 'Ewindows1252::split' . $e . qq {' '}; }
3399 0           elsif (/\G " [ ] " /oxgc) { return 'Ewindows1252::split' . $e . qq {" "}; }
3400              
3401             # split qq//
3402             elsif (/\G \b (qq) \b /oxgc) {
3403 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3404             else {
3405 0           while (not /\G \z/oxgc) {
3406 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3407 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3408 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3409 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3410 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3411 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3412 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3413             }
3414 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3415             }
3416             }
3417              
3418             # split qr//
3419             elsif (/\G \b (qr) \b /oxgc) {
3420 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3421             else {
3422 0           while (not /\G \z/oxgc) {
3423 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3424 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3425 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3426 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3427 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3428 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3429 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3430 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3431             }
3432 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3433             }
3434             }
3435              
3436             # split q//
3437             elsif (/\G \b (q) \b /oxgc) {
3438 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3439             else {
3440 0           while (not /\G \z/oxgc) {
3441 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3442 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3443 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3444 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3445 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3446 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3447 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3448             }
3449 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3450             }
3451             }
3452              
3453             # split m//
3454             elsif (/\G \b (m) \b /oxgc) {
3455 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3456             else {
3457 0           while (not /\G \z/oxgc) {
3458 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3459 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3460 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3461 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3462 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3463 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3464 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3465 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3466             }
3467 0           die __FILE__, ": Search pattern not terminated\n";
3468             }
3469             }
3470              
3471             # split ''
3472             elsif (/\G (\') /oxgc) {
3473 0           my $q_string = '';
3474 0           while (not /\G \z/oxgc) {
3475 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3476 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3477 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3478 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3479             }
3480 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3481             }
3482              
3483             # split ""
3484             elsif (/\G (\") /oxgc) {
3485 0           my $qq_string = '';
3486 0           while (not /\G \z/oxgc) {
3487 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3488 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3489 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3490 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3491             }
3492 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3493             }
3494              
3495             # split //
3496             elsif (/\G (\/) /oxgc) {
3497 0           my $regexp = '';
3498 0           while (not /\G \z/oxgc) {
3499 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3500 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3501 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3502 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3503             }
3504 0           die __FILE__, ": Search pattern not terminated\n";
3505             }
3506             }
3507              
3508             # tr/// or y///
3509              
3510             # about [cdsrbB]* (/B modifier)
3511             #
3512             # P.559 appendix C
3513             # of ISBN 4-89052-384-7 Programming perl
3514             # (Japanese title is: Perl puroguramingu)
3515              
3516             elsif (/\G \b ( tr | y ) \b /oxgc) {
3517 0           my $ope = $1;
3518              
3519             # $1 $2 $3 $4 $5 $6
3520 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3521 0           my @tr = ($tr_variable,$2);
3522 0           return e_tr(@tr,'',$4,$6);
3523             }
3524             else {
3525 0           my $e = '';
3526 0           while (not /\G \z/oxgc) {
3527 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3528             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3529 0           my @tr = ($tr_variable,$2);
3530 0           while (not /\G \z/oxgc) {
3531 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3532 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3533 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3534 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3535 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3536 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3537             }
3538 0           die __FILE__, ": Transliteration replacement not terminated\n";
3539             }
3540             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3541 0           my @tr = ($tr_variable,$2);
3542 0           while (not /\G \z/oxgc) {
3543 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3544 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3545 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3546 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3547 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3548 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3549             }
3550 0           die __FILE__, ": Transliteration replacement not terminated\n";
3551             }
3552             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3553 0           my @tr = ($tr_variable,$2);
3554 0           while (not /\G \z/oxgc) {
3555 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3556 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3557 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3558 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3559 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3560 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3561             }
3562 0           die __FILE__, ": Transliteration replacement not terminated\n";
3563             }
3564             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3565 0           my @tr = ($tr_variable,$2);
3566 0           while (not /\G \z/oxgc) {
3567 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3568 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3569 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3570 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3571 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3572 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3573             }
3574 0           die __FILE__, ": Transliteration replacement not terminated\n";
3575             }
3576             # $1 $2 $3 $4 $5 $6
3577             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3578 0           my @tr = ($tr_variable,$2);
3579 0           return e_tr(@tr,'',$4,$6);
3580             }
3581             }
3582 0           die __FILE__, ": Transliteration pattern not terminated\n";
3583             }
3584             }
3585              
3586             # qq//
3587             elsif (/\G \b (qq) \b /oxgc) {
3588 0           my $ope = $1;
3589              
3590             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3591 0 0         if (/\G (\#) /oxgc) { # qq# #
3592 0           my $qq_string = '';
3593 0           while (not /\G \z/oxgc) {
3594 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3595 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3596 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3597 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3598             }
3599 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3600             }
3601              
3602             else {
3603 0           my $e = '';
3604 0           while (not /\G \z/oxgc) {
3605 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3606              
3607             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3608             elsif (/\G (\() /oxgc) { # qq ( )
3609 0           my $qq_string = '';
3610 0           local $nest = 1;
3611 0           while (not /\G \z/oxgc) {
3612 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3613 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3614 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3615             elsif (/\G (\)) /oxgc) {
3616 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3617 0           else { $qq_string .= $1; }
3618             }
3619 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3620             }
3621 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3622             }
3623              
3624             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3625             elsif (/\G (\{) /oxgc) { # qq { }
3626 0           my $qq_string = '';
3627 0           local $nest = 1;
3628 0           while (not /\G \z/oxgc) {
3629 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3630 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3631 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3632             elsif (/\G (\}) /oxgc) {
3633 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3634 0           else { $qq_string .= $1; }
3635             }
3636 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3637             }
3638 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3639             }
3640              
3641             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3642             elsif (/\G (\[) /oxgc) { # qq [ ]
3643 0           my $qq_string = '';
3644 0           local $nest = 1;
3645 0           while (not /\G \z/oxgc) {
3646 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3647 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3648 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3649             elsif (/\G (\]) /oxgc) {
3650 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3651 0           else { $qq_string .= $1; }
3652             }
3653 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3654             }
3655 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3656             }
3657              
3658             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3659             elsif (/\G (\<) /oxgc) { # qq < >
3660 0           my $qq_string = '';
3661 0           local $nest = 1;
3662 0           while (not /\G \z/oxgc) {
3663 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3664 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3665 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3666             elsif (/\G (\>) /oxgc) {
3667 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3668 0           else { $qq_string .= $1; }
3669             }
3670 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3671             }
3672 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3673             }
3674              
3675             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3676             elsif (/\G (\S) /oxgc) { # qq * *
3677 0           my $delimiter = $1;
3678 0           my $qq_string = '';
3679 0           while (not /\G \z/oxgc) {
3680 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3681 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3682 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3683 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3684             }
3685 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3686             }
3687             }
3688 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3689             }
3690             }
3691              
3692             # qr//
3693             elsif (/\G \b (qr) \b /oxgc) {
3694 0           my $ope = $1;
3695 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3696 0           return e_qr($ope,$1,$3,$2,$4);
3697             }
3698             else {
3699 0           my $e = '';
3700 0           while (not /\G \z/oxgc) {
3701 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3702 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3703 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3704 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3705 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3706 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3707 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3708 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3709             }
3710 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3711             }
3712             }
3713              
3714             # qw//
3715             elsif (/\G \b (qw) \b /oxgc) {
3716 0           my $ope = $1;
3717 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3718 0           return e_qw($ope,$1,$3,$2);
3719             }
3720             else {
3721 0           my $e = '';
3722 0           while (not /\G \z/oxgc) {
3723 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3724              
3725 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3726 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3727              
3728 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3729 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3730              
3731 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3732 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3733              
3734 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3735 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3736              
3737 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3738 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3739             }
3740 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3741             }
3742             }
3743              
3744             # qx//
3745             elsif (/\G \b (qx) \b /oxgc) {
3746 0           my $ope = $1;
3747 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3748 0           return e_qq($ope,$1,$3,$2);
3749             }
3750             else {
3751 0           my $e = '';
3752 0           while (not /\G \z/oxgc) {
3753 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3754 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3755 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3756 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3757 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3758 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3759 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3760             }
3761 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3762             }
3763             }
3764              
3765             # q//
3766             elsif (/\G \b (q) \b /oxgc) {
3767 0           my $ope = $1;
3768              
3769             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3770              
3771             # avoid "Error: Runtime exception" of perl version 5.005_03
3772             # (and so on)
3773              
3774 0 0         if (/\G (\#) /oxgc) { # q# #
3775 0           my $q_string = '';
3776 0           while (not /\G \z/oxgc) {
3777 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3778 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3779 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3780 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3781             }
3782 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3783             }
3784              
3785             else {
3786 0           my $e = '';
3787 0           while (not /\G \z/oxgc) {
3788 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3789              
3790             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3791             elsif (/\G (\() /oxgc) { # q ( )
3792 0           my $q_string = '';
3793 0           local $nest = 1;
3794 0           while (not /\G \z/oxgc) {
3795 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3796 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3797 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3798 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3799             elsif (/\G (\)) /oxgc) {
3800 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3801 0           else { $q_string .= $1; }
3802             }
3803 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3804             }
3805 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3806             }
3807              
3808             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3809             elsif (/\G (\{) /oxgc) { # q { }
3810 0           my $q_string = '';
3811 0           local $nest = 1;
3812 0           while (not /\G \z/oxgc) {
3813 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3814 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3815 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3816 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3817             elsif (/\G (\}) /oxgc) {
3818 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3819 0           else { $q_string .= $1; }
3820             }
3821 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3822             }
3823 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3824             }
3825              
3826             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3827             elsif (/\G (\[) /oxgc) { # q [ ]
3828 0           my $q_string = '';
3829 0           local $nest = 1;
3830 0           while (not /\G \z/oxgc) {
3831 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3832 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3833 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3834 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3835             elsif (/\G (\]) /oxgc) {
3836 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3837 0           else { $q_string .= $1; }
3838             }
3839 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3840             }
3841 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3842             }
3843              
3844             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3845             elsif (/\G (\<) /oxgc) { # q < >
3846 0           my $q_string = '';
3847 0           local $nest = 1;
3848 0           while (not /\G \z/oxgc) {
3849 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3850 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3851 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3852 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3853             elsif (/\G (\>) /oxgc) {
3854 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3855 0           else { $q_string .= $1; }
3856             }
3857 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3858             }
3859 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3860             }
3861              
3862             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3863             elsif (/\G (\S) /oxgc) { # q * *
3864 0           my $delimiter = $1;
3865 0           my $q_string = '';
3866 0           while (not /\G \z/oxgc) {
3867 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3868 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3869 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3870 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3871             }
3872 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3873             }
3874             }
3875 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3876             }
3877             }
3878              
3879             # m//
3880             elsif (/\G \b (m) \b /oxgc) {
3881 0           my $ope = $1;
3882 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3883 0           return e_qr($ope,$1,$3,$2,$4);
3884             }
3885             else {
3886 0           my $e = '';
3887 0           while (not /\G \z/oxgc) {
3888 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3889 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3890 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3891 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3892 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3893 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3894 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3895 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3896 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3897             }
3898 0           die __FILE__, ": Search pattern not terminated\n";
3899             }
3900             }
3901              
3902             # s///
3903              
3904             # about [cegimosxpradlunbB]* (/cg modifier)
3905             #
3906             # P.67 Pattern-Matching Operators
3907             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3908              
3909             elsif (/\G \b (s) \b /oxgc) {
3910 0           my $ope = $1;
3911              
3912             # $1 $2 $3 $4 $5 $6
3913 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3914 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3915             }
3916             else {
3917 0           my $e = '';
3918 0           while (not /\G \z/oxgc) {
3919 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3920             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3921 0           my @s = ($1,$2,$3);
3922 0           while (not /\G \z/oxgc) {
3923 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3924             # $1 $2 $3 $4
3925 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934             }
3935 0           die __FILE__, ": Substitution replacement not terminated\n";
3936             }
3937             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3938 0           my @s = ($1,$2,$3);
3939 0           while (not /\G \z/oxgc) {
3940 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3941             # $1 $2 $3 $4
3942 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3943 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3944 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             }
3952 0           die __FILE__, ": Substitution replacement not terminated\n";
3953             }
3954             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3955 0           my @s = ($1,$2,$3);
3956 0           while (not /\G \z/oxgc) {
3957 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3958             # $1 $2 $3 $4
3959 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             }
3967 0           die __FILE__, ": Substitution replacement not terminated\n";
3968             }
3969             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3970 0           my @s = ($1,$2,$3);
3971 0           while (not /\G \z/oxgc) {
3972 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3973             # $1 $2 $3 $4
3974 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3975 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3976 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3977 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3978 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3979 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3980 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3981 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3982 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3983             }
3984 0           die __FILE__, ": Substitution replacement not terminated\n";
3985             }
3986             # $1 $2 $3 $4 $5 $6
3987             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3988 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3989             }
3990             # $1 $2 $3 $4 $5 $6
3991             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3992 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3993             }
3994             # $1 $2 $3 $4 $5 $6
3995             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3996 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3997             }
3998             # $1 $2 $3 $4 $5 $6
3999             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
4000 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
4001             }
4002             }
4003 0           die __FILE__, ": Substitution pattern not terminated\n";
4004             }
4005             }
4006              
4007             # require ignore module
4008 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
4009 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
4010 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
4011              
4012             # use strict; --> use strict; no strict qw(refs);
4013 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
4014 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4015 0           elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4016              
4017             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
4018             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4019 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
4020 0           return "use $1; no strict qw(refs);";
4021             }
4022             else {
4023 0           return "use $1;";
4024             }
4025             }
4026             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4027 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
4028 0           return "use $1; no strict qw(refs);";
4029             }
4030             else {
4031 0           return "use $1;";
4032             }
4033             }
4034              
4035             # ignore use module
4036 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4037 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4038 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4039              
4040             # ignore no module
4041 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4042 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4043 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4044              
4045             # use else
4046 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
4047              
4048             # use else
4049 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
4050              
4051             # ''
4052             elsif (/\G (?
4053 0           my $q_string = '';
4054 0           while (not /\G \z/oxgc) {
4055 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4056 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4057 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4058 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4059             }
4060 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4061             }
4062              
4063             # ""
4064             elsif (/\G (\") /oxgc) {
4065 0           my $qq_string = '';
4066 0           while (not /\G \z/oxgc) {
4067 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4068 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4069 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4070 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4071             }
4072 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4073             }
4074              
4075             # ``
4076             elsif (/\G (\`) /oxgc) {
4077 0           my $qx_string = '';
4078 0           while (not /\G \z/oxgc) {
4079 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4080 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4081 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4082 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4083             }
4084 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4085             }
4086              
4087             # // --- not divide operator (num / num), not defined-or
4088             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4089 0           my $regexp = '';
4090 0           while (not /\G \z/oxgc) {
4091 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4092 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4093 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4094 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4095             }
4096 0           die __FILE__, ": Search pattern not terminated\n";
4097             }
4098              
4099             # ?? --- not conditional operator (condition ? then : else)
4100             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4101 0           my $regexp = '';
4102 0           while (not /\G \z/oxgc) {
4103 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4104 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4105 0           elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4106 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4107             }
4108 0           die __FILE__, ": Search pattern not terminated\n";
4109             }
4110              
4111             # <<>> (a safer ARGV)
4112 0           elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4113              
4114             # << (bit shift) --- not here document
4115 0           elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4116              
4117             # <<'HEREDOC'
4118             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4119 0           $slash = 'm//';
4120 0           my $here_quote = $1;
4121 0           my $delimiter = $2;
4122              
4123             # get here document
4124 0 0         if ($here_script eq '') {
4125 0           $here_script = CORE::substr $_, pos $_;
4126 0           $here_script =~ s/.*?\n//oxm;
4127             }
4128 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4129 0           push @heredoc, $1 . qq{\n$delimiter\n};
4130 0           push @heredoc_delimiter, $delimiter;
4131             }
4132             else {
4133 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4134             }
4135 0           return $here_quote;
4136             }
4137              
4138             # <<\HEREDOC
4139              
4140             # P.66 2.6.6. "Here" Documents
4141             # in Chapter 2: Bits and Pieces
4142             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4143              
4144             # P.73 "Here" Documents
4145             # in Chapter 2: Bits and Pieces
4146             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4147              
4148             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4149 0           $slash = 'm//';
4150 0           my $here_quote = $1;
4151 0           my $delimiter = $2;
4152              
4153             # get here document
4154 0 0         if ($here_script eq '') {
4155 0           $here_script = CORE::substr $_, pos $_;
4156 0           $here_script =~ s/.*?\n//oxm;
4157             }
4158 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4159 0           push @heredoc, $1 . qq{\n$delimiter\n};
4160 0           push @heredoc_delimiter, $delimiter;
4161             }
4162             else {
4163 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4164             }
4165 0           return $here_quote;
4166             }
4167              
4168             # <<"HEREDOC"
4169             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4170 0           $slash = 'm//';
4171 0           my $here_quote = $1;
4172 0           my $delimiter = $2;
4173              
4174             # get here document
4175 0 0         if ($here_script eq '') {
4176 0           $here_script = CORE::substr $_, pos $_;
4177 0           $here_script =~ s/.*?\n//oxm;
4178             }
4179 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4180 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4181 0           push @heredoc_delimiter, $delimiter;
4182             }
4183             else {
4184 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4185             }
4186 0           return $here_quote;
4187             }
4188              
4189             # <
4190             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4191 0           $slash = 'm//';
4192 0           my $here_quote = $1;
4193 0           my $delimiter = $2;
4194              
4195             # get here document
4196 0 0         if ($here_script eq '') {
4197 0           $here_script = CORE::substr $_, pos $_;
4198 0           $here_script =~ s/.*?\n//oxm;
4199             }
4200 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4201 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4202 0           push @heredoc_delimiter, $delimiter;
4203             }
4204             else {
4205 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4206             }
4207 0           return $here_quote;
4208             }
4209              
4210             # <<`HEREDOC`
4211             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4212 0           $slash = 'm//';
4213 0           my $here_quote = $1;
4214 0           my $delimiter = $2;
4215              
4216             # get here document
4217 0 0         if ($here_script eq '') {
4218 0           $here_script = CORE::substr $_, pos $_;
4219 0           $here_script =~ s/.*?\n//oxm;
4220             }
4221 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4222 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4223 0           push @heredoc_delimiter, $delimiter;
4224             }
4225             else {
4226 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228 0           return $here_quote;
4229             }
4230              
4231             # <<= <=> <= < operator
4232             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4233 0           return $1;
4234             }
4235              
4236             #
4237             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4238 0           return $1;
4239             }
4240              
4241             # --- glob
4242              
4243             # avoid "Error: Runtime exception" of perl version 5.005_03
4244              
4245             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4246 0           return 'Ewindows1252::glob("' . $1 . '")';
4247             }
4248              
4249             # __DATA__
4250 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4251              
4252             # __END__
4253 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4254              
4255             # \cD Control-D
4256              
4257             # P.68 2.6.8. Other Literal Tokens
4258             # in Chapter 2: Bits and Pieces
4259             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4260              
4261             # P.76 Other Literal Tokens
4262             # in Chapter 2: Bits and Pieces
4263             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4264              
4265 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4266              
4267             # \cZ Control-Z
4268 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4269              
4270             # any operator before div
4271             elsif (/\G (
4272             -- | \+\+ |
4273             [\)\}\]]
4274              
4275 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4276              
4277             # yada-yada or triple-dot operator
4278             elsif (/\G (
4279             \.\.\.
4280              
4281 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4282              
4283             # any operator before m//
4284              
4285             # //, //= (defined-or)
4286              
4287             # P.164 Logical Operators
4288             # in Chapter 10: More Control Structures
4289             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4290              
4291             # P.119 C-Style Logical (Short-Circuit) Operators
4292             # in Chapter 3: Unary and Binary Operators
4293             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4294              
4295             # (and so on)
4296              
4297             # ~~
4298              
4299             # P.221 The Smart Match Operator
4300             # in Chapter 15: Smart Matching and given-when
4301             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4302              
4303             # P.112 Smartmatch Operator
4304             # in Chapter 3: Unary and Binary Operators
4305             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4306              
4307             # (and so on)
4308              
4309             elsif (/\G ((?>
4310              
4311             !~~ | !~ | != | ! |
4312             %= | % |
4313             &&= | && | &= | &\.= | &\. | & |
4314             -= | -> | - |
4315             :(?>\s*)= |
4316             : |
4317             <<>> |
4318             <<= | <=> | <= | < |
4319             == | => | =~ | = |
4320             >>= | >> | >= | > |
4321             \*\*= | \*\* | \*= | \* |
4322             \+= | \+ |
4323             \.\. | \.= | \. |
4324             \/\/= | \/\/ |
4325             \/= | \/ |
4326             \? |
4327             \\ |
4328             \^= | \^\.= | \^\. | \^ |
4329             \b x= |
4330             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4331             ~~ | ~\. | ~ |
4332             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4333             \b(?: print )\b |
4334              
4335             [,;\(\{\[]
4336              
4337 0           )) /oxgc) { $slash = 'm//'; return $1; }
  0            
4338              
4339             # other any character
4340 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4341              
4342             # system error
4343             else {
4344 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4345             }
4346             }
4347              
4348             # escape Windows-1252 string
4349             sub e_string {
4350 0     0 0   my($string) = @_;
4351 0           my $e_string = '';
4352              
4353 0           local $slash = 'm//';
4354              
4355             # P.1024 Appendix W.10 Multibyte Processing
4356             # of ISBN 1-56592-224-7 CJKV Information Processing
4357             # (and so on)
4358              
4359 0           my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4360              
4361             # without { ... }
4362 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4363 0 0         if ($string !~ /<
4364 0           return $string;
4365             }
4366             }
4367              
4368             E_STRING_LOOP:
4369 0           while ($string !~ /\G \z/oxgc) {
4370 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4371             }
4372              
4373             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ewindows1252::PREMATCH()]}
4374 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4375 0           $e_string .= q{Ewindows1252::PREMATCH()};
4376 0           $slash = 'div';
4377             }
4378              
4379             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ewindows1252::MATCH()]}
4380             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4381 0           $e_string .= q{Ewindows1252::MATCH()};
4382 0           $slash = 'div';
4383             }
4384              
4385             # $', ${'} --> $', ${'}
4386             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4387 0           $e_string .= $1;
4388 0           $slash = 'div';
4389             }
4390              
4391             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ewindows1252::POSTMATCH()]}
4392             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4393 0           $e_string .= q{Ewindows1252::POSTMATCH()};
4394 0           $slash = 'div';
4395             }
4396              
4397             # bareword
4398             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4399 0           $e_string .= $1;
4400 0           $slash = 'div';
4401             }
4402              
4403             # $0 --> $0
4404             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4405 0           $e_string .= $1;
4406 0           $slash = 'div';
4407             }
4408             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4409 0           $e_string .= $1;
4410 0           $slash = 'div';
4411             }
4412              
4413             # $$ --> $$
4414             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4415 0           $e_string .= $1;
4416 0           $slash = 'div';
4417             }
4418              
4419             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4420             # $1, $2, $3 --> $1, $2, $3 otherwise
4421             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4422 0           $e_string .= e_capture($1);
4423 0           $slash = 'div';
4424             }
4425             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4426 0           $e_string .= e_capture($1);
4427 0           $slash = 'div';
4428             }
4429              
4430             # $$foo[ ... ] --> $ $foo->[ ... ]
4431             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4432 0           $e_string .= e_capture($1.'->'.$2);
4433 0           $slash = 'div';
4434             }
4435              
4436             # $$foo{ ... } --> $ $foo->{ ... }
4437             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4438 0           $e_string .= e_capture($1.'->'.$2);
4439 0           $slash = 'div';
4440             }
4441              
4442             # $$foo
4443             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4444 0           $e_string .= e_capture($1);
4445 0           $slash = 'div';
4446             }
4447              
4448             # ${ foo }
4449             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4450 0           $e_string .= '${' . $1 . '}';
4451 0           $slash = 'div';
4452             }
4453              
4454             # ${ ... }
4455             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4456 0           $e_string .= e_capture($1);
4457 0           $slash = 'div';
4458             }
4459              
4460             # variable or function
4461             # $ @ % & * $ #
4462             elsif ($string =~ /\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
4463 0           $e_string .= $1;
4464 0           $slash = 'div';
4465             }
4466             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4467             # $ @ # \ ' " / ? ( ) [ ] < >
4468             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4469 0           $e_string .= $1;
4470 0           $slash = 'div';
4471             }
4472              
4473             # subroutines of package Ewindows1252
4474 0           elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4475 0           elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4476 0           elsif ($string =~ /\G \b Windows1252::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4477 0           elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G \b Windows1252::eval \b /oxgc) { $e_string .= 'eval Windows1252::escape'; $slash = 'm//'; }
  0            
4479 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4480 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ewindows1252::chop'; $slash = 'm//'; }
  0            
4481 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4482 0           elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0            
4483 0           elsif ($string =~ /\G \b Windows1252::index \b /oxgc) { $e_string .= 'Windows1252::index'; $slash = 'm//'; }
  0            
4484 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ewindows1252::index'; $slash = 'm//'; }
  0            
4485 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4486 0           elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0            
4487 0           elsif ($string =~ /\G \b Windows1252::rindex \b /oxgc) { $e_string .= 'Windows1252::rindex'; $slash = 'm//'; }
  0            
4488 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ewindows1252::rindex'; $slash = 'm//'; }
  0            
4489 0           elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::lc'; $slash = 'm//'; }
  0            
4490 0           elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::lcfirst'; $slash = 'm//'; }
  0            
4491 0           elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::uc'; $slash = 'm//'; }
  0            
4492 0           elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::ucfirst'; $slash = 'm//'; }
  0            
4493 0           elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::fc'; $slash = 'm//'; }
  0            
4494              
4495             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4496 0           elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4497 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4498 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4499 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4500 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4501 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4502 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            
4503              
4504 0           elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4505 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4506 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4507 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4508 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4509 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4510 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            
4511              
4512             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4513 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4514 0           elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4515 0           elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4516 0           elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4517              
4518 0           elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4519 0           elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4520 0           elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::chr'; $slash = 'm//'; }
  0            
4521 0           elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4522 0           elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4523 0           elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::glob'; $slash = 'm//'; }
  0            
4524 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ewindows1252::lc_'; $slash = 'm//'; }
  0            
4525 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ewindows1252::lcfirst_'; $slash = 'm//'; }
  0            
4526 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ewindows1252::uc_'; $slash = 'm//'; }
  0            
4527 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ewindows1252::ucfirst_'; $slash = 'm//'; }
  0            
4528 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ewindows1252::fc_'; $slash = 'm//'; }
  0            
4529 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4530              
4531 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4532 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4533 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ewindows1252::chr_'; $slash = 'm//'; }
  0            
4534 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4535 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4536 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ewindows1252::glob_'; $slash = 'm//'; }
  0            
4537 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4538 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4539             # split
4540             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4541 0           $slash = 'm//';
4542              
4543 0           my $e = '';
4544 0           while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4545 0           $e .= $1;
4546             }
4547              
4548             # end of split
4549 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ewindows1252::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          
4550              
4551             # split scalar value
4552 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4553              
4554             # split literal space
4555 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4556 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4557 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4558 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4559 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4560 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4561 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4562 0           elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4563 0           elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4564 0           elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4565 0           elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4566 0           elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4567 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4568 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4569              
4570             # split qq//
4571             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4572 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            
4573             else {
4574 0           while ($string !~ /\G \z/oxgc) {
4575 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4576 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4577 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4578 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4579 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4580 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4581 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            
4582             }
4583 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4584             }
4585             }
4586              
4587             # split qr//
4588             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4589 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4590             else {
4591 0           while ($string !~ /\G \z/oxgc) {
4592 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4593 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4594 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4595 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4596 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4597 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            
4598 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4599 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            
4600             }
4601 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4602             }
4603             }
4604              
4605             # split q//
4606             elsif ($string =~ /\G \b (q) \b /oxgc) {
4607 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0            
  0            
4608             else {
4609 0           while ($string !~ /\G \z/oxgc) {
4610 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4611 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4612 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4613 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4614 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4615 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4616 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            
4617             }
4618 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4619             }
4620             }
4621              
4622             # split m//
4623             elsif ($string =~ /\G \b (m) \b /oxgc) {
4624 0 0         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            
4625             else {
4626 0           while ($string !~ /\G \z/oxgc) {
4627 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4628 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            
4629 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            
4630 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            
4631 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            
4632 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            
4633 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4634 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            
4635             }
4636 0           die __FILE__, ": Search pattern not terminated\n";
4637             }
4638             }
4639              
4640             # split ''
4641             elsif ($string =~ /\G (\') /oxgc) {
4642 0           my $q_string = '';
4643 0           while ($string !~ /\G \z/oxgc) {
4644 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4645 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4646 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4647 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4648             }
4649 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4650             }
4651              
4652             # split ""
4653             elsif ($string =~ /\G (\") /oxgc) {
4654 0           my $qq_string = '';
4655 0           while ($string !~ /\G \z/oxgc) {
4656 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4657 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4658 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4659 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4660             }
4661 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4662             }
4663              
4664             # split //
4665             elsif ($string =~ /\G (\/) /oxgc) {
4666 0           my $regexp = '';
4667 0           while ($string !~ /\G \z/oxgc) {
4668 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4669 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4670 0           elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4671 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4672             }
4673 0           die __FILE__, ": Search pattern not terminated\n";
4674             }
4675             }
4676              
4677             # qq//
4678             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4679 0           my $ope = $1;
4680 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4681 0           $e_string .= e_qq($ope,$1,$3,$2);
4682             }
4683             else {
4684 0           my $e = '';
4685 0           while ($string !~ /\G \z/oxgc) {
4686 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4687 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4688 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4689 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4690 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4691 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4692             }
4693 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4694             }
4695             }
4696              
4697             # qx//
4698             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4699 0           my $ope = $1;
4700 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4701 0           $e_string .= e_qq($ope,$1,$3,$2);
4702             }
4703             else {
4704 0           my $e = '';
4705 0           while ($string !~ /\G \z/oxgc) {
4706 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4707 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4708 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4709 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4710 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4711 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4712 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4713             }
4714 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4715             }
4716             }
4717              
4718             # q//
4719             elsif ($string =~ /\G \b (q) \b /oxgc) {
4720 0           my $ope = $1;
4721 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4722 0           $e_string .= e_q($ope,$1,$3,$2);
4723             }
4724             else {
4725 0           my $e = '';
4726 0           while ($string !~ /\G \z/oxgc) {
4727 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4728 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4729 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4730 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4731 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4732 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            
4733             }
4734 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4735             }
4736             }
4737              
4738             # ''
4739 0           elsif ($string =~ /\G (?
4740              
4741             # ""
4742 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4743              
4744             # ``
4745 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4746              
4747             # <<>> (a safer ARGV)
4748 0           elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4749              
4750             # <<= <=> <= < operator
4751 0           elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4752              
4753             #
4754 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4755              
4756             # --- glob
4757             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4758 0           $e_string .= 'Ewindows1252::glob("' . $1 . '")';
4759             }
4760              
4761             # << (bit shift) --- not here document
4762 0           elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4763              
4764             # <<'HEREDOC'
4765             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4766 0           $slash = 'm//';
4767 0           my $here_quote = $1;
4768 0           my $delimiter = $2;
4769              
4770             # get here document
4771 0 0         if ($here_script eq '') {
4772 0           $here_script = CORE::substr $_, pos $_;
4773 0           $here_script =~ s/.*?\n//oxm;
4774             }
4775 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4776 0           push @heredoc, $1 . qq{\n$delimiter\n};
4777 0           push @heredoc_delimiter, $delimiter;
4778             }
4779             else {
4780 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4781             }
4782 0           $e_string .= $here_quote;
4783             }
4784              
4785             # <<\HEREDOC
4786             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4787 0           $slash = 'm//';
4788 0           my $here_quote = $1;
4789 0           my $delimiter = $2;
4790              
4791             # get here document
4792 0 0         if ($here_script eq '') {
4793 0           $here_script = CORE::substr $_, pos $_;
4794 0           $here_script =~ s/.*?\n//oxm;
4795             }
4796 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4797 0           push @heredoc, $1 . qq{\n$delimiter\n};
4798 0           push @heredoc_delimiter, $delimiter;
4799             }
4800             else {
4801 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4802             }
4803 0           $e_string .= $here_quote;
4804             }
4805              
4806             # <<"HEREDOC"
4807             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4808 0           $slash = 'm//';
4809 0           my $here_quote = $1;
4810 0           my $delimiter = $2;
4811              
4812             # get here document
4813 0 0         if ($here_script eq '') {
4814 0           $here_script = CORE::substr $_, pos $_;
4815 0           $here_script =~ s/.*?\n//oxm;
4816             }
4817 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4818 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4819 0           push @heredoc_delimiter, $delimiter;
4820             }
4821             else {
4822 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4823             }
4824 0           $e_string .= $here_quote;
4825             }
4826              
4827             # <
4828             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4829 0           $slash = 'm//';
4830 0           my $here_quote = $1;
4831 0           my $delimiter = $2;
4832              
4833             # get here document
4834 0 0         if ($here_script eq '') {
4835 0           $here_script = CORE::substr $_, pos $_;
4836 0           $here_script =~ s/.*?\n//oxm;
4837             }
4838 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4839 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4840 0           push @heredoc_delimiter, $delimiter;
4841             }
4842             else {
4843 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4844             }
4845 0           $e_string .= $here_quote;
4846             }
4847              
4848             # <<`HEREDOC`
4849             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4850 0           $slash = 'm//';
4851 0           my $here_quote = $1;
4852 0           my $delimiter = $2;
4853              
4854             # get here document
4855 0 0         if ($here_script eq '') {
4856 0           $here_script = CORE::substr $_, pos $_;
4857 0           $here_script =~ s/.*?\n//oxm;
4858             }
4859 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4860 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4861 0           push @heredoc_delimiter, $delimiter;
4862             }
4863             else {
4864 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4865             }
4866 0           $e_string .= $here_quote;
4867             }
4868              
4869             # any operator before div
4870             elsif ($string =~ /\G (
4871             -- | \+\+ |
4872             [\)\}\]]
4873              
4874 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4875              
4876             # yada-yada or triple-dot operator
4877             elsif ($string =~ /\G (
4878             \.\.\.
4879              
4880 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4881              
4882             # any operator before m//
4883             elsif ($string =~ /\G ((?>
4884              
4885             !~~ | !~ | != | ! |
4886             %= | % |
4887             &&= | && | &= | &\.= | &\. | & |
4888             -= | -> | - |
4889             :(?>\s*)= |
4890             : |
4891             <<>> |
4892             <<= | <=> | <= | < |
4893             == | => | =~ | = |
4894             >>= | >> | >= | > |
4895             \*\*= | \*\* | \*= | \* |
4896             \+= | \+ |
4897             \.\. | \.= | \. |
4898             \/\/= | \/\/ |
4899             \/= | \/ |
4900             \? |
4901             \\ |
4902             \^= | \^\.= | \^\. | \^ |
4903             \b x= |
4904             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4905             ~~ | ~\. | ~ |
4906             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4907             \b(?: print )\b |
4908              
4909             [,;\(\{\[]
4910              
4911 0           )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4912              
4913             # other any character
4914 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4915              
4916             # system error
4917             else {
4918 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4919             }
4920             }
4921              
4922 0           return $e_string;
4923             }
4924              
4925             #
4926             # character class
4927             #
4928             sub character_class {
4929 0     0 0   my($char,$modifier) = @_;
4930              
4931 0 0         if ($char eq '.') {
4932 0 0         if ($modifier =~ /s/) {
4933 0           return '${Ewindows1252::dot_s}';
4934             }
4935             else {
4936 0           return '${Ewindows1252::dot}';
4937             }
4938             }
4939             else {
4940 0           return Ewindows1252::classic_character_class($char);
4941             }
4942             }
4943              
4944             #
4945             # escape capture ($1, $2, $3, ...)
4946             #
4947             sub e_capture {
4948              
4949 0     0 0   return join '', '${', $_[0], '}';
4950             }
4951              
4952             #
4953             # escape transliteration (tr/// or y///)
4954             #
4955             sub e_tr {
4956 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4957 0           my $e_tr = '';
4958 0   0       $modifier ||= '';
4959              
4960 0           $slash = 'div';
4961              
4962             # quote character class 1
4963 0           $charclass = q_tr($charclass);
4964              
4965             # quote character class 2
4966 0           $charclass2 = q_tr($charclass2);
4967              
4968             # /b /B modifier
4969 0 0         if ($modifier =~ tr/bB//d) {
4970 0 0         if ($variable eq '') {
4971 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4972             }
4973             else {
4974 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4975             }
4976             }
4977             else {
4978 0 0         if ($variable eq '') {
4979 0           $e_tr = qq{Ewindows1252::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4980             }
4981             else {
4982 0           $e_tr = qq{Ewindows1252::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4983             }
4984             }
4985              
4986             # clear tr/// variable
4987 0           $tr_variable = '';
4988 0           $bind_operator = '';
4989              
4990 0           return $e_tr;
4991             }
4992              
4993             #
4994             # quote for escape transliteration (tr/// or y///)
4995             #
4996             sub q_tr {
4997 0     0 0   my($charclass) = @_;
4998              
4999             # quote character class
5000 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
5001 0           return e_q('', "'", "'", $charclass); # --> q' '
5002             }
5003             elsif ($charclass !~ /\//oxms) {
5004 0           return e_q('q', '/', '/', $charclass); # --> q/ /
5005             }
5006             elsif ($charclass !~ /\#/oxms) {
5007 0           return e_q('q', '#', '#', $charclass); # --> q# #
5008             }
5009             elsif ($charclass !~ /[\<\>]/oxms) {
5010 0           return e_q('q', '<', '>', $charclass); # --> q< >
5011             }
5012             elsif ($charclass !~ /[\(\)]/oxms) {
5013 0           return e_q('q', '(', ')', $charclass); # --> q( )
5014             }
5015             elsif ($charclass !~ /[\{\}]/oxms) {
5016 0           return e_q('q', '{', '}', $charclass); # --> q{ }
5017             }
5018             else {
5019 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5020 0 0         if ($charclass !~ /\Q$char\E/xms) {
5021 0           return e_q('q', $char, $char, $charclass);
5022             }
5023             }
5024             }
5025              
5026 0           return e_q('q', '{', '}', $charclass);
5027             }
5028              
5029             #
5030             # escape q string (q//, '')
5031             #
5032             sub e_q {
5033 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5034              
5035 0           $slash = 'div';
5036              
5037 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5038             }
5039              
5040             #
5041             # escape qq string (qq//, "", qx//, ``)
5042             #
5043             sub e_qq {
5044 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5045              
5046 0           $slash = 'div';
5047              
5048 0           my $left_e = 0;
5049 0           my $right_e = 0;
5050              
5051             # split regexp
5052 0           my @char = $string =~ /\G((?>
5053             [^\\\$] |
5054             \\x\{ (?>[0-9A-Fa-f]+) \} |
5055             \\o\{ (?>[0-7]+) \} |
5056             \\N\{ (?>[^0-9\}][^\}]*) \} |
5057             \\ $q_char |
5058             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5059             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5060             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5061             \$ (?>\s* [0-9]+) |
5062             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5063             \$ \$ (?![\w\{]) |
5064             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5065             $q_char
5066             ))/oxmsg;
5067              
5068 0           for (my $i=0; $i <= $#char; $i++) {
5069              
5070             # "\L\u" --> "\u\L"
5071 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5072 0           @char[$i,$i+1] = @char[$i+1,$i];
5073             }
5074              
5075             # "\U\l" --> "\l\U"
5076             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5077 0           @char[$i,$i+1] = @char[$i+1,$i];
5078             }
5079              
5080             # octal escape sequence
5081             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5082 0           $char[$i] = Ewindows1252::octchr($1);
5083             }
5084              
5085             # hexadecimal escape sequence
5086             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5087 0           $char[$i] = Ewindows1252::hexchr($1);
5088             }
5089              
5090             # \N{CHARNAME} --> N{CHARNAME}
5091             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5092 0           $char[$i] = $1;
5093             }
5094              
5095 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5096             }
5097              
5098             # \F
5099             #
5100             # P.69 Table 2-6. Translation escapes
5101             # in Chapter 2: Bits and Pieces
5102             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5103             # (and so on)
5104              
5105             # \u \l \U \L \F \Q \E
5106 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5107 0 0         if ($right_e < $left_e) {
5108 0           $char[$i] = '\\' . $char[$i];
5109             }
5110             }
5111             elsif ($char[$i] eq '\u') {
5112              
5113             # "STRING @{[ LIST EXPR ]} MORE STRING"
5114              
5115             # P.257 Other Tricks You Can Do with Hard References
5116             # in Chapter 8: References
5117             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5118              
5119             # P.353 Other Tricks You Can Do with Hard References
5120             # in Chapter 8: References
5121             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5122              
5123             # (and so on)
5124              
5125 0           $char[$i] = '@{[Ewindows1252::ucfirst qq<';
5126 0           $left_e++;
5127             }
5128             elsif ($char[$i] eq '\l') {
5129 0           $char[$i] = '@{[Ewindows1252::lcfirst qq<';
5130 0           $left_e++;
5131             }
5132             elsif ($char[$i] eq '\U') {
5133 0           $char[$i] = '@{[Ewindows1252::uc qq<';
5134 0           $left_e++;
5135             }
5136             elsif ($char[$i] eq '\L') {
5137 0           $char[$i] = '@{[Ewindows1252::lc qq<';
5138 0           $left_e++;
5139             }
5140             elsif ($char[$i] eq '\F') {
5141 0           $char[$i] = '@{[Ewindows1252::fc qq<';
5142 0           $left_e++;
5143             }
5144             elsif ($char[$i] eq '\Q') {
5145 0           $char[$i] = '@{[CORE::quotemeta qq<';
5146 0           $left_e++;
5147             }
5148             elsif ($char[$i] eq '\E') {
5149 0 0         if ($right_e < $left_e) {
5150 0           $char[$i] = '>]}';
5151 0           $right_e++;
5152             }
5153             else {
5154 0           $char[$i] = '';
5155             }
5156             }
5157             elsif ($char[$i] eq '\Q') {
5158 0           while (1) {
5159 0 0         if (++$i > $#char) {
5160 0           last;
5161             }
5162 0 0         if ($char[$i] eq '\E') {
5163 0           last;
5164             }
5165             }
5166             }
5167             elsif ($char[$i] eq '\E') {
5168             }
5169              
5170             # $0 --> $0
5171             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5172             }
5173             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5174             }
5175              
5176             # $$ --> $$
5177             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5178             }
5179              
5180             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5181             # $1, $2, $3 --> $1, $2, $3 otherwise
5182             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5183 0           $char[$i] = e_capture($1);
5184             }
5185             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5186 0           $char[$i] = e_capture($1);
5187             }
5188              
5189             # $$foo[ ... ] --> $ $foo->[ ... ]
5190             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5191 0           $char[$i] = e_capture($1.'->'.$2);
5192             }
5193              
5194             # $$foo{ ... } --> $ $foo->{ ... }
5195             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5196 0           $char[$i] = e_capture($1.'->'.$2);
5197             }
5198              
5199             # $$foo
5200             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5201 0           $char[$i] = e_capture($1);
5202             }
5203              
5204             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
5205             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5206 0           $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
5207             }
5208              
5209             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
5210             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5211 0           $char[$i] = '@{[Ewindows1252::MATCH()]}';
5212             }
5213              
5214             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
5215             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5216 0           $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
5217             }
5218              
5219             # ${ foo } --> ${ foo }
5220             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5221             }
5222              
5223             # ${ ... }
5224             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5225 0           $char[$i] = e_capture($1);
5226             }
5227             }
5228              
5229             # return string
5230 0 0         if ($left_e > $right_e) {
5231 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5232             }
5233 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5234             }
5235              
5236             #
5237             # escape qw string (qw//)
5238             #
5239             sub e_qw {
5240 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5241              
5242 0           $slash = 'div';
5243              
5244             # choice again delimiter
5245 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5246 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5247 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5248             }
5249             elsif (not $octet{')'}) {
5250 0           return join '', $ope, '(', $string, ')';
5251             }
5252             elsif (not $octet{'}'}) {
5253 0           return join '', $ope, '{', $string, '}';
5254             }
5255             elsif (not $octet{']'}) {
5256 0           return join '', $ope, '[', $string, ']';
5257             }
5258             elsif (not $octet{'>'}) {
5259 0           return join '', $ope, '<', $string, '>';
5260             }
5261             else {
5262 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5263 0 0         if (not $octet{$char}) {
5264 0           return join '', $ope, $char, $string, $char;
5265             }
5266             }
5267             }
5268              
5269             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5270 0           my @string = CORE::split(/\s+/, $string);
5271 0           for my $string (@string) {
5272 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5273 0           for my $octet (@octet) {
5274 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5275 0           $octet = '\\' . $1;
5276             }
5277             }
5278 0           $string = join '', @octet;
5279             }
5280 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5281             }
5282              
5283             #
5284             # escape here document (<<"HEREDOC", <
5285             #
5286             sub e_heredoc {
5287 0     0 0   my($string) = @_;
5288              
5289 0           $slash = 'm//';
5290              
5291 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5292              
5293 0           my $left_e = 0;
5294 0           my $right_e = 0;
5295              
5296             # split regexp
5297 0           my @char = $string =~ /\G((?>
5298             [^\\\$] |
5299             \\x\{ (?>[0-9A-Fa-f]+) \} |
5300             \\o\{ (?>[0-7]+) \} |
5301             \\N\{ (?>[^0-9\}][^\}]*) \} |
5302             \\ $q_char |
5303             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5304             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5305             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5306             \$ (?>\s* [0-9]+) |
5307             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5308             \$ \$ (?![\w\{]) |
5309             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5310             $q_char
5311             ))/oxmsg;
5312              
5313 0           for (my $i=0; $i <= $#char; $i++) {
5314              
5315             # "\L\u" --> "\u\L"
5316 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5317 0           @char[$i,$i+1] = @char[$i+1,$i];
5318             }
5319              
5320             # "\U\l" --> "\l\U"
5321             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5322 0           @char[$i,$i+1] = @char[$i+1,$i];
5323             }
5324              
5325             # octal escape sequence
5326             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5327 0           $char[$i] = Ewindows1252::octchr($1);
5328             }
5329              
5330             # hexadecimal escape sequence
5331             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5332 0           $char[$i] = Ewindows1252::hexchr($1);
5333             }
5334              
5335             # \N{CHARNAME} --> N{CHARNAME}
5336             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5337 0           $char[$i] = $1;
5338             }
5339              
5340 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5341             }
5342              
5343             # \u \l \U \L \F \Q \E
5344 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5345 0 0         if ($right_e < $left_e) {
5346 0           $char[$i] = '\\' . $char[$i];
5347             }
5348             }
5349             elsif ($char[$i] eq '\u') {
5350 0           $char[$i] = '@{[Ewindows1252::ucfirst qq<';
5351 0           $left_e++;
5352             }
5353             elsif ($char[$i] eq '\l') {
5354 0           $char[$i] = '@{[Ewindows1252::lcfirst qq<';
5355 0           $left_e++;
5356             }
5357             elsif ($char[$i] eq '\U') {
5358 0           $char[$i] = '@{[Ewindows1252::uc qq<';
5359 0           $left_e++;
5360             }
5361             elsif ($char[$i] eq '\L') {
5362 0           $char[$i] = '@{[Ewindows1252::lc qq<';
5363 0           $left_e++;
5364             }
5365             elsif ($char[$i] eq '\F') {
5366 0           $char[$i] = '@{[Ewindows1252::fc qq<';
5367 0           $left_e++;
5368             }
5369             elsif ($char[$i] eq '\Q') {
5370 0           $char[$i] = '@{[CORE::quotemeta qq<';
5371 0           $left_e++;
5372             }
5373             elsif ($char[$i] eq '\E') {
5374 0 0         if ($right_e < $left_e) {
5375 0           $char[$i] = '>]}';
5376 0           $right_e++;
5377             }
5378             else {
5379 0           $char[$i] = '';
5380             }
5381             }
5382             elsif ($char[$i] eq '\Q') {
5383 0           while (1) {
5384 0 0         if (++$i > $#char) {
5385 0           last;
5386             }
5387 0 0         if ($char[$i] eq '\E') {
5388 0           last;
5389             }
5390             }
5391             }
5392             elsif ($char[$i] eq '\E') {
5393             }
5394              
5395             # $0 --> $0
5396             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5397             }
5398             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5399             }
5400              
5401             # $$ --> $$
5402             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5403             }
5404              
5405             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5406             # $1, $2, $3 --> $1, $2, $3 otherwise
5407             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5408 0           $char[$i] = e_capture($1);
5409             }
5410             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5411 0           $char[$i] = e_capture($1);
5412             }
5413              
5414             # $$foo[ ... ] --> $ $foo->[ ... ]
5415             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5416 0           $char[$i] = e_capture($1.'->'.$2);
5417             }
5418              
5419             # $$foo{ ... } --> $ $foo->{ ... }
5420             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5421 0           $char[$i] = e_capture($1.'->'.$2);
5422             }
5423              
5424             # $$foo
5425             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5426 0           $char[$i] = e_capture($1);
5427             }
5428              
5429             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
5430             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5431 0           $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
5432             }
5433              
5434             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
5435             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5436 0           $char[$i] = '@{[Ewindows1252::MATCH()]}';
5437             }
5438              
5439             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
5440             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5441 0           $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
5442             }
5443              
5444             # ${ foo } --> ${ foo }
5445             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5446             }
5447              
5448             # ${ ... }
5449             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5450 0           $char[$i] = e_capture($1);
5451             }
5452             }
5453              
5454             # return string
5455 0 0         if ($left_e > $right_e) {
5456 0           return join '', @char, '>]}' x ($left_e - $right_e);
5457             }
5458 0           return join '', @char;
5459             }
5460              
5461             #
5462             # escape regexp (m//, qr//)
5463             #
5464             sub e_qr {
5465 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5466 0   0       $modifier ||= '';
5467              
5468 0           $modifier =~ tr/p//d;
5469 0 0         if ($modifier =~ /([adlu])/oxms) {
5470 0           my $line = 0;
5471 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5472 0 0         if ($filename ne __FILE__) {
5473 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5474 0           last;
5475             }
5476             }
5477 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5478             }
5479              
5480 0           $slash = 'div';
5481              
5482             # literal null string pattern
5483 0 0         if ($string eq '') {
    0          
5484 0           $modifier =~ tr/bB//d;
5485 0           $modifier =~ tr/i//d;
5486 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5487             }
5488              
5489             # /b /B modifier
5490             elsif ($modifier =~ tr/bB//d) {
5491              
5492             # choice again delimiter
5493 0 0         if ($delimiter =~ / [\@:] /oxms) {
5494 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5495 0           my %octet = map {$_ => 1} @char;
  0            
5496 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5497 0           $delimiter = '(';
5498 0           $end_delimiter = ')';
5499             }
5500             elsif (not $octet{'}'}) {
5501 0           $delimiter = '{';
5502 0           $end_delimiter = '}';
5503             }
5504             elsif (not $octet{']'}) {
5505 0           $delimiter = '[';
5506 0           $end_delimiter = ']';
5507             }
5508             elsif (not $octet{'>'}) {
5509 0           $delimiter = '<';
5510 0           $end_delimiter = '>';
5511             }
5512             else {
5513 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5514 0 0         if (not $octet{$char}) {
5515 0           $delimiter = $char;
5516 0           $end_delimiter = $char;
5517 0           last;
5518             }
5519             }
5520             }
5521             }
5522              
5523 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5524 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5525             }
5526             else {
5527 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5528             }
5529             }
5530              
5531 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5532 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5533              
5534             # split regexp
5535 0           my @char = $string =~ /\G((?>
5536             [^\\\$\@\[\(] |
5537             \\x (?>[0-9A-Fa-f]{1,2}) |
5538             \\ (?>[0-7]{2,3}) |
5539             \\c [\x40-\x5F] |
5540             \\x\{ (?>[0-9A-Fa-f]+) \} |
5541             \\o\{ (?>[0-7]+) \} |
5542             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5543             \\ $q_char |
5544             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5545             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5546             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5547             [\$\@] $qq_variable |
5548             \$ (?>\s* [0-9]+) |
5549             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5550             \$ \$ (?![\w\{]) |
5551             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5552             \[\^ |
5553             \[\: (?>[a-z]+) :\] |
5554             \[\:\^ (?>[a-z]+) :\] |
5555             \(\? |
5556             $q_char
5557             ))/oxmsg;
5558              
5559             # choice again delimiter
5560 0 0         if ($delimiter =~ / [\@:] /oxms) {
5561 0           my %octet = map {$_ => 1} @char;
  0            
5562 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5563 0           $delimiter = '(';
5564 0           $end_delimiter = ')';
5565             }
5566             elsif (not $octet{'}'}) {
5567 0           $delimiter = '{';
5568 0           $end_delimiter = '}';
5569             }
5570             elsif (not $octet{']'}) {
5571 0           $delimiter = '[';
5572 0           $end_delimiter = ']';
5573             }
5574             elsif (not $octet{'>'}) {
5575 0           $delimiter = '<';
5576 0           $end_delimiter = '>';
5577             }
5578             else {
5579 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5580 0 0         if (not $octet{$char}) {
5581 0           $delimiter = $char;
5582 0           $end_delimiter = $char;
5583 0           last;
5584             }
5585             }
5586             }
5587             }
5588              
5589 0           my $left_e = 0;
5590 0           my $right_e = 0;
5591 0           for (my $i=0; $i <= $#char; $i++) {
5592              
5593             # "\L\u" --> "\u\L"
5594 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
5595 0           @char[$i,$i+1] = @char[$i+1,$i];
5596             }
5597              
5598             # "\U\l" --> "\l\U"
5599             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5600 0           @char[$i,$i+1] = @char[$i+1,$i];
5601             }
5602              
5603             # octal escape sequence
5604             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5605 0           $char[$i] = Ewindows1252::octchr($1);
5606             }
5607              
5608             # hexadecimal escape sequence
5609             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5610 0           $char[$i] = Ewindows1252::hexchr($1);
5611             }
5612              
5613             # \b{...} --> b\{...}
5614             # \B{...} --> B\{...}
5615             # \N{CHARNAME} --> N\{CHARNAME}
5616             # \p{PROPERTY} --> p\{PROPERTY}
5617             # \P{PROPERTY} --> P\{PROPERTY}
5618             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5619 0           $char[$i] = $1 . '\\' . $2;
5620             }
5621              
5622             # \p, \P, \X --> p, P, X
5623             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5624 0           $char[$i] = $1;
5625             }
5626              
5627 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5628             }
5629              
5630             # join separated multiple-octet
5631 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5632 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        
5633 0           $char[$i] .= join '', splice @char, $i+1, 3;
5634             }
5635             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
5636 0           $char[$i] .= join '', splice @char, $i+1, 2;
5637             }
5638             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
5639 0           $char[$i] .= join '', splice @char, $i+1, 1;
5640             }
5641             }
5642              
5643             # open character class [...]
5644             elsif ($char[$i] eq '[') {
5645 0           my $left = $i;
5646              
5647             # [] make die "Unmatched [] in regexp ...\n"
5648             # (and so on)
5649              
5650 0 0         if ($char[$i+1] eq ']') {
5651 0           $i++;
5652             }
5653              
5654 0           while (1) {
5655 0 0         if (++$i > $#char) {
5656 0           die __FILE__, ": Unmatched [] in regexp\n";
5657             }
5658 0 0         if ($char[$i] eq ']') {
5659 0           my $right = $i;
5660              
5661             # [...]
5662 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5663 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1252::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5664             }
5665             else {
5666 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
5667             }
5668              
5669 0           $i = $left;
5670 0           last;
5671             }
5672             }
5673             }
5674              
5675             # open character class [^...]
5676             elsif ($char[$i] eq '[^') {
5677 0           my $left = $i;
5678              
5679             # [^] make die "Unmatched [] in regexp ...\n"
5680             # (and so on)
5681              
5682 0 0         if ($char[$i+1] eq ']') {
5683 0           $i++;
5684             }
5685              
5686 0           while (1) {
5687 0 0         if (++$i > $#char) {
5688 0           die __FILE__, ": Unmatched [] in regexp\n";
5689             }
5690 0 0         if ($char[$i] eq ']') {
5691 0           my $right = $i;
5692              
5693             # [^...]
5694 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5695 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1252::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5696             }
5697             else {
5698 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5699             }
5700              
5701 0           $i = $left;
5702 0           last;
5703             }
5704             }
5705             }
5706              
5707             # rewrite character class or escape character
5708             elsif (my $char = character_class($char[$i],$modifier)) {
5709 0           $char[$i] = $char;
5710             }
5711              
5712             # /i modifier
5713             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
5714 0 0         if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
5715 0           $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
5716             }
5717             else {
5718 0           $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
5719             }
5720             }
5721              
5722             # \u \l \U \L \F \Q \E
5723             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5724 0 0         if ($right_e < $left_e) {
5725 0           $char[$i] = '\\' . $char[$i];
5726             }
5727             }
5728             elsif ($char[$i] eq '\u') {
5729 0           $char[$i] = '@{[Ewindows1252::ucfirst qq<';
5730 0           $left_e++;
5731             }
5732             elsif ($char[$i] eq '\l') {
5733 0           $char[$i] = '@{[Ewindows1252::lcfirst qq<';
5734 0           $left_e++;
5735             }
5736             elsif ($char[$i] eq '\U') {
5737 0           $char[$i] = '@{[Ewindows1252::uc qq<';
5738 0           $left_e++;
5739             }
5740             elsif ($char[$i] eq '\L') {
5741 0           $char[$i] = '@{[Ewindows1252::lc qq<';
5742 0           $left_e++;
5743             }
5744             elsif ($char[$i] eq '\F') {
5745 0           $char[$i] = '@{[Ewindows1252::fc qq<';
5746 0           $left_e++;
5747             }
5748             elsif ($char[$i] eq '\Q') {
5749 0           $char[$i] = '@{[CORE::quotemeta qq<';
5750 0           $left_e++;
5751             }
5752             elsif ($char[$i] eq '\E') {
5753 0 0         if ($right_e < $left_e) {
5754 0           $char[$i] = '>]}';
5755 0           $right_e++;
5756             }
5757             else {
5758 0           $char[$i] = '';
5759             }
5760             }
5761             elsif ($char[$i] eq '\Q') {
5762 0           while (1) {
5763 0 0         if (++$i > $#char) {
5764 0           last;
5765             }
5766 0 0         if ($char[$i] eq '\E') {
5767 0           last;
5768             }
5769             }
5770             }
5771             elsif ($char[$i] eq '\E') {
5772             }
5773              
5774             # $0 --> $0
5775             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5776 0 0         if ($ignorecase) {
5777 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5778             }
5779             }
5780             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5781 0 0         if ($ignorecase) {
5782 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5783             }
5784             }
5785              
5786             # $$ --> $$
5787             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5788             }
5789              
5790             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5791             # $1, $2, $3 --> $1, $2, $3 otherwise
5792             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5793 0           $char[$i] = e_capture($1);
5794 0 0         if ($ignorecase) {
5795 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5796             }
5797             }
5798             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5799 0           $char[$i] = e_capture($1);
5800 0 0         if ($ignorecase) {
5801 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5802             }
5803             }
5804              
5805             # $$foo[ ... ] --> $ $foo->[ ... ]
5806             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5807 0           $char[$i] = e_capture($1.'->'.$2);
5808 0 0         if ($ignorecase) {
5809 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5810             }
5811             }
5812              
5813             # $$foo{ ... } --> $ $foo->{ ... }
5814             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5815 0           $char[$i] = e_capture($1.'->'.$2);
5816 0 0         if ($ignorecase) {
5817 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5818             }
5819             }
5820              
5821             # $$foo
5822             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5823 0           $char[$i] = e_capture($1);
5824 0 0         if ($ignorecase) {
5825 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5826             }
5827             }
5828              
5829             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
5830             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5831 0 0         if ($ignorecase) {
5832 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::PREMATCH())]}';
5833             }
5834             else {
5835 0           $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
5836             }
5837             }
5838              
5839             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
5840             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5841 0 0         if ($ignorecase) {
5842 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::MATCH())]}';
5843             }
5844             else {
5845 0           $char[$i] = '@{[Ewindows1252::MATCH()]}';
5846             }
5847             }
5848              
5849             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
5850             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5851 0 0         if ($ignorecase) {
5852 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::POSTMATCH())]}';
5853             }
5854             else {
5855 0           $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
5856             }
5857             }
5858              
5859             # ${ foo }
5860             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5861 0 0         if ($ignorecase) {
5862 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5863             }
5864             }
5865              
5866             # ${ ... }
5867             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5868 0           $char[$i] = e_capture($1);
5869 0 0         if ($ignorecase) {
5870 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5871             }
5872             }
5873              
5874             # $scalar or @array
5875             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5876 0           $char[$i] = e_string($char[$i]);
5877 0 0         if ($ignorecase) {
5878 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
5879             }
5880             }
5881              
5882             # quote character before ? + * {
5883             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5884 0 0 0       if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5885             }
5886             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5887 0           my $char = $char[$i-1];
5888 0 0         if ($char[$i] eq '{') {
5889 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5890             }
5891             else {
5892 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5893             }
5894             }
5895             else {
5896 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5897             }
5898             }
5899             }
5900              
5901             # make regexp string
5902 0           $modifier =~ tr/i//d;
5903 0 0         if ($left_e > $right_e) {
5904 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5905 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5906             }
5907             else {
5908 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5909             }
5910             }
5911 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5912 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5913             }
5914             else {
5915 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5916             }
5917             }
5918              
5919             #
5920             # double quote stuff
5921             #
5922             sub qq_stuff {
5923 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5924              
5925             # scalar variable or array variable
5926 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5927 0           return $stuff;
5928             }
5929              
5930             # quote by delimiter
5931 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5932 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5933 0 0         next if $char eq $delimiter;
5934 0 0         next if $char eq $end_delimiter;
5935 0 0         if (not $octet{$char}) {
5936 0           return join '', 'qq', $char, $stuff, $char;
5937             }
5938             }
5939 0           return join '', 'qq', '<', $stuff, '>';
5940             }
5941              
5942             #
5943             # escape regexp (m'', qr'', and m''b, qr''b)
5944             #
5945             sub e_qr_q {
5946 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5947 0   0       $modifier ||= '';
5948              
5949 0           $modifier =~ tr/p//d;
5950 0 0         if ($modifier =~ /([adlu])/oxms) {
5951 0           my $line = 0;
5952 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5953 0 0         if ($filename ne __FILE__) {
5954 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5955 0           last;
5956             }
5957             }
5958 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5959             }
5960              
5961 0           $slash = 'div';
5962              
5963             # literal null string pattern
5964 0 0         if ($string eq '') {
    0          
5965 0           $modifier =~ tr/bB//d;
5966 0           $modifier =~ tr/i//d;
5967 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5968             }
5969              
5970             # with /b /B modifier
5971             elsif ($modifier =~ tr/bB//d) {
5972 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5973             }
5974              
5975             # without /b /B modifier
5976             else {
5977 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5978             }
5979             }
5980              
5981             #
5982             # escape regexp (m'', qr'')
5983             #
5984             sub e_qr_qt {
5985 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5986              
5987 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5988              
5989             # split regexp
5990 0           my @char = $string =~ /\G((?>
5991             [^\\\[\$\@\/] |
5992             [\x00-\xFF] |
5993             \[\^ |
5994             \[\: (?>[a-z]+) \:\] |
5995             \[\:\^ (?>[a-z]+) \:\] |
5996             [\$\@\/] |
5997             \\ (?:$q_char) |
5998             (?:$q_char)
5999             ))/oxmsg;
6000              
6001             # unescape character
6002 0           for (my $i=0; $i <= $#char; $i++) {
6003 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6004             }
6005              
6006             # open character class [...]
6007 0           elsif ($char[$i] eq '[') {
6008 0           my $left = $i;
6009 0 0         if ($char[$i+1] eq ']') {
6010 0           $i++;
6011             }
6012 0           while (1) {
6013 0 0         if (++$i > $#char) {
6014 0           die __FILE__, ": Unmatched [] in regexp\n";
6015             }
6016 0 0         if ($char[$i] eq ']') {
6017 0           my $right = $i;
6018              
6019             # [...]
6020 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
6021              
6022 0           $i = $left;
6023 0           last;
6024             }
6025             }
6026             }
6027              
6028             # open character class [^...]
6029             elsif ($char[$i] eq '[^') {
6030 0           my $left = $i;
6031 0 0         if ($char[$i+1] eq ']') {
6032 0           $i++;
6033             }
6034 0           while (1) {
6035 0 0         if (++$i > $#char) {
6036 0           die __FILE__, ": Unmatched [] in regexp\n";
6037             }
6038 0 0         if ($char[$i] eq ']') {
6039 0           my $right = $i;
6040              
6041             # [^...]
6042 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6043              
6044 0           $i = $left;
6045 0           last;
6046             }
6047             }
6048             }
6049              
6050             # escape $ @ / and \
6051             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6052 0           $char[$i] = '\\' . $char[$i];
6053             }
6054              
6055             # rewrite character class or escape character
6056             elsif (my $char = character_class($char[$i],$modifier)) {
6057 0           $char[$i] = $char;
6058             }
6059              
6060             # /i modifier
6061             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
6062 0 0         if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
6063 0           $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
6064             }
6065             else {
6066 0           $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
6067             }
6068             }
6069              
6070             # quote character before ? + * {
6071             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6072 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6073             }
6074             else {
6075 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6076             }
6077             }
6078             }
6079              
6080 0           $delimiter = '/';
6081 0           $end_delimiter = '/';
6082              
6083 0           $modifier =~ tr/i//d;
6084 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6085             }
6086              
6087             #
6088             # escape regexp (m''b, qr''b)
6089             #
6090             sub e_qr_qb {
6091 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6092              
6093             # split regexp
6094 0           my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6095              
6096             # unescape character
6097 0           for (my $i=0; $i <= $#char; $i++) {
6098 0 0         if (0) {
    0          
6099             }
6100              
6101             # remain \\
6102 0           elsif ($char[$i] eq '\\\\') {
6103             }
6104              
6105             # escape $ @ / and \
6106             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6107 0           $char[$i] = '\\' . $char[$i];
6108             }
6109             }
6110              
6111 0           $delimiter = '/';
6112 0           $end_delimiter = '/';
6113 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6114             }
6115              
6116             #
6117             # escape regexp (s/here//)
6118             #
6119             sub e_s1 {
6120 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6121 0   0       $modifier ||= '';
6122              
6123 0           $modifier =~ tr/p//d;
6124 0 0         if ($modifier =~ /([adlu])/oxms) {
6125 0           my $line = 0;
6126 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6127 0 0         if ($filename ne __FILE__) {
6128 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6129 0           last;
6130             }
6131             }
6132 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6133             }
6134              
6135 0           $slash = 'div';
6136              
6137             # literal null string pattern
6138 0 0         if ($string eq '') {
    0          
6139 0           $modifier =~ tr/bB//d;
6140 0           $modifier =~ tr/i//d;
6141 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6142             }
6143              
6144             # /b /B modifier
6145             elsif ($modifier =~ tr/bB//d) {
6146              
6147             # choice again delimiter
6148 0 0         if ($delimiter =~ / [\@:] /oxms) {
6149 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6150 0           my %octet = map {$_ => 1} @char;
  0            
6151 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6152 0           $delimiter = '(';
6153 0           $end_delimiter = ')';
6154             }
6155             elsif (not $octet{'}'}) {
6156 0           $delimiter = '{';
6157 0           $end_delimiter = '}';
6158             }
6159             elsif (not $octet{']'}) {
6160 0           $delimiter = '[';
6161 0           $end_delimiter = ']';
6162             }
6163             elsif (not $octet{'>'}) {
6164 0           $delimiter = '<';
6165 0           $end_delimiter = '>';
6166             }
6167             else {
6168 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6169 0 0         if (not $octet{$char}) {
6170 0           $delimiter = $char;
6171 0           $end_delimiter = $char;
6172 0           last;
6173             }
6174             }
6175             }
6176             }
6177              
6178 0           my $prematch = '';
6179 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6180             }
6181              
6182 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6183 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6184              
6185             # split regexp
6186 0           my @char = $string =~ /\G((?>
6187             [^\\\$\@\[\(] |
6188             \\ (?>[1-9][0-9]*) |
6189             \\g (?>\s*) (?>[1-9][0-9]*) |
6190             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6191             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6192             \\x (?>[0-9A-Fa-f]{1,2}) |
6193             \\ (?>[0-7]{2,3}) |
6194             \\c [\x40-\x5F] |
6195             \\x\{ (?>[0-9A-Fa-f]+) \} |
6196             \\o\{ (?>[0-7]+) \} |
6197             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6198             \\ $q_char |
6199             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6200             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6201             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6202             [\$\@] $qq_variable |
6203             \$ (?>\s* [0-9]+) |
6204             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6205             \$ \$ (?![\w\{]) |
6206             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6207             \[\^ |
6208             \[\: (?>[a-z]+) :\] |
6209             \[\:\^ (?>[a-z]+) :\] |
6210             \(\? |
6211             $q_char
6212             ))/oxmsg;
6213              
6214             # choice again delimiter
6215 0 0         if ($delimiter =~ / [\@:] /oxms) {
6216 0           my %octet = map {$_ => 1} @char;
  0            
6217 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6218 0           $delimiter = '(';
6219 0           $end_delimiter = ')';
6220             }
6221             elsif (not $octet{'}'}) {
6222 0           $delimiter = '{';
6223 0           $end_delimiter = '}';
6224             }
6225             elsif (not $octet{']'}) {
6226 0           $delimiter = '[';
6227 0           $end_delimiter = ']';
6228             }
6229             elsif (not $octet{'>'}) {
6230 0           $delimiter = '<';
6231 0           $end_delimiter = '>';
6232             }
6233             else {
6234 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6235 0 0         if (not $octet{$char}) {
6236 0           $delimiter = $char;
6237 0           $end_delimiter = $char;
6238 0           last;
6239             }
6240             }
6241             }
6242             }
6243              
6244             # count '('
6245 0           my $parens = grep { $_ eq '(' } @char;
  0            
6246              
6247 0           my $left_e = 0;
6248 0           my $right_e = 0;
6249 0           for (my $i=0; $i <= $#char; $i++) {
6250              
6251             # "\L\u" --> "\u\L"
6252 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
6253 0           @char[$i,$i+1] = @char[$i+1,$i];
6254             }
6255              
6256             # "\U\l" --> "\l\U"
6257             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6258 0           @char[$i,$i+1] = @char[$i+1,$i];
6259             }
6260              
6261             # octal escape sequence
6262             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6263 0           $char[$i] = Ewindows1252::octchr($1);
6264             }
6265              
6266             # hexadecimal escape sequence
6267             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6268 0           $char[$i] = Ewindows1252::hexchr($1);
6269             }
6270              
6271             # \b{...} --> b\{...}
6272             # \B{...} --> B\{...}
6273             # \N{CHARNAME} --> N\{CHARNAME}
6274             # \p{PROPERTY} --> p\{PROPERTY}
6275             # \P{PROPERTY} --> P\{PROPERTY}
6276             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6277 0           $char[$i] = $1 . '\\' . $2;
6278             }
6279              
6280             # \p, \P, \X --> p, P, X
6281             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6282 0           $char[$i] = $1;
6283             }
6284              
6285 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6286             }
6287              
6288             # join separated multiple-octet
6289 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6290 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6291 0           $char[$i] .= join '', splice @char, $i+1, 3;
6292             }
6293             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
6294 0           $char[$i] .= join '', splice @char, $i+1, 2;
6295             }
6296             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
6297 0           $char[$i] .= join '', splice @char, $i+1, 1;
6298             }
6299             }
6300              
6301             # open character class [...]
6302             elsif ($char[$i] eq '[') {
6303 0           my $left = $i;
6304 0 0         if ($char[$i+1] eq ']') {
6305 0           $i++;
6306             }
6307 0           while (1) {
6308 0 0         if (++$i > $#char) {
6309 0           die __FILE__, ": Unmatched [] in regexp\n";
6310             }
6311 0 0         if ($char[$i] eq ']') {
6312 0           my $right = $i;
6313              
6314             # [...]
6315 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6316 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1252::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6317             }
6318             else {
6319 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
6320             }
6321              
6322 0           $i = $left;
6323 0           last;
6324             }
6325             }
6326             }
6327              
6328             # open character class [^...]
6329             elsif ($char[$i] eq '[^') {
6330 0           my $left = $i;
6331 0 0         if ($char[$i+1] eq ']') {
6332 0           $i++;
6333             }
6334 0           while (1) {
6335 0 0         if (++$i > $#char) {
6336 0           die __FILE__, ": Unmatched [] in regexp\n";
6337             }
6338 0 0         if ($char[$i] eq ']') {
6339 0           my $right = $i;
6340              
6341             # [^...]
6342 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6343 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1252::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6344             }
6345             else {
6346 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6347             }
6348              
6349 0           $i = $left;
6350 0           last;
6351             }
6352             }
6353             }
6354              
6355             # rewrite character class or escape character
6356             elsif (my $char = character_class($char[$i],$modifier)) {
6357 0           $char[$i] = $char;
6358             }
6359              
6360             # /i modifier
6361             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
6362 0 0         if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
6363 0           $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
6364             }
6365             else {
6366 0           $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
6367             }
6368             }
6369              
6370             # \u \l \U \L \F \Q \E
6371             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6372 0 0         if ($right_e < $left_e) {
6373 0           $char[$i] = '\\' . $char[$i];
6374             }
6375             }
6376             elsif ($char[$i] eq '\u') {
6377 0           $char[$i] = '@{[Ewindows1252::ucfirst qq<';
6378 0           $left_e++;
6379             }
6380             elsif ($char[$i] eq '\l') {
6381 0           $char[$i] = '@{[Ewindows1252::lcfirst qq<';
6382 0           $left_e++;
6383             }
6384             elsif ($char[$i] eq '\U') {
6385 0           $char[$i] = '@{[Ewindows1252::uc qq<';
6386 0           $left_e++;
6387             }
6388             elsif ($char[$i] eq '\L') {
6389 0           $char[$i] = '@{[Ewindows1252::lc qq<';
6390 0           $left_e++;
6391             }
6392             elsif ($char[$i] eq '\F') {
6393 0           $char[$i] = '@{[Ewindows1252::fc qq<';
6394 0           $left_e++;
6395             }
6396             elsif ($char[$i] eq '\Q') {
6397 0           $char[$i] = '@{[CORE::quotemeta qq<';
6398 0           $left_e++;
6399             }
6400             elsif ($char[$i] eq '\E') {
6401 0 0         if ($right_e < $left_e) {
6402 0           $char[$i] = '>]}';
6403 0           $right_e++;
6404             }
6405             else {
6406 0           $char[$i] = '';
6407             }
6408             }
6409             elsif ($char[$i] eq '\Q') {
6410 0           while (1) {
6411 0 0         if (++$i > $#char) {
6412 0           last;
6413             }
6414 0 0         if ($char[$i] eq '\E') {
6415 0           last;
6416             }
6417             }
6418             }
6419             elsif ($char[$i] eq '\E') {
6420             }
6421              
6422             # \0 --> \0
6423             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6424             }
6425              
6426             # \g{N}, \g{-N}
6427              
6428             # P.108 Using Simple Patterns
6429             # in Chapter 7: In the World of Regular Expressions
6430             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6431              
6432             # P.221 Capturing
6433             # in Chapter 5: Pattern Matching
6434             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6435              
6436             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6437             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6438             }
6439              
6440             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6441             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6442             }
6443              
6444             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6445             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6446             }
6447              
6448             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6449             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6450             }
6451              
6452             # $0 --> $0
6453             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6454 0 0         if ($ignorecase) {
6455 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6456             }
6457             }
6458             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6459 0 0         if ($ignorecase) {
6460 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6461             }
6462             }
6463              
6464             # $$ --> $$
6465             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6466             }
6467              
6468             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6469             # $1, $2, $3 --> $1, $2, $3 otherwise
6470             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6471 0           $char[$i] = e_capture($1);
6472 0 0         if ($ignorecase) {
6473 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6474             }
6475             }
6476             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6477 0           $char[$i] = e_capture($1);
6478 0 0         if ($ignorecase) {
6479 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6480             }
6481             }
6482              
6483             # $$foo[ ... ] --> $ $foo->[ ... ]
6484             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6485 0           $char[$i] = e_capture($1.'->'.$2);
6486 0 0         if ($ignorecase) {
6487 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6488             }
6489             }
6490              
6491             # $$foo{ ... } --> $ $foo->{ ... }
6492             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6493 0           $char[$i] = e_capture($1.'->'.$2);
6494 0 0         if ($ignorecase) {
6495 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6496             }
6497             }
6498              
6499             # $$foo
6500             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6501 0           $char[$i] = e_capture($1);
6502 0 0         if ($ignorecase) {
6503 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6504             }
6505             }
6506              
6507             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
6508             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6509 0 0         if ($ignorecase) {
6510 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::PREMATCH())]}';
6511             }
6512             else {
6513 0           $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
6514             }
6515             }
6516              
6517             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
6518             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6519 0 0         if ($ignorecase) {
6520 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::MATCH())]}';
6521             }
6522             else {
6523 0           $char[$i] = '@{[Ewindows1252::MATCH()]}';
6524             }
6525             }
6526              
6527             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
6528             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6529 0 0         if ($ignorecase) {
6530 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::POSTMATCH())]}';
6531             }
6532             else {
6533 0           $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
6534             }
6535             }
6536              
6537             # ${ foo }
6538             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6539 0 0         if ($ignorecase) {
6540 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6541             }
6542             }
6543              
6544             # ${ ... }
6545             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6546 0           $char[$i] = e_capture($1);
6547 0 0         if ($ignorecase) {
6548 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6549             }
6550             }
6551              
6552             # $scalar or @array
6553             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6554 0           $char[$i] = e_string($char[$i]);
6555 0 0         if ($ignorecase) {
6556 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6557             }
6558             }
6559              
6560             # quote character before ? + * {
6561             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6562 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6563             }
6564             else {
6565 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6566             }
6567             }
6568             }
6569              
6570             # make regexp string
6571 0           my $prematch = '';
6572 0           $modifier =~ tr/i//d;
6573 0 0         if ($left_e > $right_e) {
6574 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6575             }
6576 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6577             }
6578              
6579             #
6580             # escape regexp (s'here'' or s'here''b)
6581             #
6582             sub e_s1_q {
6583 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6584 0   0       $modifier ||= '';
6585              
6586 0           $modifier =~ tr/p//d;
6587 0 0         if ($modifier =~ /([adlu])/oxms) {
6588 0           my $line = 0;
6589 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6590 0 0         if ($filename ne __FILE__) {
6591 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6592 0           last;
6593             }
6594             }
6595 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6596             }
6597              
6598 0           $slash = 'div';
6599              
6600             # literal null string pattern
6601 0 0         if ($string eq '') {
    0          
6602 0           $modifier =~ tr/bB//d;
6603 0           $modifier =~ tr/i//d;
6604 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6605             }
6606              
6607             # with /b /B modifier
6608             elsif ($modifier =~ tr/bB//d) {
6609 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6610             }
6611              
6612             # without /b /B modifier
6613             else {
6614 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6615             }
6616             }
6617              
6618             #
6619             # escape regexp (s'here'')
6620             #
6621             sub e_s1_qt {
6622 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6623              
6624 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6625              
6626             # split regexp
6627 0           my @char = $string =~ /\G((?>
6628             [^\\\[\$\@\/] |
6629             [\x00-\xFF] |
6630             \[\^ |
6631             \[\: (?>[a-z]+) \:\] |
6632             \[\:\^ (?>[a-z]+) \:\] |
6633             [\$\@\/] |
6634             \\ (?:$q_char) |
6635             (?:$q_char)
6636             ))/oxmsg;
6637              
6638             # unescape character
6639 0           for (my $i=0; $i <= $#char; $i++) {
6640 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6641             }
6642              
6643             # open character class [...]
6644 0           elsif ($char[$i] eq '[') {
6645 0           my $left = $i;
6646 0 0         if ($char[$i+1] eq ']') {
6647 0           $i++;
6648             }
6649 0           while (1) {
6650 0 0         if (++$i > $#char) {
6651 0           die __FILE__, ": Unmatched [] in regexp\n";
6652             }
6653 0 0         if ($char[$i] eq ']') {
6654 0           my $right = $i;
6655              
6656             # [...]
6657 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
6658              
6659 0           $i = $left;
6660 0           last;
6661             }
6662             }
6663             }
6664              
6665             # open character class [^...]
6666             elsif ($char[$i] eq '[^') {
6667 0           my $left = $i;
6668 0 0         if ($char[$i+1] eq ']') {
6669 0           $i++;
6670             }
6671 0           while (1) {
6672 0 0         if (++$i > $#char) {
6673 0           die __FILE__, ": Unmatched [] in regexp\n";
6674             }
6675 0 0         if ($char[$i] eq ']') {
6676 0           my $right = $i;
6677              
6678             # [^...]
6679 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6680              
6681 0           $i = $left;
6682 0           last;
6683             }
6684             }
6685             }
6686              
6687             # escape $ @ / and \
6688             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6689 0           $char[$i] = '\\' . $char[$i];
6690             }
6691              
6692             # rewrite character class or escape character
6693             elsif (my $char = character_class($char[$i],$modifier)) {
6694 0           $char[$i] = $char;
6695             }
6696              
6697             # /i modifier
6698             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
6699 0 0         if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
6700 0           $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
6701             }
6702             else {
6703 0           $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
6704             }
6705             }
6706              
6707             # quote character before ? + * {
6708             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6709 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6710             }
6711             else {
6712 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6713             }
6714             }
6715             }
6716              
6717 0           $modifier =~ tr/i//d;
6718 0           $delimiter = '/';
6719 0           $end_delimiter = '/';
6720 0           my $prematch = '';
6721 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6722             }
6723              
6724             #
6725             # escape regexp (s'here''b)
6726             #
6727             sub e_s1_qb {
6728 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6729              
6730             # split regexp
6731 0           my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6732              
6733             # unescape character
6734 0           for (my $i=0; $i <= $#char; $i++) {
6735 0 0         if (0) {
    0          
6736             }
6737              
6738             # remain \\
6739 0           elsif ($char[$i] eq '\\\\') {
6740             }
6741              
6742             # escape $ @ / and \
6743             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6744 0           $char[$i] = '\\' . $char[$i];
6745             }
6746             }
6747              
6748 0           $delimiter = '/';
6749 0           $end_delimiter = '/';
6750 0           my $prematch = '';
6751 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6752             }
6753              
6754             #
6755             # escape regexp (s''here')
6756             #
6757             sub e_s2_q {
6758 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6759              
6760 0           $slash = 'div';
6761              
6762 0           my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6763 0           for (my $i=0; $i <= $#char; $i++) {
6764 0 0         if (0) {
    0          
6765             }
6766              
6767             # not escape \\
6768 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6769             }
6770              
6771             # escape $ @ / and \
6772             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6773 0           $char[$i] = '\\' . $char[$i];
6774             }
6775             }
6776              
6777 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6778             }
6779              
6780             #
6781             # escape regexp (s/here/and here/modifier)
6782             #
6783             sub e_sub {
6784 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6785 0   0       $modifier ||= '';
6786              
6787 0           $modifier =~ tr/p//d;
6788 0 0         if ($modifier =~ /([adlu])/oxms) {
6789 0           my $line = 0;
6790 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6791 0 0         if ($filename ne __FILE__) {
6792 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6793 0           last;
6794             }
6795             }
6796 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6797             }
6798              
6799 0 0         if ($variable eq '') {
6800 0           $variable = '$_';
6801 0           $bind_operator = ' =~ ';
6802             }
6803              
6804 0           $slash = 'div';
6805              
6806             # P.128 Start of match (or end of previous match): \G
6807             # P.130 Advanced Use of \G with Perl
6808             # in Chapter 3: Overview of Regular Expression Features and Flavors
6809             # P.312 Iterative Matching: Scalar Context, with /g
6810             # in Chapter 7: Perl
6811             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6812              
6813             # P.181 Where You Left Off: The \G Assertion
6814             # in Chapter 5: Pattern Matching
6815             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6816              
6817             # P.220 Where You Left Off: The \G Assertion
6818             # in Chapter 5: Pattern Matching
6819             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6820              
6821 0           my $e_modifier = $modifier =~ tr/e//d;
6822 0           my $r_modifier = $modifier =~ tr/r//d;
6823              
6824 0           my $my = '';
6825 0 0         if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6826 0           $my = $variable;
6827 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6828 0           $variable =~ s/ = .+ \z//oxms;
6829             }
6830              
6831 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6832 0           $variable_basename =~ s/ \s+ \z//oxms;
6833              
6834             # quote replacement string
6835 0           my $e_replacement = '';
6836 0 0         if ($e_modifier >= 1) {
6837 0           $e_replacement = e_qq('', '', '', $replacement);
6838 0           $e_modifier--;
6839             }
6840             else {
6841 0 0         if ($delimiter2 eq "'") {
6842 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6843             }
6844             else {
6845 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6846             }
6847             }
6848              
6849 0           my $sub = '';
6850              
6851             # with /r
6852 0 0         if ($r_modifier) {
6853 0 0         if (0) {
6854             }
6855              
6856             # s///gr without multibyte anchoring
6857 0           elsif ($modifier =~ /g/oxms) {
6858 0 0         $sub = sprintf(
6859             # 1 2 3 4 5
6860             q,
6861              
6862             $variable, # 1
6863             ($delimiter1 eq "'") ? # 2
6864             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6865             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6866             $s_matched, # 3
6867             $e_replacement, # 4
6868             '$Windows1252::re_r=CORE::eval $Windows1252::re_r; ' x $e_modifier, # 5
6869             );
6870             }
6871              
6872             # s///r
6873             else {
6874              
6875 0           my $prematch = q{$`};
6876              
6877 0 0         $sub = sprintf(
6878             # 1 2 3 4 5 6 7
6879             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Windows1252::re_r=%s; %s"%s$Windows1252::re_r$'" } : %s>,
6880              
6881             $variable, # 1
6882             ($delimiter1 eq "'") ? # 2
6883             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6884             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6885             $s_matched, # 3
6886             $e_replacement, # 4
6887             '$Windows1252::re_r=CORE::eval $Windows1252::re_r; ' x $e_modifier, # 5
6888             $prematch, # 6
6889             $variable, # 7
6890             );
6891             }
6892              
6893             # $var !~ s///r doesn't make sense
6894 0 0         if ($bind_operator =~ / !~ /oxms) {
6895 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6896             }
6897             }
6898              
6899             # without /r
6900             else {
6901 0 0         if (0) {
6902             }
6903              
6904             # s///g without multibyte anchoring
6905 0           elsif ($modifier =~ /g/oxms) {
6906 0 0         $sub = sprintf(
    0          
6907             # 1 2 3 4 5 6 7 8
6908             q,
6909              
6910             $variable, # 1
6911             ($delimiter1 eq "'") ? # 2
6912             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6913             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6914             $s_matched, # 3
6915             $e_replacement, # 4
6916             '$Windows1252::re_r=CORE::eval $Windows1252::re_r; ' x $e_modifier, # 5
6917             $variable, # 6
6918             $variable, # 7
6919             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6920             );
6921             }
6922              
6923             # s///
6924             else {
6925              
6926 0           my $prematch = q{$`};
6927              
6928 0 0         $sub = sprintf(
    0          
6929              
6930             ($bind_operator =~ / =~ /oxms) ?
6931              
6932             # 1 2 3 4 5 6 7 8
6933             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Windows1252::re_r=%s; %s%s="%s$Windows1252::re_r$'"; 1 } : undef> :
6934              
6935             # 1 2 3 4 5 6 7 8
6936             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Windows1252::re_r=%s; %s%s="%s$Windows1252::re_r$'"; undef }>,
6937              
6938             $variable, # 1
6939             $bind_operator, # 2
6940             ($delimiter1 eq "'") ? # 3
6941             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6942             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6943             $s_matched, # 4
6944             $e_replacement, # 5
6945             '$Windows1252::re_r=CORE::eval $Windows1252::re_r; ' x $e_modifier, # 6
6946             $variable, # 7
6947             $prematch, # 8
6948             );
6949             }
6950             }
6951              
6952             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6953 0 0         if ($my ne '') {
6954 0           $sub = "($my, $sub)[1]";
6955             }
6956              
6957             # clear s/// variable
6958 0           $sub_variable = '';
6959 0           $bind_operator = '';
6960              
6961 0           return $sub;
6962             }
6963              
6964             #
6965             # escape regexp of split qr//
6966             #
6967             sub e_split {
6968 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6969 0   0       $modifier ||= '';
6970              
6971 0           $modifier =~ tr/p//d;
6972 0 0         if ($modifier =~ /([adlu])/oxms) {
6973 0           my $line = 0;
6974 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6975 0 0         if ($filename ne __FILE__) {
6976 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6977 0           last;
6978             }
6979             }
6980 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6981             }
6982              
6983 0           $slash = 'div';
6984              
6985             # /b /B modifier
6986 0 0         if ($modifier =~ tr/bB//d) {
6987 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6988             }
6989              
6990 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6991 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6992              
6993             # split regexp
6994 0           my @char = $string =~ /\G((?>
6995             [^\\\$\@\[\(] |
6996             \\x (?>[0-9A-Fa-f]{1,2}) |
6997             \\ (?>[0-7]{2,3}) |
6998             \\c [\x40-\x5F] |
6999             \\x\{ (?>[0-9A-Fa-f]+) \} |
7000             \\o\{ (?>[0-7]+) \} |
7001             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7002             \\ $q_char |
7003             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7004             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7005             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7006             [\$\@] $qq_variable |
7007             \$ (?>\s* [0-9]+) |
7008             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7009             \$ \$ (?![\w\{]) |
7010             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7011             \[\^ |
7012             \[\: (?>[a-z]+) :\] |
7013             \[\:\^ (?>[a-z]+) :\] |
7014             \(\? |
7015             $q_char
7016             ))/oxmsg;
7017              
7018 0           my $left_e = 0;
7019 0           my $right_e = 0;
7020 0           for (my $i=0; $i <= $#char; $i++) {
7021              
7022             # "\L\u" --> "\u\L"
7023 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
7024 0           @char[$i,$i+1] = @char[$i+1,$i];
7025             }
7026              
7027             # "\U\l" --> "\l\U"
7028             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7029 0           @char[$i,$i+1] = @char[$i+1,$i];
7030             }
7031              
7032             # octal escape sequence
7033             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7034 0           $char[$i] = Ewindows1252::octchr($1);
7035             }
7036              
7037             # hexadecimal escape sequence
7038             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7039 0           $char[$i] = Ewindows1252::hexchr($1);
7040             }
7041              
7042             # \b{...} --> b\{...}
7043             # \B{...} --> B\{...}
7044             # \N{CHARNAME} --> N\{CHARNAME}
7045             # \p{PROPERTY} --> p\{PROPERTY}
7046             # \P{PROPERTY} --> P\{PROPERTY}
7047             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7048 0           $char[$i] = $1 . '\\' . $2;
7049             }
7050              
7051             # \p, \P, \X --> p, P, X
7052             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7053 0           $char[$i] = $1;
7054             }
7055              
7056 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7057             }
7058              
7059             # join separated multiple-octet
7060 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7061 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
7062 0           $char[$i] .= join '', splice @char, $i+1, 3;
7063             }
7064             elsif (($i+2 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+2]) == 2) and (CORE::eval(sprintf '"%s%s%s"', @char[$i..$i+2]) =~ /\A $q_char \z/oxms)) {
7065 0           $char[$i] .= join '', splice @char, $i+1, 2;
7066             }
7067             elsif (($i+1 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, $char[$i+1 ]) == 1) and (CORE::eval(sprintf '"%s%s"', @char[$i..$i+1]) =~ /\A $q_char \z/oxms)) {
7068 0           $char[$i] .= join '', splice @char, $i+1, 1;
7069             }
7070             }
7071              
7072             # open character class [...]
7073             elsif ($char[$i] eq '[') {
7074 0           my $left = $i;
7075 0 0         if ($char[$i+1] eq ']') {
7076 0           $i++;
7077             }
7078 0           while (1) {
7079 0 0         if (++$i > $#char) {
7080 0           die __FILE__, ": Unmatched [] in regexp\n";
7081             }
7082 0 0         if ($char[$i] eq ']') {
7083 0           my $right = $i;
7084              
7085             # [...]
7086 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7087 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1252::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7088             }
7089             else {
7090 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
7091             }
7092              
7093 0           $i = $left;
7094 0           last;
7095             }
7096             }
7097             }
7098              
7099             # open character class [^...]
7100             elsif ($char[$i] eq '[^') {
7101 0           my $left = $i;
7102 0 0         if ($char[$i+1] eq ']') {
7103 0           $i++;
7104             }
7105 0           while (1) {
7106 0 0         if (++$i > $#char) {
7107 0           die __FILE__, ": Unmatched [] in regexp\n";
7108             }
7109 0 0         if ($char[$i] eq ']') {
7110 0           my $right = $i;
7111              
7112             # [^...]
7113 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7114 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Ewindows1252::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7115             }
7116             else {
7117 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7118             }
7119              
7120 0           $i = $left;
7121 0           last;
7122             }
7123             }
7124             }
7125              
7126             # rewrite character class or escape character
7127             elsif (my $char = character_class($char[$i],$modifier)) {
7128 0           $char[$i] = $char;
7129             }
7130              
7131             # P.794 29.2.161. split
7132             # in Chapter 29: Functions
7133             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7134              
7135             # P.951 split
7136             # in Chapter 27: Functions
7137             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7138              
7139             # said "The //m modifier is assumed when you split on the pattern /^/",
7140             # but perl5.008 is not so. Therefore, this software adds //m.
7141             # (and so on)
7142              
7143             # split(m/^/) --> split(m/^/m)
7144             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7145 0           $modifier .= 'm';
7146             }
7147              
7148             # /i modifier
7149             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
7150 0 0         if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
7151 0           $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
7152             }
7153             else {
7154 0           $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
7155             }
7156             }
7157              
7158             # \u \l \U \L \F \Q \E
7159             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7160 0 0         if ($right_e < $left_e) {
7161 0           $char[$i] = '\\' . $char[$i];
7162             }
7163             }
7164             elsif ($char[$i] eq '\u') {
7165 0           $char[$i] = '@{[Ewindows1252::ucfirst qq<';
7166 0           $left_e++;
7167             }
7168             elsif ($char[$i] eq '\l') {
7169 0           $char[$i] = '@{[Ewindows1252::lcfirst qq<';
7170 0           $left_e++;
7171             }
7172             elsif ($char[$i] eq '\U') {
7173 0           $char[$i] = '@{[Ewindows1252::uc qq<';
7174 0           $left_e++;
7175             }
7176             elsif ($char[$i] eq '\L') {
7177 0           $char[$i] = '@{[Ewindows1252::lc qq<';
7178 0           $left_e++;
7179             }
7180             elsif ($char[$i] eq '\F') {
7181 0           $char[$i] = '@{[Ewindows1252::fc qq<';
7182 0           $left_e++;
7183             }
7184             elsif ($char[$i] eq '\Q') {
7185 0           $char[$i] = '@{[CORE::quotemeta qq<';
7186 0           $left_e++;
7187             }
7188             elsif ($char[$i] eq '\E') {
7189 0 0         if ($right_e < $left_e) {
7190 0           $char[$i] = '>]}';
7191 0           $right_e++;
7192             }
7193             else {
7194 0           $char[$i] = '';
7195             }
7196             }
7197             elsif ($char[$i] eq '\Q') {
7198 0           while (1) {
7199 0 0         if (++$i > $#char) {
7200 0           last;
7201             }
7202 0 0         if ($char[$i] eq '\E') {
7203 0           last;
7204             }
7205             }
7206             }
7207             elsif ($char[$i] eq '\E') {
7208             }
7209              
7210             # $0 --> $0
7211             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7212 0 0         if ($ignorecase) {
7213 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7214             }
7215             }
7216             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7217 0 0         if ($ignorecase) {
7218 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7219             }
7220             }
7221              
7222             # $$ --> $$
7223             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7224             }
7225              
7226             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7227             # $1, $2, $3 --> $1, $2, $3 otherwise
7228             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7229 0           $char[$i] = e_capture($1);
7230 0 0         if ($ignorecase) {
7231 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7232             }
7233             }
7234             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7235 0           $char[$i] = e_capture($1);
7236 0 0         if ($ignorecase) {
7237 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7238             }
7239             }
7240              
7241             # $$foo[ ... ] --> $ $foo->[ ... ]
7242             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7243 0           $char[$i] = e_capture($1.'->'.$2);
7244 0 0         if ($ignorecase) {
7245 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7246             }
7247             }
7248              
7249             # $$foo{ ... } --> $ $foo->{ ... }
7250             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7251 0           $char[$i] = e_capture($1.'->'.$2);
7252 0 0         if ($ignorecase) {
7253 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7254             }
7255             }
7256              
7257             # $$foo
7258             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7259 0           $char[$i] = e_capture($1);
7260 0 0         if ($ignorecase) {
7261 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7262             }
7263             }
7264              
7265             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
7266             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7267 0 0         if ($ignorecase) {
7268 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::PREMATCH())]}';
7269             }
7270             else {
7271 0           $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
7272             }
7273             }
7274              
7275             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
7276             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7277 0 0         if ($ignorecase) {
7278 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::MATCH())]}';
7279             }
7280             else {
7281 0           $char[$i] = '@{[Ewindows1252::MATCH()]}';
7282             }
7283             }
7284              
7285             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
7286             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7287 0 0         if ($ignorecase) {
7288 0           $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::POSTMATCH())]}';
7289             }
7290             else {
7291 0           $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
7292             }
7293             }
7294              
7295             # ${ foo }
7296             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7297 0 0         if ($ignorecase) {
7298 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $1 . ')]}';
7299             }
7300             }
7301              
7302             # ${ ... }
7303             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7304 0           $char[$i] = e_capture($1);
7305 0 0         if ($ignorecase) {
7306 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7307             }
7308             }
7309              
7310             # $scalar or @array
7311             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7312 0           $char[$i] = e_string($char[$i]);
7313 0 0         if ($ignorecase) {
7314 0           $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7315             }
7316             }
7317              
7318             # quote character before ? + * {
7319             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7320 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7321             }
7322             else {
7323 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7324             }
7325             }
7326             }
7327              
7328             # make regexp string
7329 0           $modifier =~ tr/i//d;
7330 0 0         if ($left_e > $right_e) {
7331 0           return join '', 'Ewindows1252::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7332             }
7333 0           return join '', 'Ewindows1252::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7334             }
7335              
7336             #
7337             # escape regexp of split qr''
7338             #
7339             sub e_split_q {
7340 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7341 0   0       $modifier ||= '';
7342              
7343 0           $modifier =~ tr/p//d;
7344 0 0         if ($modifier =~ /([adlu])/oxms) {
7345 0           my $line = 0;
7346 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7347 0 0         if ($filename ne __FILE__) {
7348 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7349 0           last;
7350             }
7351             }
7352 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7353             }
7354              
7355 0           $slash = 'div';
7356              
7357             # /b /B modifier
7358 0 0         if ($modifier =~ tr/bB//d) {
7359 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7360             }
7361              
7362 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7363              
7364             # split regexp
7365 0           my @char = $string =~ /\G((?>
7366             [^\\\[] |
7367             [\x00-\xFF] |
7368             \[\^ |
7369             \[\: (?>[a-z]+) \:\] |
7370             \[\:\^ (?>[a-z]+) \:\] |
7371             \\ (?:$q_char) |
7372             (?:$q_char)
7373             ))/oxmsg;
7374              
7375             # unescape character
7376 0           for (my $i=0; $i <= $#char; $i++) {
7377 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7378             }
7379              
7380             # open character class [...]
7381 0           elsif ($char[$i] eq '[') {
7382 0           my $left = $i;
7383 0 0         if ($char[$i+1] eq ']') {
7384 0           $i++;
7385             }
7386 0           while (1) {
7387 0 0         if (++$i > $#char) {
7388 0           die __FILE__, ": Unmatched [] in regexp\n";
7389             }
7390 0 0         if ($char[$i] eq ']') {
7391 0           my $right = $i;
7392              
7393             # [...]
7394 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
7395              
7396 0           $i = $left;
7397 0           last;
7398             }
7399             }
7400             }
7401              
7402             # open character class [^...]
7403             elsif ($char[$i] eq '[^') {
7404 0           my $left = $i;
7405 0 0         if ($char[$i+1] eq ']') {
7406 0           $i++;
7407             }
7408 0           while (1) {
7409 0 0         if (++$i > $#char) {
7410 0           die __FILE__, ": Unmatched [] in regexp\n";
7411             }
7412 0 0         if ($char[$i] eq ']') {
7413 0           my $right = $i;
7414              
7415             # [^...]
7416 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7417              
7418 0           $i = $left;
7419 0           last;
7420             }
7421             }
7422             }
7423              
7424             # rewrite character class or escape character
7425             elsif (my $char = character_class($char[$i],$modifier)) {
7426 0           $char[$i] = $char;
7427             }
7428              
7429             # split(m/^/) --> split(m/^/m)
7430             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7431 0           $modifier .= 'm';
7432             }
7433              
7434             # /i modifier
7435             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
7436 0 0         if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
7437 0           $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
7438             }
7439             else {
7440 0           $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
7441             }
7442             }
7443              
7444             # quote character before ? + * {
7445             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7446 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7447             }
7448             else {
7449 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7450             }
7451             }
7452             }
7453              
7454 0           $modifier =~ tr/i//d;
7455 0           return join '', 'Ewindows1252::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7456             }
7457              
7458             #
7459             # instead of Carp::carp
7460             #
7461             sub carp {
7462 0     0 0   my($package,$filename,$line) = caller(1);
7463 0           print STDERR "@_ at $filename line $line.\n";
7464             }
7465              
7466             #
7467             # instead of Carp::croak
7468             #
7469             sub croak {
7470 0     0 0   my($package,$filename,$line) = caller(1);
7471 0           print STDERR "@_ at $filename line $line.\n";
7472 0           die "\n";
7473             }
7474              
7475             #
7476             # instead of Carp::cluck
7477             #
7478             sub cluck {
7479 0     0 0   my $i = 0;
7480 0           my @cluck = ();
7481 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7482 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7483 0           $i++;
7484             }
7485 0           print STDERR CORE::reverse @cluck;
7486 0           print STDERR "\n";
7487 0           carp @_;
7488             }
7489              
7490             #
7491             # instead of Carp::confess
7492             #
7493             sub confess {
7494 0     0 0   my $i = 0;
7495 0           my @confess = ();
7496 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7497 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7498 0           $i++;
7499             }
7500 0           print STDERR CORE::reverse @confess;
7501 0           print STDERR "\n";
7502 0           croak @_;
7503             }
7504              
7505             1;
7506              
7507             __END__