File Coverage

blib/lib/Ewindows1252.pm
Criterion Covered Total %
statement 903 3194 28.2
branch 966 2740 35.2
condition 98 355 27.6
subroutine 52 110 47.2
pod 7 74 9.4
total 2026 6473 31.3


line stmt bran cond sub pod time code
1             package Ewindows1252;
2 204     204   1544 use strict;
  204         352  
  204         7501  
3             ######################################################################
4             #
5             # Ewindows1252 - Run-time routines for Windows1252.pm
6             #
7             # http://search.cpan.org/dist/Char-Windows1252/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   3084 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         676  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 204     204   1021 use vars qw($VERSION);
  204         383  
  204         30948  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   1817 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         358 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         33087 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 204     204   29176 CORE::eval q{
  204     204   1537  
  204     66   448  
  204         53031  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 204 50       84703 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0     0 0 0 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Ewindows1252::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Ewindows1252::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   1788 no strict qw(refs);
  204         444  
  204         15563  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1289 no strict qw(refs);
  204     0   361  
  204         42168  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1602 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         369  
  204         28770  
149 204     204   1560 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         399  
  204         420594  
150              
151             #
152             # Windows-1252 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # Windows-1252 case conversion
158             #
159             my %lc = ();
160             @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)} =
161             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);
162             my %uc = ();
163             @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)} =
164             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);
165             my %fc = ();
166             @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)} =
167             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);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Ewindows1252 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177              
178             %lc = (%lc,
179             "\x8A" => "\x9A", # LATIN LETTER S WITH CARON
180             "\x8C" => "\x9C", # LATIN LIGATURE OE
181             "\x8E" => "\x9E", # LATIN LETTER Z WITH CARON
182             "\x9F" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
183             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
184             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
185             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
186             "\xC3" => "\xE3", # LATIN LETTER A WITH TILDE
187             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
188             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
189             "\xC6" => "\xE6", # LATIN LETTER AE
190             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
191             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
192             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
193             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
194             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
195             "\xCC" => "\xEC", # LATIN LETTER I WITH GRAVE
196             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
197             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
198             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
199             "\xD0" => "\xF0", # LATIN LETTER ETH
200             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
201             "\xD2" => "\xF2", # LATIN LETTER O WITH GRAVE
202             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
203             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
204             "\xD5" => "\xF5", # LATIN LETTER O WITH TILDE
205             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
206             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
207             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
208             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
209             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
210             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
211             "\xDD" => "\xFD", # LATIN LETTER Y WITH ACUTE
212             "\xDE" => "\xFE", # LATIN LETTER THORN
213             );
214              
215             %uc = (%uc,
216             "\x9A" => "\x8A", # LATIN LETTER S WITH CARON
217             "\x9C" => "\x8C", # LATIN LIGATURE OE
218             "\x9E" => "\x8E", # LATIN LETTER Z WITH CARON
219             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
220             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
221             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
222             "\xE3" => "\xC3", # LATIN LETTER A WITH TILDE
223             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
224             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
225             "\xE6" => "\xC6", # LATIN LETTER AE
226             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
227             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
228             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
229             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
230             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
231             "\xEC" => "\xCC", # LATIN LETTER I WITH GRAVE
232             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
233             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
234             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
235             "\xF0" => "\xD0", # LATIN LETTER ETH
236             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
237             "\xF2" => "\xD2", # LATIN LETTER O WITH GRAVE
238             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
239             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
240             "\xF5" => "\xD5", # LATIN LETTER O WITH TILDE
241             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
242             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
243             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
244             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
245             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
246             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
247             "\xFD" => "\xDD", # LATIN LETTER Y WITH ACUTE
248             "\xFE" => "\xDE", # LATIN LETTER THORN
249             "\xFF" => "\x9F", # LATIN LETTER Y WITH DIAERESIS
250             );
251              
252             %fc = (%fc,
253             "\x8A" => "\x9A", # LATIN CAPITAL LETTER S WITH CARON --> LATIN SMALL LETTER S WITH CARON
254             "\x8C" => "\x9C", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
255             "\x8E" => "\x9E", # LATIN CAPITAL LETTER Z WITH CARON --> LATIN SMALL LETTER Z WITH CARON
256             "\x9F" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
257             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
258             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
259             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
260             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH TILDE --> LATIN SMALL LETTER A WITH TILDE
261             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
262             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
263             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
264             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
265             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
266             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
267             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
268             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
269             "\xCC" => "\xEC", # LATIN CAPITAL LETTER I WITH GRAVE --> LATIN SMALL LETTER I WITH GRAVE
270             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
271             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
272             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
273             "\xD0" => "\xF0", # LATIN CAPITAL LETTER ETH --> LATIN SMALL LETTER ETH
274             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
275             "\xD2" => "\xF2", # LATIN CAPITAL LETTER O WITH GRAVE --> LATIN SMALL LETTER O WITH GRAVE
276             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
277             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
278             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH TILDE --> LATIN SMALL LETTER O WITH TILDE
279             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
280             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
281             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
282             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
283             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
284             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
285             "\xDD" => "\xFD", # LATIN CAPITAL LETTER Y WITH ACUTE --> LATIN SMALL LETTER Y WITH ACUTE
286             "\xDE" => "\xFE", # LATIN CAPITAL LETTER THORN --> LATIN SMALL LETTER THORN
287             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
288             );
289             }
290              
291             else {
292             croak "Don't know my package name '@{[__PACKAGE__]}'";
293             }
294              
295             #
296             # @ARGV wildcard globbing
297             #
298             sub import {
299              
300 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
301 0         0 my @argv = ();
302 0         0 for (@ARGV) {
303              
304             # has space
305 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
306 0 0       0 if (my @glob = Ewindows1252::glob(qq{"$_"})) {
307 0         0 push @argv, @glob;
308             }
309             else {
310 0         0 push @argv, $_;
311             }
312             }
313              
314             # has wildcard metachar
315             elsif (/\A (?:$q_char)*? [*?] /oxms) {
316 0 0       0 if (my @glob = Ewindows1252::glob($_)) {
317 0         0 push @argv, @glob;
318             }
319             else {
320 0         0 push @argv, $_;
321             }
322             }
323              
324             # no wildcard globbing
325             else {
326 0         0 push @argv, $_;
327             }
328             }
329 0         0 @ARGV = @argv;
330             }
331              
332 0         0 *Char::ord = \&Windows1252::ord;
333 0         0 *Char::ord_ = \&Windows1252::ord_;
334 0         0 *Char::reverse = \&Windows1252::reverse;
335 0         0 *Char::getc = \&Windows1252::getc;
336 0         0 *Char::length = \&Windows1252::length;
337 0         0 *Char::substr = \&Windows1252::substr;
338 0         0 *Char::index = \&Windows1252::index;
339 0         0 *Char::rindex = \&Windows1252::rindex;
340 0         0 *Char::eval = \&Windows1252::eval;
341 0         0 *Char::escape = \&Windows1252::escape;
342 0         0 *Char::escape_token = \&Windows1252::escape_token;
343 0         0 *Char::escape_script = \&Windows1252::escape_script;
344             }
345              
346             # P.230 Care with Prototypes
347             # in Chapter 6: Subroutines
348             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
349             #
350             # If you aren't careful, you can get yourself into trouble with prototypes.
351             # But if you are careful, you can do a lot of neat things with them. This is
352             # all very powerful, of course, and should only be used in moderation to make
353             # the world a better place.
354              
355             # P.332 Care with Prototypes
356             # in Chapter 7: Subroutines
357             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
358             #
359             # If you aren't careful, you can get yourself into trouble with prototypes.
360             # But if you are careful, you can do a lot of neat things with them. This is
361             # all very powerful, of course, and should only be used in moderation to make
362             # the world a better place.
363              
364             #
365             # Prototypes of subroutines
366             #
367       0     sub unimport {}
368             sub Ewindows1252::split(;$$$);
369             sub Ewindows1252::tr($$$$;$);
370             sub Ewindows1252::chop(@);
371             sub Ewindows1252::index($$;$);
372             sub Ewindows1252::rindex($$;$);
373             sub Ewindows1252::lcfirst(@);
374             sub Ewindows1252::lcfirst_();
375             sub Ewindows1252::lc(@);
376             sub Ewindows1252::lc_();
377             sub Ewindows1252::ucfirst(@);
378             sub Ewindows1252::ucfirst_();
379             sub Ewindows1252::uc(@);
380             sub Ewindows1252::uc_();
381             sub Ewindows1252::fc(@);
382             sub Ewindows1252::fc_();
383             sub Ewindows1252::ignorecase;
384             sub Ewindows1252::classic_character_class;
385             sub Ewindows1252::capture;
386             sub Ewindows1252::chr(;$);
387             sub Ewindows1252::chr_();
388             sub Ewindows1252::glob($);
389             sub Ewindows1252::glob_();
390              
391             sub Windows1252::ord(;$);
392             sub Windows1252::ord_();
393             sub Windows1252::reverse(@);
394             sub Windows1252::getc(;*@);
395             sub Windows1252::length(;$);
396             sub Windows1252::substr($$;$$);
397             sub Windows1252::index($$;$);
398             sub Windows1252::rindex($$;$);
399             sub Windows1252::escape(;$);
400              
401             #
402             # Regexp work
403             #
404 204         21528 use vars qw(
405             $re_a
406             $re_t
407             $re_n
408             $re_r
409 204     204   2081 );
  204         461  
410              
411             #
412             # Character class
413             #
414 204         2193335 use vars qw(
415             $dot
416             $dot_s
417             $eD
418             $eS
419             $eW
420             $eH
421             $eV
422             $eR
423             $eN
424             $not_alnum
425             $not_alpha
426             $not_ascii
427             $not_blank
428             $not_cntrl
429             $not_digit
430             $not_graph
431             $not_lower
432             $not_lower_i
433             $not_print
434             $not_punct
435             $not_space
436             $not_upper
437             $not_upper_i
438             $not_word
439             $not_xdigit
440             $eb
441             $eB
442 204     204   1874 );
  204         472  
443              
444             ${Ewindows1252::dot} = qr{(?>[^\x0A])};
445             ${Ewindows1252::dot_s} = qr{(?>[\x00-\xFF])};
446             ${Ewindows1252::eD} = qr{(?>[^0-9])};
447              
448             # Vertical tabs are now whitespace
449             # \s in a regex now matches a vertical tab in all circumstances.
450             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
451             # ${Ewindows1252::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
452             # ${Ewindows1252::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
453             ${Ewindows1252::eS} = qr{(?>[^\s])};
454              
455             ${Ewindows1252::eW} = qr{(?>[^0-9A-Z_a-z])};
456             ${Ewindows1252::eH} = qr{(?>[^\x09\x20])};
457             ${Ewindows1252::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
458             ${Ewindows1252::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
459             ${Ewindows1252::eN} = qr{(?>[^\x0A])};
460             ${Ewindows1252::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
461             ${Ewindows1252::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
462             ${Ewindows1252::not_ascii} = qr{(?>[^\x00-\x7F])};
463             ${Ewindows1252::not_blank} = qr{(?>[^\x09\x20])};
464             ${Ewindows1252::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
465             ${Ewindows1252::not_digit} = qr{(?>[^\x30-\x39])};
466             ${Ewindows1252::not_graph} = qr{(?>[^\x21-\x7F])};
467             ${Ewindows1252::not_lower} = qr{(?>[^\x61-\x7A])};
468             ${Ewindows1252::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
469             # ${Ewindows1252::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
470             ${Ewindows1252::not_print} = qr{(?>[^\x20-\x7F])};
471             ${Ewindows1252::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
472             ${Ewindows1252::not_space} = qr{(?>[^\s\x0B])};
473             ${Ewindows1252::not_upper} = qr{(?>[^\x41-\x5A])};
474             ${Ewindows1252::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
475             # ${Ewindows1252::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
476             ${Ewindows1252::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
477             ${Ewindows1252::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
478             ${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))};
479             ${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]))};
480              
481             # avoid: Name "Ewindows1252::foo" used only once: possible typo at here.
482             ${Ewindows1252::dot} = ${Ewindows1252::dot};
483             ${Ewindows1252::dot_s} = ${Ewindows1252::dot_s};
484             ${Ewindows1252::eD} = ${Ewindows1252::eD};
485             ${Ewindows1252::eS} = ${Ewindows1252::eS};
486             ${Ewindows1252::eW} = ${Ewindows1252::eW};
487             ${Ewindows1252::eH} = ${Ewindows1252::eH};
488             ${Ewindows1252::eV} = ${Ewindows1252::eV};
489             ${Ewindows1252::eR} = ${Ewindows1252::eR};
490             ${Ewindows1252::eN} = ${Ewindows1252::eN};
491             ${Ewindows1252::not_alnum} = ${Ewindows1252::not_alnum};
492             ${Ewindows1252::not_alpha} = ${Ewindows1252::not_alpha};
493             ${Ewindows1252::not_ascii} = ${Ewindows1252::not_ascii};
494             ${Ewindows1252::not_blank} = ${Ewindows1252::not_blank};
495             ${Ewindows1252::not_cntrl} = ${Ewindows1252::not_cntrl};
496             ${Ewindows1252::not_digit} = ${Ewindows1252::not_digit};
497             ${Ewindows1252::not_graph} = ${Ewindows1252::not_graph};
498             ${Ewindows1252::not_lower} = ${Ewindows1252::not_lower};
499             ${Ewindows1252::not_lower_i} = ${Ewindows1252::not_lower_i};
500             ${Ewindows1252::not_print} = ${Ewindows1252::not_print};
501             ${Ewindows1252::not_punct} = ${Ewindows1252::not_punct};
502             ${Ewindows1252::not_space} = ${Ewindows1252::not_space};
503             ${Ewindows1252::not_upper} = ${Ewindows1252::not_upper};
504             ${Ewindows1252::not_upper_i} = ${Ewindows1252::not_upper_i};
505             ${Ewindows1252::not_word} = ${Ewindows1252::not_word};
506             ${Ewindows1252::not_xdigit} = ${Ewindows1252::not_xdigit};
507             ${Ewindows1252::eb} = ${Ewindows1252::eb};
508             ${Ewindows1252::eB} = ${Ewindows1252::eB};
509              
510             #
511             # Windows-1252 split
512             #
513             sub Ewindows1252::split(;$$$) {
514              
515             # P.794 29.2.161. split
516             # in Chapter 29: Functions
517             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
518              
519             # P.951 split
520             # in Chapter 27: Functions
521             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
522              
523 0     0 0 0 my $pattern = $_[0];
524 0         0 my $string = $_[1];
525 0         0 my $limit = $_[2];
526              
527             # if $pattern is also omitted or is the literal space, " "
528 0 0       0 if (not defined $pattern) {
529 0         0 $pattern = ' ';
530             }
531              
532             # if $string is omitted, the function splits the $_ string
533 0 0       0 if (not defined $string) {
534 0 0       0 if (defined $_) {
535 0         0 $string = $_;
536             }
537             else {
538 0         0 $string = '';
539             }
540             }
541              
542 0         0 my @split = ();
543              
544             # when string is empty
545 0 0       0 if ($string eq '') {
    0          
546              
547             # resulting list value in list context
548 0 0       0 if (wantarray) {
549 0         0 return @split;
550             }
551              
552             # count of substrings in scalar context
553             else {
554 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
555 0         0 @_ = @split;
556 0         0 return scalar @_;
557             }
558             }
559              
560             # split's first argument is more consistently interpreted
561             #
562             # After some changes earlier in v5.17, split's behavior has been simplified:
563             # if the PATTERN argument evaluates to a string containing one space, it is
564             # treated the way that a literal string containing one space once was.
565             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
566              
567             # if $pattern is also omitted or is the literal space, " ", the function splits
568             # on whitespace, /\s+/, after skipping any leading whitespace
569             # (and so on)
570              
571             elsif ($pattern eq ' ') {
572 0 0       0 if (not defined $limit) {
573 0         0 return CORE::split(' ', $string);
574             }
575             else {
576 0         0 return CORE::split(' ', $string, $limit);
577             }
578             }
579              
580             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
581 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
582              
583             # a pattern capable of matching either the null string or something longer than the
584             # null string will split the value of $string into separate characters wherever it
585             # matches the null string between characters
586             # (and so on)
587              
588 0 0       0 if ('' =~ / \A $pattern \z /xms) {
589 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
590 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
591              
592             # P.1024 Appendix W.10 Multibyte Processing
593             # of ISBN 1-56592-224-7 CJKV Information Processing
594             # (and so on)
595              
596             # the //m modifier is assumed when you split on the pattern /^/
597             # (and so on)
598              
599             # V
600 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
601              
602             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
603             # is included in the resulting list, interspersed with the fields that are ordinarily returned
604             # (and so on)
605              
606 0         0 local $@;
607 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
608 0         0 push @split, CORE::eval('$' . $digit);
609             }
610             }
611             }
612              
613             else {
614 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
615              
616             # V
617 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
618 0         0 local $@;
619 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
620 0         0 push @split, CORE::eval('$' . $digit);
621             }
622             }
623             }
624             }
625              
626             elsif ($limit > 0) {
627 0 0       0 if ('' =~ / \A $pattern \z /xms) {
628 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
629 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
630              
631             # V
632 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
633 0         0 local $@;
634 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
635 0         0 push @split, CORE::eval('$' . $digit);
636             }
637             }
638             }
639             }
640             else {
641 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
642 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
643              
644             # V
645 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
646 0         0 local $@;
647 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
648 0         0 push @split, CORE::eval('$' . $digit);
649             }
650             }
651             }
652             }
653             }
654              
655 0 0       0 if (CORE::length($string) > 0) {
656 0         0 push @split, $string;
657             }
658              
659             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
660 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
661 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
662 0         0 pop @split;
663             }
664             }
665              
666             # resulting list value in list context
667 0 0       0 if (wantarray) {
668 0         0 return @split;
669             }
670              
671             # count of substrings in scalar context
672             else {
673 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
674 0         0 @_ = @split;
675 0         0 return scalar @_;
676             }
677             }
678              
679             #
680             # get last subexpression offsets
681             #
682             sub _last_subexpression_offsets {
683 0     0   0 my $pattern = $_[0];
684              
685             # remove comment
686 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
687              
688 0         0 my $modifier = '';
689 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
690 0         0 $modifier = $1;
691 0         0 $modifier =~ s/-[A-Za-z]*//;
692             }
693              
694             # with /x modifier
695 0         0 my @char = ();
696 0 0       0 if ($modifier =~ /x/oxms) {
697 0         0 @char = $pattern =~ /\G((?>
698             [^\\\#\[\(] |
699             \\ $q_char |
700             \# (?>[^\n]*) $ |
701             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
702             \(\? |
703             $q_char
704             ))/oxmsg;
705             }
706              
707             # without /x modifier
708             else {
709 0         0 @char = $pattern =~ /\G((?>
710             [^\\\[\(] |
711             \\ $q_char |
712             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
713             \(\? |
714             $q_char
715             ))/oxmsg;
716             }
717              
718 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
719             }
720              
721             #
722             # Windows-1252 transliteration (tr///)
723             #
724             sub Ewindows1252::tr($$$$;$) {
725              
726 0     0 0 0 my $bind_operator = $_[1];
727 0         0 my $searchlist = $_[2];
728 0         0 my $replacementlist = $_[3];
729 0   0     0 my $modifier = $_[4] || '';
730              
731 0 0       0 if ($modifier =~ /r/oxms) {
732 0 0       0 if ($bind_operator =~ / !~ /oxms) {
733 0         0 croak "Using !~ with tr///r doesn't make sense";
734             }
735             }
736              
737 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
738 0         0 my @searchlist = _charlist_tr($searchlist);
739 0         0 my @replacementlist = _charlist_tr($replacementlist);
740              
741 0         0 my %tr = ();
742 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
743 0 0       0 if (not exists $tr{$searchlist[$i]}) {
744 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
745 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
746             }
747             elsif ($modifier =~ /d/oxms) {
748 0         0 $tr{$searchlist[$i]} = '';
749             }
750             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
751 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
752             }
753             else {
754 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
755             }
756             }
757             }
758              
759 0         0 my $tr = 0;
760 0         0 my $replaced = '';
761 0 0       0 if ($modifier =~ /c/oxms) {
762 0         0 while (defined(my $char = shift @char)) {
763 0 0       0 if (not exists $tr{$char}) {
764 0 0       0 if (defined $replacementlist[0]) {
765 0         0 $replaced .= $replacementlist[0];
766             }
767 0         0 $tr++;
768 0 0       0 if ($modifier =~ /s/oxms) {
769 0   0     0 while (@char and (not exists $tr{$char[0]})) {
770 0         0 shift @char;
771 0         0 $tr++;
772             }
773             }
774             }
775             else {
776 0         0 $replaced .= $char;
777             }
778             }
779             }
780             else {
781 0         0 while (defined(my $char = shift @char)) {
782 0 0       0 if (exists $tr{$char}) {
783 0         0 $replaced .= $tr{$char};
784 0         0 $tr++;
785 0 0       0 if ($modifier =~ /s/oxms) {
786 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
787 0         0 shift @char;
788 0         0 $tr++;
789             }
790             }
791             }
792             else {
793 0         0 $replaced .= $char;
794             }
795             }
796             }
797              
798 0 0       0 if ($modifier =~ /r/oxms) {
799 0         0 return $replaced;
800             }
801             else {
802 0         0 $_[0] = $replaced;
803 0 0       0 if ($bind_operator =~ / !~ /oxms) {
804 0         0 return not $tr;
805             }
806             else {
807 0         0 return $tr;
808             }
809             }
810             }
811              
812             #
813             # Windows-1252 chop
814             #
815             sub Ewindows1252::chop(@) {
816              
817 0     0 0 0 my $chop;
818 0 0       0 if (@_ == 0) {
819 0         0 my @char = /\G (?>$q_char) /oxmsg;
820 0         0 $chop = pop @char;
821 0         0 $_ = join '', @char;
822             }
823             else {
824 0         0 for (@_) {
825 0         0 my @char = /\G (?>$q_char) /oxmsg;
826 0         0 $chop = pop @char;
827 0         0 $_ = join '', @char;
828             }
829             }
830 0         0 return $chop;
831             }
832              
833             #
834             # Windows-1252 index by octet
835             #
836             sub Ewindows1252::index($$;$) {
837              
838 0     0 1 0 my($str,$substr,$position) = @_;
839 0   0     0 $position ||= 0;
840 0         0 my $pos = 0;
841              
842 0         0 while ($pos < CORE::length($str)) {
843 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
844 0 0       0 if ($pos >= $position) {
845 0         0 return $pos;
846             }
847             }
848 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
849 0         0 $pos += CORE::length($1);
850             }
851             else {
852 0         0 $pos += 1;
853             }
854             }
855 0         0 return -1;
856             }
857              
858             #
859             # Windows-1252 reverse index
860             #
861             sub Ewindows1252::rindex($$;$) {
862              
863 0     0 0 0 my($str,$substr,$position) = @_;
864 0   0     0 $position ||= CORE::length($str) - 1;
865 0         0 my $pos = 0;
866 0         0 my $rindex = -1;
867              
868 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
869 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
870 0         0 $rindex = $pos;
871             }
872 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
873 0         0 $pos += CORE::length($1);
874             }
875             else {
876 0         0 $pos += 1;
877             }
878             }
879 0         0 return $rindex;
880             }
881              
882             #
883             # Windows-1252 lower case first with parameter
884             #
885             sub Ewindows1252::lcfirst(@) {
886 0 0   0 0 0 if (@_) {
887 0         0 my $s = shift @_;
888 0 0 0     0 if (@_ and wantarray) {
889 0         0 return Ewindows1252::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
890             }
891             else {
892 0         0 return Ewindows1252::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
893             }
894             }
895             else {
896 0         0 return Ewindows1252::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
897             }
898             }
899              
900             #
901             # Windows-1252 lower case first without parameter
902             #
903             sub Ewindows1252::lcfirst_() {
904 0     0 0 0 return Ewindows1252::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
905             }
906              
907             #
908             # Windows-1252 lower case with parameter
909             #
910             sub Ewindows1252::lc(@) {
911 0 0   0 0 0 if (@_) {
912 0         0 my $s = shift @_;
913 0 0 0     0 if (@_ and wantarray) {
914 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
915             }
916             else {
917 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
918             }
919             }
920             else {
921 0         0 return Ewindows1252::lc_();
922             }
923             }
924              
925             #
926             # Windows-1252 lower case without parameter
927             #
928             sub Ewindows1252::lc_() {
929 0     0 0 0 my $s = $_;
930 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
931             }
932              
933             #
934             # Windows-1252 upper case first with parameter
935             #
936             sub Ewindows1252::ucfirst(@) {
937 0 0   0 0 0 if (@_) {
938 0         0 my $s = shift @_;
939 0 0 0     0 if (@_ and wantarray) {
940 0         0 return Ewindows1252::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
941             }
942             else {
943 0         0 return Ewindows1252::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
944             }
945             }
946             else {
947 0         0 return Ewindows1252::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
948             }
949             }
950              
951             #
952             # Windows-1252 upper case first without parameter
953             #
954             sub Ewindows1252::ucfirst_() {
955 0     0 0 0 return Ewindows1252::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
956             }
957              
958             #
959             # Windows-1252 upper case with parameter
960             #
961             sub Ewindows1252::uc(@) {
962 0 50   186 0 0 if (@_) {
963 186         310 my $s = shift @_;
964 186 50 33     246 if (@_ and wantarray) {
965 186 0       334 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
966             }
967             else {
968 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  186         741  
969             }
970             }
971             else {
972 186         789 return Ewindows1252::uc_();
973             }
974             }
975              
976             #
977             # Windows-1252 upper case without parameter
978             #
979             sub Ewindows1252::uc_() {
980 0     0 0 0 my $s = $_;
981 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
982             }
983              
984             #
985             # Windows-1252 fold case with parameter
986             #
987             sub Ewindows1252::fc(@) {
988 0 50   209 0 0 if (@_) {
989 209         310 my $s = shift @_;
990 209 50 33     238 if (@_ and wantarray) {
991 209 0       413 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
992             }
993             else {
994 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  209         505  
995             }
996             }
997             else {
998 209         1309 return Ewindows1252::fc_();
999             }
1000             }
1001              
1002             #
1003             # Windows-1252 fold case without parameter
1004             #
1005             sub Ewindows1252::fc_() {
1006 0     0 0 0 my $s = $_;
1007 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1008             }
1009              
1010             #
1011             # Windows-1252 regexp capture
1012             #
1013             {
1014             sub Ewindows1252::capture {
1015 0     0 1 0 return $_[0];
1016             }
1017             }
1018              
1019             #
1020             # Windows-1252 regexp ignore case modifier
1021             #
1022             sub Ewindows1252::ignorecase {
1023              
1024 0     0 0 0 my @string = @_;
1025 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1026              
1027             # ignore case of $scalar or @array
1028 0         0 for my $string (@string) {
1029              
1030             # split regexp
1031 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1032              
1033             # unescape character
1034 0         0 for (my $i=0; $i <= $#char; $i++) {
1035 0 0       0 next if not defined $char[$i];
1036              
1037             # open character class [...]
1038 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1039 0         0 my $left = $i;
1040              
1041             # [] make die "unmatched [] in regexp ...\n"
1042              
1043 0 0       0 if ($char[$i+1] eq ']') {
1044 0         0 $i++;
1045             }
1046              
1047 0         0 while (1) {
1048 0 0       0 if (++$i > $#char) {
1049 0         0 croak "Unmatched [] in regexp";
1050             }
1051 0 0       0 if ($char[$i] eq ']') {
1052 0         0 my $right = $i;
1053 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1054              
1055             # escape character
1056 0         0 for my $char (@charlist) {
1057 0 0       0 if (0) {
1058             }
1059              
1060 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1061 0         0 $char = '\\' . $char;
1062             }
1063             }
1064              
1065             # [...]
1066 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1067              
1068 0         0 $i = $left;
1069 0         0 last;
1070             }
1071             }
1072             }
1073              
1074             # open character class [^...]
1075             elsif ($char[$i] eq '[^') {
1076 0         0 my $left = $i;
1077              
1078             # [^] make die "unmatched [] in regexp ...\n"
1079              
1080 0 0       0 if ($char[$i+1] eq ']') {
1081 0         0 $i++;
1082             }
1083              
1084 0         0 while (1) {
1085 0 0       0 if (++$i > $#char) {
1086 0         0 croak "Unmatched [] in regexp";
1087             }
1088 0 0       0 if ($char[$i] eq ']') {
1089 0         0 my $right = $i;
1090 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1091              
1092             # escape character
1093 0         0 for my $char (@charlist) {
1094 0 0       0 if (0) {
1095             }
1096              
1097 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1098 0         0 $char = '\\' . $char;
1099             }
1100             }
1101              
1102             # [^...]
1103 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1104              
1105 0         0 $i = $left;
1106 0         0 last;
1107             }
1108             }
1109             }
1110              
1111             # rewrite classic character class or escape character
1112             elsif (my $char = classic_character_class($char[$i])) {
1113 0         0 $char[$i] = $char;
1114             }
1115              
1116             # with /i modifier
1117             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1118 0         0 my $uc = Ewindows1252::uc($char[$i]);
1119 0         0 my $fc = Ewindows1252::fc($char[$i]);
1120 0 0       0 if ($uc ne $fc) {
1121 0 0       0 if (CORE::length($fc) == 1) {
1122 0         0 $char[$i] = '[' . $uc . $fc . ']';
1123             }
1124             else {
1125 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1126             }
1127             }
1128             }
1129             }
1130              
1131             # characterize
1132 0         0 for (my $i=0; $i <= $#char; $i++) {
1133 0 0       0 next if not defined $char[$i];
1134              
1135 0 0       0 if (0) {
1136             }
1137              
1138             # quote character before ? + * {
1139 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1140 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1141 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1142             }
1143             }
1144             }
1145              
1146 0         0 $string = join '', @char;
1147             }
1148              
1149             # make regexp string
1150 0         0 return @string;
1151             }
1152              
1153             #
1154             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1155             #
1156             sub Ewindows1252::classic_character_class {
1157 0     1867 0 0 my($char) = @_;
1158              
1159             return {
1160             '\D' => '${Ewindows1252::eD}',
1161             '\S' => '${Ewindows1252::eS}',
1162             '\W' => '${Ewindows1252::eW}',
1163             '\d' => '[0-9]',
1164              
1165             # Before Perl 5.6, \s only matched the five whitespace characters
1166             # tab, newline, form-feed, carriage return, and the space character
1167             # itself, which, taken together, is the character class [\t\n\f\r ].
1168              
1169             # Vertical tabs are now whitespace
1170             # \s in a regex now matches a vertical tab in all circumstances.
1171             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1172             # \t \n \v \f \r space
1173             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1174             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1175             '\s' => '\s',
1176              
1177             '\w' => '[0-9A-Z_a-z]',
1178             '\C' => '[\x00-\xFF]',
1179             '\X' => 'X',
1180              
1181             # \h \v \H \V
1182              
1183             # P.114 Character Class Shortcuts
1184             # in Chapter 7: In the World of Regular Expressions
1185             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1186              
1187             # P.357 13.2.3 Whitespace
1188             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1189             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1190             #
1191             # 0x00009 CHARACTER TABULATION h s
1192             # 0x0000a LINE FEED (LF) vs
1193             # 0x0000b LINE TABULATION v
1194             # 0x0000c FORM FEED (FF) vs
1195             # 0x0000d CARRIAGE RETURN (CR) vs
1196             # 0x00020 SPACE h s
1197              
1198             # P.196 Table 5-9. Alphanumeric regex metasymbols
1199             # in Chapter 5. Pattern Matching
1200             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1201              
1202             # (and so on)
1203              
1204             '\H' => '${Ewindows1252::eH}',
1205             '\V' => '${Ewindows1252::eV}',
1206             '\h' => '[\x09\x20]',
1207             '\v' => '[\x0A\x0B\x0C\x0D]',
1208             '\R' => '${Ewindows1252::eR}',
1209              
1210             # \N
1211             #
1212             # http://perldoc.perl.org/perlre.html
1213             # Character Classes and other Special Escapes
1214             # Any character but \n (experimental). Not affected by /s modifier
1215              
1216             '\N' => '${Ewindows1252::eN}',
1217              
1218             # \b \B
1219              
1220             # P.180 Boundaries: The \b and \B Assertions
1221             # in Chapter 5: Pattern Matching
1222             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1223              
1224             # P.219 Boundaries: The \b and \B Assertions
1225             # in Chapter 5: Pattern Matching
1226             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1227              
1228             # \b really means (?:(?<=\w)(?!\w)|(?
1229             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1230             '\b' => '${Ewindows1252::eb}',
1231              
1232             # \B really means (?:(?<=\w)(?=\w)|(?
1233             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1234             '\B' => '${Ewindows1252::eB}',
1235              
1236 1867   100     2714 }->{$char} || '';
1237             }
1238              
1239             #
1240             # prepare Windows-1252 characters per length
1241             #
1242              
1243             # 1 octet characters
1244             my @chars1 = ();
1245             sub chars1 {
1246 1867 0   0 0 69758 if (@chars1) {
1247 0         0 return @chars1;
1248             }
1249 0 0       0 if (exists $range_tr{1}) {
1250 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1251 0         0 while (my @range = splice(@ranges,0,1)) {
1252 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1253 0         0 push @chars1, pack 'C', $oct0;
1254             }
1255             }
1256             }
1257 0         0 return @chars1;
1258             }
1259              
1260             # 2 octets characters
1261             my @chars2 = ();
1262             sub chars2 {
1263 0 0   0 0 0 if (@chars2) {
1264 0         0 return @chars2;
1265             }
1266 0 0       0 if (exists $range_tr{2}) {
1267 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1268 0         0 while (my @range = splice(@ranges,0,2)) {
1269 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1270 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1271 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1272             }
1273             }
1274             }
1275             }
1276 0         0 return @chars2;
1277             }
1278              
1279             # 3 octets characters
1280             my @chars3 = ();
1281             sub chars3 {
1282 0 0   0 0 0 if (@chars3) {
1283 0         0 return @chars3;
1284             }
1285 0 0       0 if (exists $range_tr{3}) {
1286 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1287 0         0 while (my @range = splice(@ranges,0,3)) {
1288 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1289 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1290 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1291 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1292             }
1293             }
1294             }
1295             }
1296             }
1297 0         0 return @chars3;
1298             }
1299              
1300             # 4 octets characters
1301             my @chars4 = ();
1302             sub chars4 {
1303 0 0   0 0 0 if (@chars4) {
1304 0         0 return @chars4;
1305             }
1306 0 0       0 if (exists $range_tr{4}) {
1307 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1308 0         0 while (my @range = splice(@ranges,0,4)) {
1309 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1310 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1311 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1312 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1313 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1314             }
1315             }
1316             }
1317             }
1318             }
1319             }
1320 0         0 return @chars4;
1321             }
1322              
1323             #
1324             # Windows-1252 open character list for tr
1325             #
1326             sub _charlist_tr {
1327              
1328 0     0   0 local $_ = shift @_;
1329              
1330             # unescape character
1331 0         0 my @char = ();
1332 0         0 while (not /\G \z/oxmsgc) {
1333 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1334 0         0 push @char, '\-';
1335             }
1336             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1337 0         0 push @char, CORE::chr(oct $1);
1338             }
1339             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1340 0         0 push @char, CORE::chr(hex $1);
1341             }
1342             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1343 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1344             }
1345             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1346             push @char, {
1347             '\0' => "\0",
1348             '\n' => "\n",
1349             '\r' => "\r",
1350             '\t' => "\t",
1351             '\f' => "\f",
1352             '\b' => "\x08", # \b means backspace in character class
1353             '\a' => "\a",
1354             '\e' => "\e",
1355 0         0 }->{$1};
1356             }
1357             elsif (/\G \\ ($q_char) /oxmsgc) {
1358 0         0 push @char, $1;
1359             }
1360             elsif (/\G ($q_char) /oxmsgc) {
1361 0         0 push @char, $1;
1362             }
1363             }
1364              
1365             # join separated multiple-octet
1366 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1367              
1368             # unescape '-'
1369 0         0 my @i = ();
1370 0         0 for my $i (0 .. $#char) {
1371 0 0       0 if ($char[$i] eq '\-') {
    0          
1372 0         0 $char[$i] = '-';
1373             }
1374             elsif ($char[$i] eq '-') {
1375 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1376 0         0 push @i, $i;
1377             }
1378             }
1379             }
1380              
1381             # open character list (reverse for splice)
1382 0         0 for my $i (CORE::reverse @i) {
1383 0         0 my @range = ();
1384              
1385             # range error
1386 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1387 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1388             }
1389              
1390             # range of multiple-octet code
1391 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1392 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1393 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1394             }
1395             elsif (CORE::length($char[$i+1]) == 2) {
1396 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1397 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1398             }
1399             elsif (CORE::length($char[$i+1]) == 3) {
1400 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1401 0         0 push @range, chars2();
1402 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1403             }
1404             elsif (CORE::length($char[$i+1]) == 4) {
1405 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1406 0         0 push @range, chars2();
1407 0         0 push @range, chars3();
1408 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1409             }
1410             else {
1411 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1412             }
1413             }
1414             elsif (CORE::length($char[$i-1]) == 2) {
1415 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1416 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1417             }
1418             elsif (CORE::length($char[$i+1]) == 3) {
1419 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1420 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1421             }
1422             elsif (CORE::length($char[$i+1]) == 4) {
1423 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1424 0         0 push @range, chars3();
1425 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1426             }
1427             else {
1428 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1429             }
1430             }
1431             elsif (CORE::length($char[$i-1]) == 3) {
1432 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1433 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1434             }
1435             elsif (CORE::length($char[$i+1]) == 4) {
1436 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1437 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1438             }
1439             else {
1440 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1441             }
1442             }
1443             elsif (CORE::length($char[$i-1]) == 4) {
1444 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1445 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1446             }
1447             else {
1448 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1449             }
1450             }
1451             else {
1452 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1453             }
1454              
1455 0         0 splice @char, $i-1, 3, @range;
1456             }
1457              
1458 0         0 return @char;
1459             }
1460              
1461             #
1462             # Windows-1252 open character class
1463             #
1464             sub _cc {
1465 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1466 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1467             }
1468             elsif (scalar(@_) == 1) {
1469 0         0 return sprintf('\x%02X',$_[0]);
1470             }
1471             elsif (scalar(@_) == 2) {
1472 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1473 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1474             }
1475             elsif ($_[0] == $_[1]) {
1476 0         0 return sprintf('\x%02X',$_[0]);
1477             }
1478             elsif (($_[0]+1) == $_[1]) {
1479 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1480             }
1481             else {
1482 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1483             }
1484             }
1485             else {
1486 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1487             }
1488             }
1489              
1490             #
1491             # Windows-1252 octet range
1492             #
1493             sub _octets {
1494 0     182   0 my $length = shift @_;
1495              
1496 182 50       314 if ($length == 1) {
1497 182         357 my($a1) = unpack 'C', $_[0];
1498 182         472 my($z1) = unpack 'C', $_[1];
1499              
1500 182 50       334 if ($a1 > $z1) {
1501 182         351 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1502             }
1503              
1504 0 50       0 if ($a1 == $z1) {
    50          
1505 182         407 return sprintf('\x%02X',$a1);
1506             }
1507             elsif (($a1+1) == $z1) {
1508 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1509             }
1510             else {
1511 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1512             }
1513             }
1514             else {
1515 182         1109 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1516             }
1517             }
1518              
1519             #
1520             # Windows-1252 range regexp
1521             #
1522             sub _range_regexp {
1523 0     182   0 my($length,$first,$last) = @_;
1524              
1525 182         419 my @range_regexp = ();
1526 182 50       264 if (not exists $range_tr{$length}) {
1527 182         427 return @range_regexp;
1528             }
1529              
1530 0         0 my @ranges = @{ $range_tr{$length} };
  182         331  
1531 182         389 while (my @range = splice(@ranges,0,$length)) {
1532 182         527 my $min = '';
1533 182         272 my $max = '';
1534 182         235 for (my $i=0; $i < $length; $i++) {
1535 182         473 $min .= pack 'C', $range[$i][0];
1536 182         621 $max .= pack 'C', $range[$i][-1];
1537             }
1538              
1539             # min___max
1540             # FIRST_____________LAST
1541             # (nothing)
1542              
1543 182 50 33     434 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1544             }
1545              
1546             # **********
1547             # min_________max
1548             # FIRST_____________LAST
1549             # **********
1550              
1551             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1552 182         1866 push @range_regexp, _octets($length,$first,$max,$min,$max);
1553             }
1554              
1555             # **********************
1556             # min________________max
1557             # FIRST_____________LAST
1558             # **********************
1559              
1560             elsif (($min eq $first) and ($max eq $last)) {
1561 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1562             }
1563              
1564             # *********
1565             # min___max
1566             # FIRST_____________LAST
1567             # *********
1568              
1569             elsif (($first le $min) and ($max le $last)) {
1570 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1571             }
1572              
1573             # **********************
1574             # min__________________________max
1575             # FIRST_____________LAST
1576             # **********************
1577              
1578             elsif (($min le $first) and ($last le $max)) {
1579 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1580             }
1581              
1582             # *********
1583             # min________max
1584             # FIRST_____________LAST
1585             # *********
1586              
1587             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1588 182         448 push @range_regexp, _octets($length,$min,$last,$min,$max);
1589             }
1590              
1591             # min___max
1592             # FIRST_____________LAST
1593             # (nothing)
1594              
1595             elsif ($last lt $min) {
1596             }
1597              
1598             else {
1599 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1600             }
1601             }
1602              
1603 0         0 return @range_regexp;
1604             }
1605              
1606             #
1607             # Windows-1252 open character list for qr and not qr
1608             #
1609             sub _charlist {
1610              
1611 182     358   385 my $modifier = pop @_;
1612 358         633 my @char = @_;
1613              
1614 358 100       4037 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1615              
1616             # unescape character
1617 358         944 for (my $i=0; $i <= $#char; $i++) {
1618              
1619             # escape - to ...
1620 358 100 100     1440 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1621 1125 100 100     8986 if ((0 < $i) and ($i < $#char)) {
1622 206         709 $char[$i] = '...';
1623             }
1624             }
1625              
1626             # octal escape sequence
1627             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1628 182         455 $char[$i] = octchr($1);
1629             }
1630              
1631             # hexadecimal escape sequence
1632             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1633 0         0 $char[$i] = hexchr($1);
1634             }
1635              
1636             # \b{...} --> b\{...}
1637             # \B{...} --> B\{...}
1638             # \N{CHARNAME} --> N\{CHARNAME}
1639             # \p{PROPERTY} --> p\{PROPERTY}
1640             # \P{PROPERTY} --> P\{PROPERTY}
1641             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1642 0         0 $char[$i] = $1 . '\\' . $2;
1643             }
1644              
1645             # \p, \P, \X --> p, P, X
1646             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1647 0         0 $char[$i] = $1;
1648             }
1649              
1650             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1651 0         0 $char[$i] = CORE::chr oct $1;
1652             }
1653             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1654 0         0 $char[$i] = CORE::chr hex $1;
1655             }
1656             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1657 22         95 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1658             }
1659             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1660             $char[$i] = {
1661             '\0' => "\0",
1662             '\n' => "\n",
1663             '\r' => "\r",
1664             '\t' => "\t",
1665             '\f' => "\f",
1666             '\b' => "\x08", # \b means backspace in character class
1667             '\a' => "\a",
1668             '\e' => "\e",
1669             '\d' => '[0-9]',
1670              
1671             # Vertical tabs are now whitespace
1672             # \s in a regex now matches a vertical tab in all circumstances.
1673             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1674             # \t \n \v \f \r space
1675             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1676             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1677             '\s' => '\s',
1678              
1679             '\w' => '[0-9A-Z_a-z]',
1680             '\D' => '${Ewindows1252::eD}',
1681             '\S' => '${Ewindows1252::eS}',
1682             '\W' => '${Ewindows1252::eW}',
1683              
1684             '\H' => '${Ewindows1252::eH}',
1685             '\V' => '${Ewindows1252::eV}',
1686             '\h' => '[\x09\x20]',
1687             '\v' => '[\x0A\x0B\x0C\x0D]',
1688             '\R' => '${Ewindows1252::eR}',
1689              
1690 0         0 }->{$1};
1691             }
1692              
1693             # POSIX-style character classes
1694             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1695             $char[$i] = {
1696              
1697             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1698             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1699             '[:^lower:]' => '${Ewindows1252::not_lower_i}',
1700             '[:^upper:]' => '${Ewindows1252::not_upper_i}',
1701              
1702 25         431 }->{$1};
1703             }
1704             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1705             $char[$i] = {
1706              
1707             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1708             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1709             '[:ascii:]' => '[\x00-\x7F]',
1710             '[:blank:]' => '[\x09\x20]',
1711             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1712             '[:digit:]' => '[\x30-\x39]',
1713             '[:graph:]' => '[\x21-\x7F]',
1714             '[:lower:]' => '[\x61-\x7A]',
1715             '[:print:]' => '[\x20-\x7F]',
1716             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1717              
1718             # P.174 POSIX-Style Character Classes
1719             # in Chapter 5: Pattern Matching
1720             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1721              
1722             # P.311 11.2.4 Character Classes and other Special Escapes
1723             # in Chapter 11: perlre: Perl regular expressions
1724             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1725              
1726             # P.210 POSIX-Style Character Classes
1727             # in Chapter 5: Pattern Matching
1728             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1729              
1730             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1731              
1732             '[:upper:]' => '[\x41-\x5A]',
1733             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1734             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1735             '[:^alnum:]' => '${Ewindows1252::not_alnum}',
1736             '[:^alpha:]' => '${Ewindows1252::not_alpha}',
1737             '[:^ascii:]' => '${Ewindows1252::not_ascii}',
1738             '[:^blank:]' => '${Ewindows1252::not_blank}',
1739             '[:^cntrl:]' => '${Ewindows1252::not_cntrl}',
1740             '[:^digit:]' => '${Ewindows1252::not_digit}',
1741             '[:^graph:]' => '${Ewindows1252::not_graph}',
1742             '[:^lower:]' => '${Ewindows1252::not_lower}',
1743             '[:^print:]' => '${Ewindows1252::not_print}',
1744             '[:^punct:]' => '${Ewindows1252::not_punct}',
1745             '[:^space:]' => '${Ewindows1252::not_space}',
1746             '[:^upper:]' => '${Ewindows1252::not_upper}',
1747             '[:^word:]' => '${Ewindows1252::not_word}',
1748             '[:^xdigit:]' => '${Ewindows1252::not_xdigit}',
1749              
1750 8         53 }->{$1};
1751             }
1752             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1753 70         1524 $char[$i] = $1;
1754             }
1755             }
1756              
1757             # open character list
1758 7         44 my @singleoctet = ();
1759 358         951 my @multipleoctet = ();
1760 358         532 for (my $i=0; $i <= $#char; ) {
1761              
1762             # escaped -
1763 358 100 100     951 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1764 943         4332 $i += 1;
1765 182         246 next;
1766             }
1767              
1768             # make range regexp
1769             elsif ($char[$i] eq '...') {
1770              
1771             # range error
1772 182 50       330 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1773 182         684 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1774             }
1775             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1776 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1777 182         460 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1778             }
1779             }
1780              
1781             # make range regexp per length
1782 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1783 182         514 my @regexp = ();
1784              
1785             # is first and last
1786 182 50 33     282 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1787 182         594 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1788             }
1789              
1790             # is first
1791             elsif ($length == CORE::length($char[$i-1])) {
1792 182         482 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1793             }
1794              
1795             # is inside in first and last
1796             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1797 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1798             }
1799              
1800             # is last
1801             elsif ($length == CORE::length($char[$i+1])) {
1802 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1803             }
1804              
1805             else {
1806 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1807             }
1808              
1809 0 50       0 if ($length == 1) {
1810 182         338 push @singleoctet, @regexp;
1811             }
1812             else {
1813 182         464 push @multipleoctet, @regexp;
1814             }
1815             }
1816              
1817 0         0 $i += 2;
1818             }
1819              
1820             # with /i modifier
1821             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1822 182 100       372 if ($modifier =~ /i/oxms) {
1823 493         828 my $uc = Ewindows1252::uc($char[$i]);
1824 24         100 my $fc = Ewindows1252::fc($char[$i]);
1825 24 50       47 if ($uc ne $fc) {
1826 24 50       45 if (CORE::length($fc) == 1) {
1827 24         107 push @singleoctet, $uc, $fc;
1828             }
1829             else {
1830 24         49 push @singleoctet, $uc;
1831 0         0 push @multipleoctet, $fc;
1832             }
1833             }
1834             else {
1835 0         0 push @singleoctet, $char[$i];
1836             }
1837             }
1838             else {
1839 0         0 push @singleoctet, $char[$i];
1840             }
1841 469         700 $i += 1;
1842             }
1843              
1844             # single character of single octet code
1845             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1846 493         806 push @singleoctet, "\t", "\x20";
1847 0         0 $i += 1;
1848             }
1849             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1850 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1851 0         0 $i += 1;
1852             }
1853             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1854 0         0 push @singleoctet, $char[$i];
1855 2         7 $i += 1;
1856             }
1857              
1858             # single character of multiple-octet code
1859             else {
1860 2         4 push @multipleoctet, $char[$i];
1861 84         181 $i += 1;
1862             }
1863             }
1864              
1865             # quote metachar
1866 84         151 for (@singleoctet) {
1867 358 50       856 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1868 701         3167 $_ = '-';
1869             }
1870             elsif (/\A \n \z/oxms) {
1871 0         0 $_ = '\n';
1872             }
1873             elsif (/\A \r \z/oxms) {
1874 8         29 $_ = '\r';
1875             }
1876             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1877 8         27 $_ = sprintf('\x%02X', CORE::ord $1);
1878             }
1879             elsif (/\A [\x00-\xFF] \z/oxms) {
1880 72         228 $_ = quotemeta $_;
1881             }
1882             }
1883              
1884             # return character list
1885 429         694 return \@singleoctet, \@multipleoctet;
1886             }
1887              
1888             #
1889             # Windows-1252 octal escape sequence
1890             #
1891             sub octchr {
1892 358     5 0 1200 my($octdigit) = @_;
1893              
1894 5         13 my @binary = ();
1895 5         6 for my $octal (split(//,$octdigit)) {
1896             push @binary, {
1897             '0' => '000',
1898             '1' => '001',
1899             '2' => '010',
1900             '3' => '011',
1901             '4' => '100',
1902             '5' => '101',
1903             '6' => '110',
1904             '7' => '111',
1905 5         26 }->{$octal};
1906             }
1907 50         176 my $binary = join '', @binary;
1908              
1909             my $octchr = {
1910             # 1234567
1911             1 => pack('B*', "0000000$binary"),
1912             2 => pack('B*', "000000$binary"),
1913             3 => pack('B*', "00000$binary"),
1914             4 => pack('B*', "0000$binary"),
1915             5 => pack('B*', "000$binary"),
1916             6 => pack('B*', "00$binary"),
1917             7 => pack('B*', "0$binary"),
1918             0 => pack('B*', "$binary"),
1919              
1920 5         15 }->{CORE::length($binary) % 8};
1921              
1922 5         57 return $octchr;
1923             }
1924              
1925             #
1926             # Windows-1252 hexadecimal escape sequence
1927             #
1928             sub hexchr {
1929 5     5 0 18 my($hexdigit) = @_;
1930              
1931             my $hexchr = {
1932             1 => pack('H*', "0$hexdigit"),
1933             0 => pack('H*', "$hexdigit"),
1934              
1935 5         15 }->{CORE::length($_[0]) % 2};
1936              
1937 5         43 return $hexchr;
1938             }
1939              
1940             #
1941             # Windows-1252 open character list for qr
1942             #
1943             sub charlist_qr {
1944              
1945 5     314 0 19 my $modifier = pop @_;
1946 314         722 my @char = @_;
1947              
1948 314         783 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1949 314         906 my @singleoctet = @$singleoctet;
1950 314         708 my @multipleoctet = @$multipleoctet;
1951              
1952             # return character list
1953 314 100       603 if (scalar(@singleoctet) >= 1) {
1954              
1955             # with /i modifier
1956 314 100       714 if ($modifier =~ m/i/oxms) {
1957 236         514 my %singleoctet_ignorecase = ();
1958 22         34 for (@singleoctet) {
1959 22   100     42 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1960 58         249 for my $ord (hex($1) .. hex($2)) {
1961 58         169 my $char = CORE::chr($ord);
1962 78         198 my $uc = Ewindows1252::uc($char);
1963 78         168 my $fc = Ewindows1252::fc($char);
1964 78 50       135 if ($uc eq $fc) {
1965 78         137 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1966             }
1967             else {
1968 0 50       0 if (CORE::length($fc) == 1) {
1969 78         318 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1970 78         237 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1971             }
1972             else {
1973 78         306 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1974 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1975             }
1976             }
1977             }
1978             }
1979 0 50       0 if ($_ ne '') {
1980 58         137 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1981             }
1982             }
1983 0         0 my $i = 0;
1984 22         27 my @singleoctet_ignorecase = ();
1985 22         30 for my $ord (0 .. 255) {
1986 22 100       39 if (exists $singleoctet_ignorecase{$ord}) {
1987 5632         7567 push @{$singleoctet_ignorecase[$i]}, $ord;
  108         183  
1988             }
1989             else {
1990 108         281 $i++;
1991             }
1992             }
1993 5524         6390 @singleoctet = ();
1994 22         41 for my $range (@singleoctet_ignorecase) {
1995 22 100       246 if (ref $range) {
1996 3636 100       6457 if (scalar(@{$range}) == 1) {
  68 50       69  
1997 68         116 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  48         59  
1998             }
1999 48         169 elsif (scalar(@{$range}) == 2) {
2000 20         27 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2001             }
2002             else {
2003 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         25  
  20         25  
2004             }
2005             }
2006             }
2007             }
2008              
2009 20         73 my $not_anchor = '';
2010              
2011 236         396 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2012             }
2013 236 100       680 if (scalar(@multipleoctet) >= 2) {
2014 314         687 return '(?:' . join('|', @multipleoctet) . ')';
2015             }
2016             else {
2017 6         34 return $multipleoctet[0];
2018             }
2019             }
2020              
2021             #
2022             # Windows-1252 open character list for not qr
2023             #
2024             sub charlist_not_qr {
2025              
2026 308     44 0 1486 my $modifier = pop @_;
2027 44         107 my @char = @_;
2028              
2029 44         142 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2030 44         127 my @singleoctet = @$singleoctet;
2031 44         97 my @multipleoctet = @$multipleoctet;
2032              
2033             # with /i modifier
2034 44 100       80 if ($modifier =~ m/i/oxms) {
2035 44         126 my %singleoctet_ignorecase = ();
2036 10         11 for (@singleoctet) {
2037 10   66     12 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2038 10         50 for my $ord (hex($1) .. hex($2)) {
2039 10         32 my $char = CORE::chr($ord);
2040 30         38 my $uc = Ewindows1252::uc($char);
2041 30         46 my $fc = Ewindows1252::fc($char);
2042 30 50       47 if ($uc eq $fc) {
2043 30         48 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2044             }
2045             else {
2046 0 50       0 if (CORE::length($fc) == 1) {
2047 30         50 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2048 30         63 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2049             }
2050             else {
2051 30         93 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2052 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2053             }
2054             }
2055             }
2056             }
2057 0 50       0 if ($_ ne '') {
2058 10         28 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2059             }
2060             }
2061 0         0 my $i = 0;
2062 10         13 my @singleoctet_ignorecase = ();
2063 10         14 for my $ord (0 .. 255) {
2064 10 100       16 if (exists $singleoctet_ignorecase{$ord}) {
2065 2560         2950 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         59  
2066             }
2067             else {
2068 60         116 $i++;
2069             }
2070             }
2071 2500         2610 @singleoctet = ();
2072 10         15 for my $range (@singleoctet_ignorecase) {
2073 10 100       21 if (ref $range) {
2074 960 50       1502 if (scalar(@{$range}) == 1) {
  20 50       21  
2075 20         24 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2076             }
2077 0         0 elsif (scalar(@{$range}) == 2) {
2078 20         36 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2079             }
2080             else {
2081 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         22  
  20         22  
2082             }
2083             }
2084             }
2085             }
2086              
2087             # return character list
2088 20 50       87 if (scalar(@multipleoctet) >= 1) {
2089 44 0       125 if (scalar(@singleoctet) >= 1) {
2090              
2091             # any character other than multiple-octet and single octet character class
2092 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2093             }
2094             else {
2095              
2096             # any character other than multiple-octet character class
2097 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2098             }
2099             }
2100             else {
2101 0 50       0 if (scalar(@singleoctet) >= 1) {
2102              
2103             # any character other than single octet character class
2104 44         83 return '(?:[^' . join('', @singleoctet) . '])';
2105             }
2106             else {
2107              
2108             # any character
2109 44         260 return "(?:$your_char)";
2110             }
2111             }
2112             }
2113              
2114             #
2115             # open file in read mode
2116             #
2117             sub _open_r {
2118 0     408   0 my(undef,$file) = @_;
2119 204     204   3523 use Fcntl qw(O_RDONLY);
  204         656  
  204         44241  
2120 408         1178 return CORE::sysopen($_[0], $file, &O_RDONLY);
2121             }
2122              
2123             #
2124             # open file in append mode
2125             #
2126             sub _open_a {
2127 408     204   18624 my(undef,$file) = @_;
2128 204     204   1593 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         491  
  204         705529  
2129 204         715 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2130             }
2131              
2132             #
2133             # safe system
2134             #
2135             sub _systemx {
2136              
2137             # P.707 29.2.33. exec
2138             # in Chapter 29: Functions
2139             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2140             #
2141             # Be aware that in older releases of Perl, exec (and system) did not flush
2142             # your output buffer, so you needed to enable command buffering by setting $|
2143             # on one or more filehandles to avoid lost output in the case of exec, or
2144             # misordererd output in the case of system. This situation was largely remedied
2145             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2146              
2147             # P.855 exec
2148             # in Chapter 27: Functions
2149             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2150             #
2151             # In very old release of Perl (before v5.6), exec (and system) did not flush
2152             # your output buffer, so you needed to enable command buffering by setting $|
2153             # on one or more filehandles to avoid lost output with exec or misordered
2154             # output with system.
2155              
2156 204     204   63599 $| = 1;
2157              
2158             # P.565 23.1.2. Cleaning Up Your Environment
2159             # in Chapter 23: Security
2160             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2161              
2162             # P.656 Cleaning Up Your Environment
2163             # in Chapter 20: Security
2164             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2165              
2166             # local $ENV{'PATH'} = '.';
2167 204         799 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2168              
2169             # P.707 29.2.33. exec
2170             # in Chapter 29: Functions
2171             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2172             #
2173             # As we mentioned earlier, exec treats a discrete list of arguments as an
2174             # indication that it should bypass shell processing. However, there is one
2175             # place where you might still get tripped up. The exec call (and system, too)
2176             # will not distinguish between a single scalar argument and an array containing
2177             # only one element.
2178             #
2179             # @args = ("echo surprise"); # just one element in list
2180             # exec @args # still subject to shell escapes
2181             # or die "exec: $!"; # because @args == 1
2182             #
2183             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2184             # first argument as the pathname, which forces the rest of the arguments to be
2185             # interpreted as a list, even if there is only one of them:
2186             #
2187             # exec { $args[0] } @args # safe even with one-argument list
2188             # or die "can't exec @args: $!";
2189              
2190             # P.855 exec
2191             # in Chapter 27: Functions
2192             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2193             #
2194             # As we mentioned earlier, exec treats a discrete list of arguments as a
2195             # directive to bypass shell processing. However, there is one place where
2196             # you might still get tripped up. The exec call (and system, too) cannot
2197             # distinguish between a single scalar argument and an array containing
2198             # only one element.
2199             #
2200             # @args = ("echo surprise"); # just one element in list
2201             # exec @args # still subject to shell escapes
2202             # || die "exec: $!"; # because @args == 1
2203             #
2204             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2205             # argument as the pathname, which forces the rest of the arguments to be
2206             # interpreted as a list, even if there is only one of them:
2207             #
2208             # exec { $args[0] } @args # safe even with one-argument list
2209             # || die "can't exec @args: $!";
2210              
2211 204         1881 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         451  
2212             }
2213              
2214             #
2215             # Windows-1252 order to character (with parameter)
2216             #
2217             sub Ewindows1252::chr(;$) {
2218              
2219 204 0   0 0 20460153 my $c = @_ ? $_[0] : $_;
2220              
2221 0 0       0 if ($c == 0x00) {
2222 0         0 return "\x00";
2223             }
2224             else {
2225 0         0 my @chr = ();
2226 0         0 while ($c > 0) {
2227 0         0 unshift @chr, ($c % 0x100);
2228 0         0 $c = int($c / 0x100);
2229             }
2230 0         0 return pack 'C*', @chr;
2231             }
2232             }
2233              
2234             #
2235             # Windows-1252 order to character (without parameter)
2236             #
2237             sub Ewindows1252::chr_() {
2238              
2239 0     0 0 0 my $c = $_;
2240              
2241 0 0       0 if ($c == 0x00) {
2242 0         0 return "\x00";
2243             }
2244             else {
2245 0         0 my @chr = ();
2246 0         0 while ($c > 0) {
2247 0         0 unshift @chr, ($c % 0x100);
2248 0         0 $c = int($c / 0x100);
2249             }
2250 0         0 return pack 'C*', @chr;
2251             }
2252             }
2253              
2254             #
2255             # Windows-1252 path globbing (with parameter)
2256             #
2257             sub Ewindows1252::glob($) {
2258              
2259 0 0   0 0 0 if (wantarray) {
2260 0         0 my @glob = _DOS_like_glob(@_);
2261 0         0 for my $glob (@glob) {
2262 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2263             }
2264 0         0 return @glob;
2265             }
2266             else {
2267 0         0 my $glob = _DOS_like_glob(@_);
2268 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2269 0         0 return $glob;
2270             }
2271             }
2272              
2273             #
2274             # Windows-1252 path globbing (without parameter)
2275             #
2276             sub Ewindows1252::glob_() {
2277              
2278 0 0   0 0 0 if (wantarray) {
2279 0         0 my @glob = _DOS_like_glob();
2280 0         0 for my $glob (@glob) {
2281 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2282             }
2283 0         0 return @glob;
2284             }
2285             else {
2286 0         0 my $glob = _DOS_like_glob();
2287 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2288 0         0 return $glob;
2289             }
2290             }
2291              
2292             #
2293             # Windows-1252 path globbing via File::DosGlob 1.10
2294             #
2295             # Often I confuse "_dosglob" and "_doglob".
2296             # So, I renamed "_dosglob" to "_DOS_like_glob".
2297             #
2298             my %iter;
2299             my %entries;
2300             sub _DOS_like_glob {
2301              
2302             # context (keyed by second cxix argument provided by core)
2303 0     0   0 my($expr,$cxix) = @_;
2304              
2305             # glob without args defaults to $_
2306 0 0       0 $expr = $_ if not defined $expr;
2307              
2308             # represents the current user's home directory
2309             #
2310             # 7.3. Expanding Tildes in Filenames
2311             # in Chapter 7. File Access
2312             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2313             #
2314             # and File::HomeDir, File::HomeDir::Windows module
2315              
2316             # DOS-like system
2317 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2318 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2319             { my_home_MSWin32() }oxmse;
2320             }
2321              
2322             # UNIX-like system
2323 0 0 0     0 else {
  0         0  
2324             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2325             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2326             }
2327 0 0       0  
2328 0 0       0 # assume global context if not provided one
2329             $cxix = '_G_' if not defined $cxix;
2330             $iter{$cxix} = 0 if not exists $iter{$cxix};
2331 0 0       0  
2332 0         0 # if we're just beginning, do it all first
2333             if ($iter{$cxix} == 0) {
2334             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2335             }
2336 0 0       0  
2337 0         0 # chuck it all out, quick or slow
2338 0         0 if (wantarray) {
  0         0  
2339             delete $iter{$cxix};
2340             return @{delete $entries{$cxix}};
2341 0 0       0 }
  0         0  
2342 0         0 else {
  0         0  
2343             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2344             return shift @{$entries{$cxix}};
2345             }
2346 0         0 else {
2347 0         0 # return undef for EOL
2348 0         0 delete $iter{$cxix};
2349             delete $entries{$cxix};
2350             return undef;
2351             }
2352             }
2353             }
2354              
2355             #
2356             # Windows-1252 path globbing subroutine
2357             #
2358 0     0   0 sub _do_glob {
2359 0         0  
2360 0         0 my($cond,@expr) = @_;
2361             my @glob = ();
2362             my $fix_drive_relative_paths = 0;
2363 0         0  
2364 0 0       0 OUTER:
2365 0 0       0 for my $expr (@expr) {
2366             next OUTER if not defined $expr;
2367 0         0 next OUTER if $expr eq '';
2368 0         0  
2369 0         0 my @matched = ();
2370 0         0 my @globdir = ();
2371 0         0 my $head = '.';
2372             my $pathsep = '/';
2373             my $tail;
2374 0 0       0  
2375 0         0 # if argument is within quotes strip em and do no globbing
2376 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2377 0 0       0 $expr = $1;
2378 0         0 if ($cond eq 'd') {
2379             if (-d $expr) {
2380             push @glob, $expr;
2381             }
2382 0 0       0 }
2383 0         0 else {
2384             if (-e $expr) {
2385             push @glob, $expr;
2386 0         0 }
2387             }
2388             next OUTER;
2389             }
2390              
2391 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2392 0 0       0 # to h:./*.pm to expand correctly
2393 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2394             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2395             $fix_drive_relative_paths = 1;
2396             }
2397 0 0       0 }
2398 0 0       0  
2399 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2400 0         0 if ($tail eq '') {
2401             push @glob, $expr;
2402 0 0       0 next OUTER;
2403 0 0       0 }
2404 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2405 0         0 if (@globdir = _do_glob('d', $head)) {
2406             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2407             next OUTER;
2408 0 0 0     0 }
2409 0         0 }
2410             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2411 0         0 $head .= $pathsep;
2412             }
2413             $expr = $tail;
2414             }
2415 0 0       0  
2416 0 0       0 # If file component has no wildcards, we can avoid opendir
2417 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2418             if ($head eq '.') {
2419 0 0 0     0 $head = '';
2420 0         0 }
2421             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2422 0         0 $head .= $pathsep;
2423 0 0       0 }
2424 0 0       0 $head .= $expr;
2425 0         0 if ($cond eq 'd') {
2426             if (-d $head) {
2427             push @glob, $head;
2428             }
2429 0 0       0 }
2430 0         0 else {
2431             if (-e $head) {
2432             push @glob, $head;
2433 0         0 }
2434             }
2435 0 0       0 next OUTER;
2436 0         0 }
2437 0         0 opendir(*DIR, $head) or next OUTER;
2438             my @leaf = readdir DIR;
2439 0 0       0 closedir DIR;
2440 0         0  
2441             if ($head eq '.') {
2442 0 0 0     0 $head = '';
2443 0         0 }
2444             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2445             $head .= $pathsep;
2446 0         0 }
2447 0         0  
2448 0         0 my $pattern = '';
2449             while ($expr =~ / \G ($q_char) /oxgc) {
2450             my $char = $1;
2451              
2452             # 6.9. Matching Shell Globs as Regular Expressions
2453             # in Chapter 6. Pattern Matching
2454             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2455 0 0       0 # (and so on)
    0          
    0          
2456 0         0  
2457             if ($char eq '*') {
2458             $pattern .= "(?:$your_char)*",
2459 0         0 }
2460             elsif ($char eq '?') {
2461             $pattern .= "(?:$your_char)?", # DOS style
2462             # $pattern .= "(?:$your_char)", # UNIX style
2463 0         0 }
2464             elsif ((my $fc = Ewindows1252::fc($char)) ne $char) {
2465             $pattern .= $fc;
2466 0         0 }
2467             else {
2468             $pattern .= quotemeta $char;
2469 0     0   0 }
  0         0  
2470             }
2471             my $matchsub = sub { Ewindows1252::fc($_[0]) =~ /\A $pattern \z/xms };
2472              
2473             # if ($@) {
2474             # print STDERR "$0: $@\n";
2475             # next OUTER;
2476             # }
2477 0         0  
2478 0 0 0     0 INNER:
2479 0         0 for my $leaf (@leaf) {
2480             if ($leaf eq '.' or $leaf eq '..') {
2481 0 0 0     0 next INNER;
2482 0         0 }
2483             if ($cond eq 'd' and not -d "$head$leaf") {
2484             next INNER;
2485 0 0       0 }
2486 0         0  
2487 0         0 if (&$matchsub($leaf)) {
2488             push @matched, "$head$leaf";
2489             next INNER;
2490             }
2491              
2492             # [DOS compatibility special case]
2493 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2494              
2495             if (Ewindows1252::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2496             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2497 0 0       0 Ewindows1252::index($pattern,'\\.') != -1 # pattern has a dot.
2498 0         0 ) {
2499 0         0 if (&$matchsub("$leaf.")) {
2500             push @matched, "$head$leaf";
2501             next INNER;
2502             }
2503 0 0       0 }
2504 0         0 }
2505             if (@matched) {
2506             push @glob, @matched;
2507 0 0       0 }
2508 0         0 }
2509 0         0 if ($fix_drive_relative_paths) {
2510             for my $glob (@glob) {
2511             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2512 0         0 }
2513             }
2514             return @glob;
2515             }
2516              
2517             #
2518             # Windows-1252 parse line
2519             #
2520 0     0   0 sub _parse_line {
2521              
2522 0         0 my($line) = @_;
2523 0         0  
2524 0         0 $line .= ' ';
2525             my @piece = ();
2526             while ($line =~ /
2527             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2528             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2529 0 0       0 /oxmsg
2530             ) {
2531 0         0 push @piece, defined($1) ? $1 : $2;
2532             }
2533             return @piece;
2534             }
2535              
2536             #
2537             # Windows-1252 parse path
2538             #
2539 0     0   0 sub _parse_path {
2540              
2541 0         0 my($path,$pathsep) = @_;
2542 0         0  
2543 0         0 $path .= '/';
2544             my @subpath = ();
2545             while ($path =~ /
2546             ((?: [^\/\\] )+?) [\/\\]
2547 0         0 /oxmsg
2548             ) {
2549             push @subpath, $1;
2550 0         0 }
2551 0         0  
2552 0         0 my $tail = pop @subpath;
2553             my $head = join $pathsep, @subpath;
2554             return $head, $tail;
2555             }
2556              
2557             #
2558             # via File::HomeDir::Windows 1.00
2559             #
2560             sub my_home_MSWin32 {
2561              
2562             # A lot of unix people and unix-derived tools rely on
2563 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2564 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2565             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2566             return $ENV{'HOME'};
2567             }
2568              
2569 0         0 # Do we have a user profile?
2570             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2571             return $ENV{'USERPROFILE'};
2572             }
2573              
2574 0         0 # Some Windows use something like $ENV{'HOME'}
2575             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2576             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2577 0         0 }
2578              
2579             return undef;
2580             }
2581              
2582             #
2583             # via File::HomeDir::Unix 1.00
2584 0     0 0 0 #
2585             sub my_home {
2586 0 0 0     0 my $home;
    0 0        
2587 0         0  
2588             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2589             $home = $ENV{'HOME'};
2590             }
2591              
2592             # This is from the original code, but I'm guessing
2593 0         0 # it means "login directory" and exists on some Unixes.
2594             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2595             $home = $ENV{'LOGDIR'};
2596             }
2597              
2598             ### More-desperate methods
2599              
2600 0         0 # Light desperation on any (Unixish) platform
2601             else {
2602             $home = CORE::eval q{ (getpwuid($<))[7] };
2603             }
2604              
2605 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2606 0         0 # For example, "nobody"-like users might use /nonexistant
2607             if (defined $home and ! -d($home)) {
2608 0         0 $home = undef;
2609             }
2610             return $home;
2611             }
2612              
2613             #
2614             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2615 0     0 0 0 #
2616             sub Ewindows1252::PREMATCH {
2617             return $`;
2618             }
2619              
2620             #
2621             # ${^MATCH}, $MATCH, $& the string that matched
2622 0     0 0 0 #
2623             sub Ewindows1252::MATCH {
2624             return $&;
2625             }
2626              
2627             #
2628             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2629 0     0 0 0 #
2630             sub Ewindows1252::POSTMATCH {
2631             return $';
2632             }
2633              
2634             #
2635             # Windows-1252 character to order (with parameter)
2636             #
2637 0 0   0 1 0 sub Windows1252::ord(;$) {
2638              
2639 0 0       0 local $_ = shift if @_;
2640 0         0  
2641 0         0 if (/\A ($q_char) /oxms) {
2642 0         0 my @ord = unpack 'C*', $1;
2643 0         0 my $ord = 0;
2644             while (my $o = shift @ord) {
2645 0         0 $ord = $ord * 0x100 + $o;
2646             }
2647             return $ord;
2648 0         0 }
2649             else {
2650             return CORE::ord $_;
2651             }
2652             }
2653              
2654             #
2655             # Windows-1252 character to order (without parameter)
2656             #
2657 0 0   0 0 0 sub Windows1252::ord_() {
2658 0         0  
2659 0         0 if (/\A ($q_char) /oxms) {
2660 0         0 my @ord = unpack 'C*', $1;
2661 0         0 my $ord = 0;
2662             while (my $o = shift @ord) {
2663 0         0 $ord = $ord * 0x100 + $o;
2664             }
2665             return $ord;
2666 0         0 }
2667             else {
2668             return CORE::ord $_;
2669             }
2670             }
2671              
2672             #
2673             # Windows-1252 reverse
2674             #
2675 0 0   0 0 0 sub Windows1252::reverse(@) {
2676 0         0  
2677             if (wantarray) {
2678             return CORE::reverse @_;
2679             }
2680             else {
2681              
2682             # One of us once cornered Larry in an elevator and asked him what
2683             # problem he was solving with this, but he looked as far off into
2684             # the distance as he could in an elevator and said, "It seemed like
2685 0         0 # a good idea at the time."
2686              
2687             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2688             }
2689             }
2690              
2691             #
2692             # Windows-1252 getc (with parameter, without parameter)
2693             #
2694 0     0 0 0 sub Windows1252::getc(;*@) {
2695 0 0       0  
2696 0 0 0     0 my($package) = caller;
2697             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2698 0         0 croak 'Too many arguments for Windows1252::getc' if @_ and not wantarray;
  0         0  
2699 0         0  
2700 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2701 0         0 my $getc = '';
2702 0 0       0 for my $length ($length[0] .. $length[-1]) {
2703 0 0       0 $getc .= CORE::getc($fh);
2704 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2705             if ($getc =~ /\A ${Ewindows1252::dot_s} \z/oxms) {
2706             return wantarray ? ($getc,@_) : $getc;
2707             }
2708 0 0       0 }
2709             }
2710             return wantarray ? ($getc,@_) : $getc;
2711             }
2712              
2713             #
2714             # Windows-1252 length by character
2715             #
2716 0 0   0 1 0 sub Windows1252::length(;$) {
2717              
2718 0         0 local $_ = shift if @_;
2719 0         0  
2720             local @_ = /\G ($q_char) /oxmsg;
2721             return scalar @_;
2722             }
2723              
2724             #
2725             # Windows-1252 substr by character
2726             #
2727             BEGIN {
2728              
2729             # P.232 The lvalue Attribute
2730             # in Chapter 6: Subroutines
2731             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2732              
2733             # P.336 The lvalue Attribute
2734             # in Chapter 7: Subroutines
2735             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2736              
2737             # P.144 8.4 Lvalue subroutines
2738             # in Chapter 8: perlsub: Perl subroutines
2739 204 50 0 204 1 171147 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2740              
2741             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2742             # vv----------------------*******
2743             sub Windows1252::substr($$;$$) %s {
2744              
2745             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2746              
2747             # If the substring is beyond either end of the string, substr() returns the undefined
2748             # value and produces a warning. When used as an lvalue, specifying a substring that
2749             # is entirely outside the string raises an exception.
2750             # http://perldoc.perl.org/functions/substr.html
2751              
2752             # A return with no argument returns the scalar value undef in scalar context,
2753             # an empty list () in list context, and (naturally) nothing at all in void
2754             # context.
2755              
2756             my $offset = $_[1];
2757             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2758             return;
2759             }
2760              
2761             # substr($string,$offset,$length,$replacement)
2762             if (@_ == 4) {
2763             my(undef,undef,$length,$replacement) = @_;
2764             my $substr = join '', splice(@char, $offset, $length, $replacement);
2765             $_[0] = join '', @char;
2766              
2767             # return $substr; this doesn't work, don't say "return"
2768             $substr;
2769             }
2770              
2771             # substr($string,$offset,$length)
2772             elsif (@_ == 3) {
2773             my(undef,undef,$length) = @_;
2774             my $octet_offset = 0;
2775             my $octet_length = 0;
2776             if ($offset == 0) {
2777             $octet_offset = 0;
2778             }
2779             elsif ($offset > 0) {
2780             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2781             }
2782             else {
2783             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2784             }
2785             if ($length == 0) {
2786             $octet_length = 0;
2787             }
2788             elsif ($length > 0) {
2789             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2790             }
2791             else {
2792             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2793             }
2794             CORE::substr($_[0], $octet_offset, $octet_length);
2795             }
2796              
2797             # substr($string,$offset)
2798             else {
2799             my $octet_offset = 0;
2800             if ($offset == 0) {
2801             $octet_offset = 0;
2802             }
2803             elsif ($offset > 0) {
2804             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2805             }
2806             else {
2807             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2808             }
2809             CORE::substr($_[0], $octet_offset);
2810             }
2811             }
2812             END
2813             }
2814              
2815             #
2816             # Windows-1252 index by character
2817             #
2818 0     0 1 0 sub Windows1252::index($$;$) {
2819 0 0       0  
2820 0         0 my $index;
2821             if (@_ == 3) {
2822             $index = Ewindows1252::index($_[0], $_[1], CORE::length(Windows1252::substr($_[0], 0, $_[2])));
2823 0         0 }
2824             else {
2825             $index = Ewindows1252::index($_[0], $_[1]);
2826 0 0       0 }
2827 0         0  
2828             if ($index == -1) {
2829             return -1;
2830 0         0 }
2831             else {
2832             return Windows1252::length(CORE::substr $_[0], 0, $index);
2833             }
2834             }
2835              
2836             #
2837             # Windows-1252 rindex by character
2838             #
2839 0     0 1 0 sub Windows1252::rindex($$;$) {
2840 0 0       0  
2841 0         0 my $rindex;
2842             if (@_ == 3) {
2843             $rindex = Ewindows1252::rindex($_[0], $_[1], CORE::length(Windows1252::substr($_[0], 0, $_[2])));
2844 0         0 }
2845             else {
2846             $rindex = Ewindows1252::rindex($_[0], $_[1]);
2847 0 0       0 }
2848 0         0  
2849             if ($rindex == -1) {
2850             return -1;
2851 0         0 }
2852             else {
2853             return Windows1252::length(CORE::substr $_[0], 0, $rindex);
2854             }
2855             }
2856              
2857 204     204   1971 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         481  
  204         46452  
2858             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2859             use vars qw($slash); $slash = 'm//';
2860              
2861             # ord() to ord() or Windows1252::ord()
2862             my $function_ord = 'ord';
2863              
2864             # ord to ord or Windows1252::ord_
2865             my $function_ord_ = 'ord';
2866              
2867             # reverse to reverse or Windows1252::reverse
2868             my $function_reverse = 'reverse';
2869              
2870             # getc to getc or Windows1252::getc
2871             my $function_getc = 'getc';
2872              
2873             # P.1023 Appendix W.9 Multibyte Anchoring
2874             # of ISBN 1-56592-224-7 CJKV Information Processing
2875              
2876 204     204   1519 my $anchor = '';
  204     0   677  
  204         10159272  
2877              
2878             use vars qw($nest);
2879              
2880             # regexp of nested parens in qqXX
2881              
2882             # P.340 Matching Nested Constructs with Embedded Code
2883             # in Chapter 7: Perl
2884             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2885              
2886             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2887             [^\\()] |
2888             \( (?{$nest++}) |
2889             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2890             \\ [^c] |
2891             \\c[\x40-\x5F] |
2892             [\x00-\xFF]
2893             }xms;
2894              
2895             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2896             [^\\{}] |
2897             \{ (?{$nest++}) |
2898             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2899             \\ [^c] |
2900             \\c[\x40-\x5F] |
2901             [\x00-\xFF]
2902             }xms;
2903              
2904             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2905             [^\\\[\]] |
2906             \[ (?{$nest++}) |
2907             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2908             \\ [^c] |
2909             \\c[\x40-\x5F] |
2910             [\x00-\xFF]
2911             }xms;
2912              
2913             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2914             [^\\<>] |
2915             \< (?{$nest++}) |
2916             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2917             \\ [^c] |
2918             \\c[\x40-\x5F] |
2919             [\x00-\xFF]
2920             }xms;
2921              
2922             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2923             (?: ::)? (?:
2924             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2925             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2926             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2927             ))
2928             }xms;
2929              
2930             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2931             (?: ::)? (?:
2932             (?>[0-9]+) |
2933             [^a-zA-Z_0-9\[\]] |
2934             ^[A-Z] |
2935             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2936             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2937             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2938             ))
2939             }xms;
2940              
2941             my $qq_substr = qr{(?> Char::substr | Windows1252::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2942             }xms;
2943              
2944             # regexp of nested parens in qXX
2945             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2946             [^()] |
2947             \( (?{$nest++}) |
2948             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2949             [\x00-\xFF]
2950             }xms;
2951              
2952             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2953             [^\{\}] |
2954             \{ (?{$nest++}) |
2955             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2956             [\x00-\xFF]
2957             }xms;
2958              
2959             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2960             [^\[\]] |
2961             \[ (?{$nest++}) |
2962             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2963             [\x00-\xFF]
2964             }xms;
2965              
2966             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2967             [^<>] |
2968             \< (?{$nest++}) |
2969             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2970             [\x00-\xFF]
2971             }xms;
2972              
2973             my $matched = '';
2974             my $s_matched = '';
2975              
2976             my $tr_variable = ''; # variable of tr///
2977             my $sub_variable = ''; # variable of s///
2978             my $bind_operator = ''; # =~ or !~
2979              
2980             my @heredoc = (); # here document
2981             my @heredoc_delimiter = ();
2982             my $here_script = ''; # here script
2983              
2984             #
2985             # escape Windows-1252 script
2986 0 50   204 0 0 #
2987             sub Windows1252::escape(;$) {
2988             local($_) = $_[0] if @_;
2989              
2990             # P.359 The Study Function
2991             # in Chapter 7: Perl
2992 204         684 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2993              
2994             study $_; # Yes, I studied study yesterday.
2995              
2996             # while all script
2997              
2998             # 6.14. Matching from Where the Last Pattern Left Off
2999             # in Chapter 6. Pattern Matching
3000             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3001             # (and so on)
3002              
3003             # one member of Tag-team
3004             #
3005             # P.128 Start of match (or end of previous match): \G
3006             # P.130 Advanced Use of \G with Perl
3007             # in Chapter 3: Overview of Regular Expression Features and Flavors
3008             # P.255 Use leading anchors
3009             # P.256 Expose ^ and \G at the front expressions
3010             # in Chapter 6: Crafting an Efficient Expression
3011             # P.315 "Tag-team" matching with /gc
3012             # in Chapter 7: Perl
3013 204         602 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3014 204         390  
3015 204         978 my $e_script = '';
3016             while (not /\G \z/oxgc) { # member
3017             $e_script .= Windows1252::escape_token();
3018 75417         123296 }
3019              
3020             return $e_script;
3021             }
3022              
3023             #
3024             # escape Windows-1252 token of script
3025             #
3026             sub Windows1252::escape_token {
3027              
3028 204     75417 0 2668 # \n output here document
3029              
3030             my $ignore_modules = join('|', qw(
3031             utf8
3032             bytes
3033             charnames
3034             I18N::Japanese
3035             I18N::Collate
3036             I18N::JExt
3037             File::DosGlob
3038             Wild
3039             Wildcard
3040             Japanese
3041             ));
3042              
3043             # another member of Tag-team
3044             #
3045             # P.315 "Tag-team" matching with /gc
3046             # in Chapter 7: Perl
3047 75417 100 100     110065 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
3048 75417         3207332  
3049 12514 100       32748 if (/\G ( \n ) /oxgc) { # another member (and so on)
3050 12514         26118 my $heredoc = '';
3051             if (scalar(@heredoc_delimiter) >= 1) {
3052 174         252 $slash = 'm//';
3053 174         400  
3054             $heredoc = join '', @heredoc;
3055             @heredoc = ();
3056 174         443  
3057 174         432 # skip here document
3058             for my $heredoc_delimiter (@heredoc_delimiter) {
3059 174         1131 /\G .*? \n $heredoc_delimiter \n/xmsgc;
3060             }
3061 174         978 @heredoc_delimiter = ();
3062              
3063 174         254 $here_script = '';
3064             }
3065             return "\n" . $heredoc;
3066             }
3067 12514         39443  
3068             # ignore space, comment
3069             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
3070              
3071             # if (, elsif (, unless (, while (, until (, given (, and when (
3072              
3073             # given, when
3074              
3075             # P.225 The given Statement
3076             # in Chapter 15: Smart Matching and given-when
3077             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3078              
3079             # P.133 The given Statement
3080             # in Chapter 4: Statements and Declarations
3081             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3082 17934         72208  
3083 1401         2208 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
3084             $slash = 'm//';
3085             return $1;
3086             }
3087              
3088             # scalar variable ($scalar = ...) =~ tr///;
3089             # scalar variable ($scalar = ...) =~ s///;
3090              
3091             # state
3092              
3093             # P.68 Persistent, Private Variables
3094             # in Chapter 4: Subroutines
3095             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3096              
3097             # P.160 Persistent Lexically Scoped Variables: state
3098             # in Chapter 4: Statements and Declarations
3099             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3100              
3101             # (and so on)
3102 1401         6486  
3103             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3104 86 50       197 my $e_string = e_string($1);
    50          
3105 86         2089  
3106 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3107 0         0 $tr_variable = $e_string . e_string($1);
3108 0         0 $bind_operator = $2;
3109             $slash = 'm//';
3110             return '';
3111 0         0 }
3112 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3113 0         0 $sub_variable = $e_string . e_string($1);
3114 0         0 $bind_operator = $2;
3115             $slash = 'm//';
3116             return '';
3117 0         0 }
3118 86         169 else {
3119             $slash = 'div';
3120             return $e_string;
3121             }
3122             }
3123              
3124 86         593 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
3125 4         9 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3126             $slash = 'div';
3127             return q{Ewindows1252::PREMATCH()};
3128             }
3129              
3130 4         14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
3131 28         57 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3132             $slash = 'div';
3133             return q{Ewindows1252::MATCH()};
3134             }
3135              
3136 28         82 # $', ${'} --> $', ${'}
3137 1         3 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3138             $slash = 'div';
3139             return $1;
3140             }
3141              
3142 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
3143 3         7 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3144             $slash = 'div';
3145             return q{Ewindows1252::POSTMATCH()};
3146             }
3147              
3148             # scalar variable $scalar =~ tr///;
3149             # scalar variable $scalar =~ s///;
3150             # substr() =~ tr///;
3151 3         10 # substr() =~ s///;
3152             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3153 1671 100       3844 my $scalar = e_string($1);
    100          
3154 1671         8162  
3155 1         4 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3156 1         2 $tr_variable = $scalar;
3157 1         3 $bind_operator = $1;
3158             $slash = 'm//';
3159             return '';
3160 1         3 }
3161 61         195 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3162 61         123 $sub_variable = $scalar;
3163 61         89 $bind_operator = $1;
3164             $slash = 'm//';
3165             return '';
3166 61         199 }
3167 1609         2645 else {
3168             $slash = 'div';
3169             return $scalar;
3170             }
3171             }
3172              
3173 1609         4647 # end of statement
3174             elsif (/\G ( [,;] ) /oxgc) {
3175             $slash = 'm//';
3176 4990         10793  
3177             # clear tr/// variable
3178             $tr_variable = '';
3179 4990         6758  
3180             # clear s/// variable
3181 4990         5999 $sub_variable = '';
3182              
3183 4990         6339 $bind_operator = '';
3184              
3185             return $1;
3186             }
3187              
3188 4990         17802 # bareword
3189             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3190             return $1;
3191             }
3192              
3193 0         0 # $0 --> $0
3194 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3195             $slash = 'div';
3196             return $1;
3197 2         8 }
3198 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3199             $slash = 'div';
3200             return $1;
3201             }
3202              
3203 0         0 # $$ --> $$
3204 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3205             $slash = 'div';
3206             return $1;
3207             }
3208              
3209             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3210 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3211 4         9 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3212             $slash = 'div';
3213             return e_capture($1);
3214 4         8 }
3215 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3216             $slash = 'div';
3217             return e_capture($1);
3218             }
3219              
3220 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3221 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3222             $slash = 'div';
3223             return e_capture($1.'->'.$2);
3224             }
3225              
3226 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3227 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3228             $slash = 'div';
3229             return e_capture($1.'->'.$2);
3230             }
3231              
3232 0         0 # $$foo
3233 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3234             $slash = 'div';
3235             return e_capture($1);
3236             }
3237              
3238 0         0 # ${ foo }
3239 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3240             $slash = 'div';
3241             return '${' . $1 . '}';
3242             }
3243              
3244 0         0 # ${ ... }
3245 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3246             $slash = 'div';
3247             return e_capture($1);
3248             }
3249              
3250             # variable or function
3251 0         0 # $ @ % & * $ #
3252 42         80 elsif (/\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
3253             $slash = 'div';
3254             return $1;
3255             }
3256             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3257 42         143 # $ @ # \ ' " / ? ( ) [ ] < >
3258 62         135 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3259             $slash = 'div';
3260             return $1;
3261             }
3262              
3263 62         218 # while ()
3264             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3265             return $1;
3266             }
3267              
3268             # while () --- glob
3269              
3270             # avoid "Error: Runtime exception" of perl version 5.005_03
3271 0         0  
3272             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3273             return 'while ($_ = Ewindows1252::glob("' . $1 . '"))';
3274             }
3275              
3276 0         0 # while (glob)
3277             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3278             return 'while ($_ = Ewindows1252::glob_)';
3279             }
3280              
3281 0         0 # while (glob(WILDCARD))
3282             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3283             return 'while ($_ = Ewindows1252::glob';
3284             }
3285 0         0  
  248         568  
3286             # doit if, doit unless, doit while, doit until, doit for, doit when
3287             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3288 248         888  
  19         37  
3289 19         70 # subroutines of package Ewindows1252
  0         0  
3290 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         71  
3291 13         87 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3292 0         0 elsif (/\G \b Windows1252::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         180  
3293 114         341 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         7  
3294 2         7 elsif (/\G \b Windows1252::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Windows1252::escape'; }
  0         0  
3295 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         8  
3296 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::chop'; }
  0         0  
3297 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3298 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3299 0         0 elsif (/\G \b Windows1252::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Windows1252::index'; }
  2         7  
3300 2         9 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::index'; }
  0         0  
3301 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3302 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3303 0         0 elsif (/\G \b Windows1252::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Windows1252::rindex'; }
  1         3  
3304 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::rindex'; }
  0         0  
3305 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lc'; }
  1         13  
3306 1         7 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lcfirst'; }
  0         0  
3307 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::uc'; }
  6         12  
3308             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::ucfirst'; }
3309             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::fc'; }
3310 6         19  
  0         0  
3311 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3312 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3313 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3314 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3315 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3316 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3317             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3318 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3319 0         0  
  0         0  
3320 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3321 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3322 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3323 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3324 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3325             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3326             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3327 0         0  
  0         0  
3328 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3329 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3330 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3331             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3332 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         7  
3333 2         7  
  2         8  
3334 2         8 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         71  
3335 36         140 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
3336 2         8 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::chr'; }
  8         13  
3337 8         27 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3338 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3339 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ewindows1252::glob'; }
  0         0  
3340 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lc_'; }
  0         0  
3341 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::lcfirst_'; }
  0         0  
3342 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::uc_'; }
  0         0  
3343 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::ucfirst_'; }
  0         0  
3344             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::fc_'; }
3345 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3346 0         0  
  0         0  
3347 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3348 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3349 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::chr_'; }
  0         0  
3350 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3351 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3352 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ewindows1252::glob_'; }
  8         22  
3353             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3354             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3355 8         29 # split
3356             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3357 87         175 $slash = 'm//';
3358 87         136  
3359 87         318 my $e = '';
3360             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3361             $e .= $1;
3362             }
3363 85 100       477  
  87 100       5868  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3364             # end of split
3365             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ewindows1252::split' . $e; }
3366 2         7  
3367             # split scalar value
3368             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ewindows1252::split' . $e . e_string($1); }
3369 1         7  
3370 0         0 # split literal space
3371 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ewindows1252::split' . $e . qq {qq$1 $2}; }
3372 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3373 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3374 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3375 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3376 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; }
3377 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ewindows1252::split' . $e . qq {q$1 $2}; }
3378 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3379 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3380 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3381 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3382 10         43 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ewindows1252::split' . $e . qq {$1q$2 $3}; }
3383             elsif (/\G ' [ ] ' /oxgc) { return 'Ewindows1252::split' . $e . qq {' '}; }
3384             elsif (/\G " [ ] " /oxgc) { return 'Ewindows1252::split' . $e . qq {" "}; }
3385              
3386 0 0       0 # split qq//
  0         0  
3387             elsif (/\G \b (qq) \b /oxgc) {
3388 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3389 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3390 0         0 while (not /\G \z/oxgc) {
3391 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3392 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3393 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3394 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3395 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3396             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3397 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3398             }
3399             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3400             }
3401             }
3402              
3403 0 50       0 # split qr//
  12         401  
3404             elsif (/\G \b (qr) \b /oxgc) {
3405 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3406 12 50       62 else {
  12 50       3065  
    50          
    50          
    50          
    50          
    50          
    50          
3407 0         0 while (not /\G \z/oxgc) {
3408 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3409 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3410 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3411 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3412 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3413 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3414             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3415 12         85 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3416             }
3417             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3418             }
3419             }
3420              
3421 0 0       0 # split q//
  0         0  
3422             elsif (/\G \b (q) \b /oxgc) {
3423 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3424 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3425 0         0 while (not /\G \z/oxgc) {
3426 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3427 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3428 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3429 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3430 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3431             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3432 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3433             }
3434             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3435             }
3436             }
3437              
3438 0 50       0 # split m//
  18         466  
3439             elsif (/\G \b (m) \b /oxgc) {
3440 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3441 18 50       82 else {
  18 50       4114  
    50          
    50          
    50          
    50          
    50          
    50          
3442 0         0 while (not /\G \z/oxgc) {
3443 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3444 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3445 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3446 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3447 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3448 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3449             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3450 18         107 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3451             }
3452             die __FILE__, ": Search pattern not terminated\n";
3453             }
3454             }
3455              
3456 0         0 # split ''
3457 0         0 elsif (/\G (\') /oxgc) {
3458 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3459 0         0 while (not /\G \z/oxgc) {
3460 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3461 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3462             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3463 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3464             }
3465             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3466             }
3467              
3468 0         0 # split ""
3469 0         0 elsif (/\G (\") /oxgc) {
3470 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3471 0         0 while (not /\G \z/oxgc) {
3472 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3473 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3474             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3475 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3476             }
3477             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3478             }
3479              
3480 0         0 # split //
3481 44         133 elsif (/\G (\/) /oxgc) {
3482 44 50       214 my $regexp = '';
  381 50       1658  
    100          
    50          
3483 0         0 while (not /\G \z/oxgc) {
3484 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3485 44         199 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3486             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3487 337         692 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3488             }
3489             die __FILE__, ": Search pattern not terminated\n";
3490             }
3491             }
3492              
3493             # tr/// or y///
3494              
3495             # about [cdsrbB]* (/B modifier)
3496             #
3497             # P.559 appendix C
3498             # of ISBN 4-89052-384-7 Programming perl
3499             # (Japanese title is: Perl puroguramingu)
3500 0         0  
3501             elsif (/\G \b ( tr | y ) \b /oxgc) {
3502             my $ope = $1;
3503 3 50       7  
3504 3         52 # $1 $2 $3 $4 $5 $6
3505 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3506             my @tr = ($tr_variable,$2);
3507             return e_tr(@tr,'',$4,$6);
3508 0         0 }
3509 3         6 else {
3510 3 50       10 my $e = '';
  3 50       258  
    50          
    50          
    50          
    50          
3511             while (not /\G \z/oxgc) {
3512 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3513 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3514 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3515 0         0 while (not /\G \z/oxgc) {
3516 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3517 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3518 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3519 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3520             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3521 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3522             }
3523             die __FILE__, ": Transliteration replacement not terminated\n";
3524 0         0 }
3525 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3526 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3527 0         0 while (not /\G \z/oxgc) {
3528 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3529 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3530 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3531 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3532             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3533 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3534             }
3535             die __FILE__, ": Transliteration replacement not terminated\n";
3536 0         0 }
3537 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3538 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3539 0         0 while (not /\G \z/oxgc) {
3540 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3541 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3542 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3543 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3544             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3545 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3546             }
3547             die __FILE__, ": Transliteration replacement not terminated\n";
3548 0         0 }
3549 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3550 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3551 0         0 while (not /\G \z/oxgc) {
3552 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3553 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3554 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3555 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3556             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3557 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3558             }
3559             die __FILE__, ": Transliteration replacement not terminated\n";
3560             }
3561 0         0 # $1 $2 $3 $4 $5 $6
3562 3         12 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3563             my @tr = ($tr_variable,$2);
3564             return e_tr(@tr,'',$4,$6);
3565 3         12 }
3566             }
3567             die __FILE__, ": Transliteration pattern not terminated\n";
3568             }
3569             }
3570              
3571 0         0 # qq//
3572             elsif (/\G \b (qq) \b /oxgc) {
3573             my $ope = $1;
3574 2180 50       6283  
3575 2180         4269 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3576 0         0 if (/\G (\#) /oxgc) { # qq# #
3577 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3578 0         0 while (not /\G \z/oxgc) {
3579 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3580 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3581             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3582 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3583             }
3584             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3585             }
3586 0         0  
3587 2180         3126 else {
3588 2180 50       5932 my $e = '';
  2180 50       9422  
    100          
    50          
    50          
    0          
3589             while (not /\G \z/oxgc) {
3590             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3591              
3592 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3593 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3594 0         0 my $qq_string = '';
3595 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3596 0         0 while (not /\G \z/oxgc) {
3597 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3598             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3599 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3600 0         0 elsif (/\G (\)) /oxgc) {
3601             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3602 0         0 else { $qq_string .= $1; }
3603             }
3604 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3605             }
3606             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3607             }
3608              
3609 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3610 2150         3051 elsif (/\G (\{) /oxgc) { # qq { }
3611 2150         3453 my $qq_string = '';
3612 2150 100       4570 local $nest = 1;
  84071 50       300695  
    100          
    100          
    50          
3613 722         1422 while (not /\G \z/oxgc) {
3614 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1153         1783  
3615             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3616 1153 100       2262 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3303         5635  
3617 2150         5019 elsif (/\G (\}) /oxgc) {
3618             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3619 1153         9684 else { $qq_string .= $1; }
3620             }
3621 78893         180379 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3622             }
3623             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3624             }
3625              
3626 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3627 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3628 0         0 my $qq_string = '';
3629 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3630 0         0 while (not /\G \z/oxgc) {
3631 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3632             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3633 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3634 0         0 elsif (/\G (\]) /oxgc) {
3635             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3636 0         0 else { $qq_string .= $1; }
3637             }
3638 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3639             }
3640             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3641             }
3642              
3643 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3644 30         57 elsif (/\G (\<) /oxgc) { # qq < >
3645 30         57 my $qq_string = '';
3646 30 100       169 local $nest = 1;
  1166 50       4409  
    50          
    100          
    50          
3647 22         54 while (not /\G \z/oxgc) {
3648 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3649             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3650 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         74  
3651 30         74 elsif (/\G (\>) /oxgc) {
3652             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3653 0         0 else { $qq_string .= $1; }
3654             }
3655 1114         2342 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3656             }
3657             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3658             }
3659              
3660 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3661 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3662 0         0 my $delimiter = $1;
3663 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3664 0         0 while (not /\G \z/oxgc) {
3665 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3666 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3667             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3668 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3669             }
3670             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3671 0         0 }
3672             }
3673             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3674             }
3675             }
3676              
3677 0         0 # qr//
3678 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3679 0         0 my $ope = $1;
3680             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3681             return e_qr($ope,$1,$3,$2,$4);
3682 0         0 }
3683 0         0 else {
3684 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3685 0         0 while (not /\G \z/oxgc) {
3686 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3687 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3688 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3689 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3690 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3691 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3692             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3693 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3694             }
3695             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3696             }
3697             }
3698              
3699 0         0 # qw//
3700 16 50       71 elsif (/\G \b (qw) \b /oxgc) {
3701 16         59 my $ope = $1;
3702             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3703             return e_qw($ope,$1,$3,$2);
3704 0         0 }
3705 16         29 else {
3706 16 50       67 my $e = '';
  16 50       127  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3707             while (not /\G \z/oxgc) {
3708 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3709 16         61  
3710             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3711 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3712 0         0  
3713             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3714 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3715 0         0  
3716             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3717 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3718 0         0  
3719             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3720 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3721 0         0  
3722             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3723 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3724             }
3725             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3726             }
3727             }
3728              
3729 0         0 # qx//
3730 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3731 0         0 my $ope = $1;
3732             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3733             return e_qq($ope,$1,$3,$2);
3734 0         0 }
3735 0         0 else {
3736 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3737 0         0 while (not /\G \z/oxgc) {
3738 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3739 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3740 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3741 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3742 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3743             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3744 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3745             }
3746             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3747             }
3748             }
3749              
3750 0         0 # q//
3751             elsif (/\G \b (q) \b /oxgc) {
3752             my $ope = $1;
3753              
3754             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3755              
3756             # avoid "Error: Runtime exception" of perl version 5.005_03
3757 410 50       1135 # (and so on)
3758 410         1129  
3759 0         0 if (/\G (\#) /oxgc) { # q# #
3760 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3761 0         0 while (not /\G \z/oxgc) {
3762 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3763 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3764             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3765 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3766             }
3767             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3768             }
3769 0         0  
3770 410         836 else {
3771 410 50       1244 my $e = '';
  410 50       4987  
    100          
    50          
    100          
    50          
3772             while (not /\G \z/oxgc) {
3773             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3774              
3775 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3776 0         0 elsif (/\G (\() /oxgc) { # q ( )
3777 0         0 my $q_string = '';
3778 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3779 0         0 while (not /\G \z/oxgc) {
3780 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3781 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3782             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3783 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3784 0         0 elsif (/\G (\)) /oxgc) {
3785             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3786 0         0 else { $q_string .= $1; }
3787             }
3788 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3789             }
3790             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3791             }
3792              
3793 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3794 404         768 elsif (/\G (\{) /oxgc) { # q { }
3795 404         710 my $q_string = '';
3796 404 50       1107 local $nest = 1;
  6835 50       26187  
    50          
    100          
    100          
    50          
3797 0         0 while (not /\G \z/oxgc) {
3798 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3799 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  107         176  
3800             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3801 107 100       203 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  511         979  
3802 404         1175 elsif (/\G (\}) /oxgc) {
3803             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3804 107         233 else { $q_string .= $1; }
3805             }
3806 6217         12842 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3807             }
3808             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3809             }
3810              
3811 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3812 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3813 0         0 my $q_string = '';
3814 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3815 0         0 while (not /\G \z/oxgc) {
3816 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3817 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3818             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3819 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3820 0         0 elsif (/\G (\]) /oxgc) {
3821             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3822 0         0 else { $q_string .= $1; }
3823             }
3824 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3825             }
3826             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3827             }
3828              
3829 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3830 5         12 elsif (/\G (\<) /oxgc) { # q < >
3831 5         10 my $q_string = '';
3832 5 50       19 local $nest = 1;
  88 50       419  
    50          
    50          
    100          
    50          
3833 0         0 while (not /\G \z/oxgc) {
3834 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3835 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3836             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3837 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         13  
3838 5         16 elsif (/\G (\>) /oxgc) {
3839             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3840 0         0 else { $q_string .= $1; }
3841             }
3842 83         181 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3843             }
3844             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3845             }
3846              
3847 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3848 1         3 elsif (/\G (\S) /oxgc) { # q * *
3849 1         2 my $delimiter = $1;
3850 1 50       4 my $q_string = '';
  14 50       62  
    100          
    50          
3851 0         0 while (not /\G \z/oxgc) {
3852 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3853 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3854             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3855 13         38 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3856             }
3857             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3858 0         0 }
3859             }
3860             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3861             }
3862             }
3863              
3864 0         0 # m//
3865 209 50       539 elsif (/\G \b (m) \b /oxgc) {
3866 209         1600 my $ope = $1;
3867             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3868             return e_qr($ope,$1,$3,$2,$4);
3869 0         0 }
3870 209         334 else {
3871 209 50       551 my $e = '';
  209 50       23506  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3872 0         0 while (not /\G \z/oxgc) {
3873 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3874 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3875 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3876 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3877 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3878 10         28 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3879 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3880             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3881 199         732 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3882             }
3883             die __FILE__, ": Search pattern not terminated\n";
3884             }
3885             }
3886              
3887             # s///
3888              
3889             # about [cegimosxpradlunbB]* (/cg modifier)
3890             #
3891             # P.67 Pattern-Matching Operators
3892             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3893 0         0  
3894             elsif (/\G \b (s) \b /oxgc) {
3895             my $ope = $1;
3896 97 100       257  
3897 97         1628 # $1 $2 $3 $4 $5 $6
3898             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3899             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3900 1         5 }
3901 96         186 else {
3902 96 50       293 my $e = '';
  96 50       11792  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3903             while (not /\G \z/oxgc) {
3904 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3905 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3906 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3907             while (not /\G \z/oxgc) {
3908 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3909 0         0 # $1 $2 $3 $4
3910 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3916 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3917             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3918 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3919             }
3920             die __FILE__, ": Substitution replacement not terminated\n";
3921 0         0 }
3922 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3923 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3924             while (not /\G \z/oxgc) {
3925 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3926 0         0 # $1 $2 $3 $4
3927 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3933 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3934             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3935 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3936             }
3937             die __FILE__, ": Substitution replacement not terminated\n";
3938 0         0 }
3939 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3940 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3941             while (not /\G \z/oxgc) {
3942 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3943 0         0 # $1 $2 $3 $4
3944 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3945 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3946 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3947 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3948 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3949             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3950 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3951             }
3952             die __FILE__, ": Substitution replacement not terminated\n";
3953 0         0 }
3954 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3955 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3956             while (not /\G \z/oxgc) {
3957 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3958 0         0 # $1 $2 $3 $4
3959 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3960 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3961 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3962 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3963 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3964 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3965 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3966             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3967 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3968             }
3969             die __FILE__, ": Substitution replacement not terminated\n";
3970             }
3971 0         0 # $1 $2 $3 $4 $5 $6
3972             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3973             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3974             }
3975 21         63 # $1 $2 $3 $4 $5 $6
3976             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3977             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3978             }
3979 0         0 # $1 $2 $3 $4 $5 $6
3980             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3981             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3982             }
3983 0         0 # $1 $2 $3 $4 $5 $6
3984             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3985             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3986 75         383 }
3987             }
3988             die __FILE__, ": Substitution pattern not terminated\n";
3989             }
3990             }
3991 0         0  
3992 0         0 # require ignore module
3993 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3994             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3995             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3996 0         0  
3997 37         292 # use strict; --> use strict; no strict qw(refs);
3998 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3999             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
4000             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
4001              
4002 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
4003 2         24 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4004             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
4005             return "use $1; no strict qw(refs);";
4006 0         0 }
4007             else {
4008             return "use $1;";
4009             }
4010 2 0 0     10 }
      0        
4011 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
4012             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
4013             return "use $1; no strict qw(refs);";
4014 0         0 }
4015             else {
4016             return "use $1;";
4017             }
4018             }
4019 0         0  
4020 2         15 # ignore use module
4021 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
4022             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
4023             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
4024 0         0  
4025 0         0 # ignore no module
4026 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
4027             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
4028             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
4029 0         0  
4030             # use else
4031             elsif (/\G \b use \b /oxmsgc) { return "use"; }
4032 0         0  
4033             # use else
4034             elsif (/\G \b no \b /oxmsgc) { return "no"; }
4035              
4036 2         8 # ''
4037 848         2068 elsif (/\G (?
4038 848 100       2216 my $q_string = '';
  8319 100       27300  
    100          
    50          
4039 4         11 while (not /\G \z/oxgc) {
4040 48         93 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
4041 848         2012 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4042             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4043 7419         14899 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4044             }
4045             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4046             }
4047              
4048 0         0 # ""
4049 1788         4609 elsif (/\G (\") /oxgc) {
4050 1788 100       4566 my $qq_string = '';
  36074 100       114176  
    100          
    50          
4051 67         398 while (not /\G \z/oxgc) {
4052 12         27 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
4053 1788         4097 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4054             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4055 34207         87296 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4056             }
4057             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4058             }
4059              
4060 0         0 # ``
4061 1         3 elsif (/\G (\`) /oxgc) {
4062 1 50       4 my $qx_string = '';
  19 50       69  
    100          
    50          
4063 0         0 while (not /\G \z/oxgc) {
4064 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
4065 1         3 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4066             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4067 18         34 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4068             }
4069             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4070             }
4071              
4072 0         0 # // --- not divide operator (num / num), not defined-or
4073 453         1516 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4074 453 50       16004 my $regexp = '';
  4496 50       15388  
    100          
    50          
4075 0         0 while (not /\G \z/oxgc) {
4076 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4077 453         1799 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4078             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4079 4043         8267 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4080             }
4081             die __FILE__, ": Search pattern not terminated\n";
4082             }
4083              
4084 0         0 # ?? --- not conditional operator (condition ? then : else)
4085 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4086 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4087 0         0 while (not /\G \z/oxgc) {
4088 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
4089 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4090             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4091 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4092             }
4093             die __FILE__, ": Search pattern not terminated\n";
4094             }
4095 0         0  
  0         0  
4096             # <<>> (a safer ARGV)
4097             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
4098 0         0  
  0         0  
4099             # << (bit shift) --- not here document
4100             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
4101              
4102 0         0 # <<~'HEREDOC'
4103 6         60 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4104 6         13 $slash = 'm//';
4105             my $here_quote = $1;
4106             my $delimiter = $2;
4107 6 50       13  
4108 6         16 # get here document
4109 6         25 if ($here_script eq '') {
4110             $here_script = CORE::substr $_, pos $_;
4111 6 50       35 $here_script =~ s/.*?\n//oxm;
4112 6         203 }
4113 6         28 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4114 6         11 my $heredoc = $1;
4115 6         57 my $indent = $2;
4116 6         21 $heredoc =~ s{^$indent}{}msg; # no /ox
4117             push @heredoc, $heredoc . qq{\n$delimiter\n};
4118             push @heredoc_delimiter, qq{\\s*$delimiter};
4119 6         17 }
4120             else {
4121 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4122             }
4123             return qq{<<'$delimiter'};
4124             }
4125              
4126             # <<~\HEREDOC
4127              
4128             # P.66 2.6.6. "Here" Documents
4129             # in Chapter 2: Bits and Pieces
4130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4131              
4132             # P.73 "Here" Documents
4133             # in Chapter 2: Bits and Pieces
4134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4135 6         26  
4136 3         51 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4137 3         8 $slash = 'm//';
4138             my $here_quote = $1;
4139             my $delimiter = $2;
4140 3 50       7  
4141 3         9 # get here document
4142 3         24 if ($here_script eq '') {
4143             $here_script = CORE::substr $_, pos $_;
4144 3 50       21 $here_script =~ s/.*?\n//oxm;
4145 3         56 }
4146 3         11 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4147 3         6 my $heredoc = $1;
4148 3         68 my $indent = $2;
4149 3         16 $heredoc =~ s{^$indent}{}msg; # no /ox
4150             push @heredoc, $heredoc . qq{\n$delimiter\n};
4151             push @heredoc_delimiter, qq{\\s*$delimiter};
4152 3         8 }
4153             else {
4154 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4155             }
4156             return qq{<<\\$delimiter};
4157             }
4158              
4159 3         17 # <<~"HEREDOC"
4160 6         14 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4161 6         11 $slash = 'm//';
4162             my $here_quote = $1;
4163             my $delimiter = $2;
4164 6 50       10  
4165 6         13 # get here document
4166 6         21 if ($here_script eq '') {
4167             $here_script = CORE::substr $_, pos $_;
4168 6 50       31 $here_script =~ s/.*?\n//oxm;
4169 6         66 }
4170 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4171 6         11 my $heredoc = $1;
4172 6         48 my $indent = $2;
4173 6         18 $heredoc =~ s{^$indent}{}msg; # no /ox
4174             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4175             push @heredoc_delimiter, qq{\\s*$delimiter};
4176 6         13 }
4177             else {
4178 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4179             }
4180             return qq{<<"$delimiter"};
4181             }
4182              
4183 6         26 # <<~HEREDOC
4184 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4185 3         8 $slash = 'm//';
4186             my $here_quote = $1;
4187             my $delimiter = $2;
4188 3 50       7  
4189 3         8 # get here document
4190 3         23 if ($here_script eq '') {
4191             $here_script = CORE::substr $_, pos $_;
4192 3 50       19 $here_script =~ s/.*?\n//oxm;
4193 3         55 }
4194 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4195 3         5 my $heredoc = $1;
4196 3         37 my $indent = $2;
4197 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
4198             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4199             push @heredoc_delimiter, qq{\\s*$delimiter};
4200 3         9 }
4201             else {
4202 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4203             }
4204             return qq{<<$delimiter};
4205             }
4206              
4207 3         14 # <<~`HEREDOC`
4208 6         11 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4209 6         11 $slash = 'm//';
4210             my $here_quote = $1;
4211             my $delimiter = $2;
4212 6 50       12  
4213 6         10 # get here document
4214 6         18 if ($here_script eq '') {
4215             $here_script = CORE::substr $_, pos $_;
4216 6 50       55 $here_script =~ s/.*?\n//oxm;
4217 6         59 }
4218 6         14 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4219 6         8 my $heredoc = $1;
4220 6         46 my $indent = $2;
4221 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4222             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4223             push @heredoc_delimiter, qq{\\s*$delimiter};
4224 6         57 }
4225             else {
4226 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4227             }
4228             return qq{<<`$delimiter`};
4229             }
4230              
4231 6         24 # <<'HEREDOC'
4232 72         151 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4233 72         160 $slash = 'm//';
4234             my $here_quote = $1;
4235             my $delimiter = $2;
4236 72 50       122  
4237 72         143 # get here document
4238 72         407 if ($here_script eq '') {
4239             $here_script = CORE::substr $_, pos $_;
4240 72 50       433 $here_script =~ s/.*?\n//oxm;
4241 72         814 }
4242 72         244 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4243             push @heredoc, $1 . qq{\n$delimiter\n};
4244             push @heredoc_delimiter, $delimiter;
4245 72         113 }
4246             else {
4247 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4248             }
4249             return $here_quote;
4250             }
4251              
4252             # <<\HEREDOC
4253              
4254             # P.66 2.6.6. "Here" Documents
4255             # in Chapter 2: Bits and Pieces
4256             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4257              
4258             # P.73 "Here" Documents
4259             # in Chapter 2: Bits and Pieces
4260             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4261 72         291  
4262 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4263 0         0 $slash = 'm//';
4264             my $here_quote = $1;
4265             my $delimiter = $2;
4266 0 0       0  
4267 0         0 # get here document
4268 0         0 if ($here_script eq '') {
4269             $here_script = CORE::substr $_, pos $_;
4270 0 0       0 $here_script =~ s/.*?\n//oxm;
4271 0         0 }
4272 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4273             push @heredoc, $1 . qq{\n$delimiter\n};
4274             push @heredoc_delimiter, $delimiter;
4275 0         0 }
4276             else {
4277 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4278             }
4279             return $here_quote;
4280             }
4281              
4282 0         0 # <<"HEREDOC"
4283 36         84 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4284 36         85 $slash = 'm//';
4285             my $here_quote = $1;
4286             my $delimiter = $2;
4287 36 50       72  
4288 36         86 # get here document
4289 36         346 if ($here_script eq '') {
4290             $here_script = CORE::substr $_, pos $_;
4291 36 50       214 $here_script =~ s/.*?\n//oxm;
4292 36         442 }
4293 36         116 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4294             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4295             push @heredoc_delimiter, $delimiter;
4296 36         90 }
4297             else {
4298 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4299             }
4300             return $here_quote;
4301             }
4302              
4303 36         163 # <
4304 42         102 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4305 42         88 $slash = 'm//';
4306             my $here_quote = $1;
4307             my $delimiter = $2;
4308 42 50       78  
4309 42         113 # get here document
4310 42         305 if ($here_script eq '') {
4311             $here_script = CORE::substr $_, pos $_;
4312 42 50       336 $here_script =~ s/.*?\n//oxm;
4313 42         595 }
4314 42         281 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4315             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4316             push @heredoc_delimiter, $delimiter;
4317 42         96 }
4318             else {
4319 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4320             }
4321             return $here_quote;
4322             }
4323              
4324 42         186 # <<`HEREDOC`
4325 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4326 0         0 $slash = 'm//';
4327             my $here_quote = $1;
4328             my $delimiter = $2;
4329 0 0       0  
4330 0         0 # get here document
4331 0         0 if ($here_script eq '') {
4332             $here_script = CORE::substr $_, pos $_;
4333 0 0       0 $here_script =~ s/.*?\n//oxm;
4334 0         0 }
4335 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4336             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4337             push @heredoc_delimiter, $delimiter;
4338 0         0 }
4339             else {
4340 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4341             }
4342             return $here_quote;
4343             }
4344              
4345 0         0 # <<= <=> <= < operator
4346             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4347             return $1;
4348             }
4349              
4350 12         64 #
4351             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4352             return $1;
4353             }
4354              
4355             # --- glob
4356              
4357             # avoid "Error: Runtime exception" of perl version 5.005_03
4358 0         0  
4359             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4360             return 'Ewindows1252::glob("' . $1 . '")';
4361             }
4362 0         0  
4363             # __DATA__
4364             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4365 0         0  
4366             # __END__
4367             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4368              
4369             # \cD Control-D
4370              
4371             # P.68 2.6.8. Other Literal Tokens
4372             # in Chapter 2: Bits and Pieces
4373             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4374              
4375             # P.76 Other Literal Tokens
4376             # in Chapter 2: Bits and Pieces
4377 204         1484 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4378              
4379             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4380 0         0  
4381             # \cZ Control-Z
4382             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4383              
4384             # any operator before div
4385             elsif (/\G (
4386             -- | \+\+ |
4387 0         0 [\)\}\]]
  5081         13789  
4388              
4389             ) /oxgc) { $slash = 'div'; return $1; }
4390              
4391             # yada-yada or triple-dot operator
4392             elsif (/\G (
4393 5081         24589 \.\.\.
  7         13  
4394              
4395             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4396              
4397             # any operator before m//
4398              
4399             # //, //= (defined-or)
4400              
4401             # P.164 Logical Operators
4402             # in Chapter 10: More Control Structures
4403             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4404              
4405             # P.119 C-Style Logical (Short-Circuit) Operators
4406             # in Chapter 3: Unary and Binary Operators
4407             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4408              
4409             # (and so on)
4410              
4411             # ~~
4412              
4413             # P.221 The Smart Match Operator
4414             # in Chapter 15: Smart Matching and given-when
4415             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4416              
4417             # P.112 Smartmatch Operator
4418             # in Chapter 3: Unary and Binary Operators
4419             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4420              
4421             # (and so on)
4422              
4423             elsif (/\G ((?>
4424              
4425             !~~ | !~ | != | ! |
4426             %= | % |
4427             &&= | && | &= | &\.= | &\. | & |
4428             -= | -> | - |
4429             :(?>\s*)= |
4430             : |
4431             <<>> |
4432             <<= | <=> | <= | < |
4433             == | => | =~ | = |
4434             >>= | >> | >= | > |
4435             \*\*= | \*\* | \*= | \* |
4436             \+= | \+ |
4437             \.\. | \.= | \. |
4438             \/\/= | \/\/ |
4439             \/= | \/ |
4440             \? |
4441             \\ |
4442             \^= | \^\.= | \^\. | \^ |
4443             \b x= |
4444             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4445             ~~ | ~\. | ~ |
4446             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4447             \b(?: print )\b |
4448              
4449 7         22 [,;\(\{\[]
  8838         19748  
4450              
4451             )) /oxgc) { $slash = 'm//'; return $1; }
4452 8838         42781  
  15757         58060  
4453             # other any character
4454             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4455              
4456 15757         79726 # system error
4457             else {
4458             die __FILE__, ": Oops, this shouldn't happen!\n";
4459             }
4460             }
4461              
4462 0     1786 0 0 # escape Windows-1252 string
4463 1786         4402 sub e_string {
4464             my($string) = @_;
4465 1786         2855 my $e_string = '';
4466              
4467             local $slash = 'm//';
4468              
4469             # P.1024 Appendix W.10 Multibyte Processing
4470             # of ISBN 1-56592-224-7 CJKV Information Processing
4471 1786         2693 # (and so on)
4472              
4473             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4474 1786 100 66     14143  
4475 1786 50       8471 # without { ... }
4476 1769         3840 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4477             if ($string !~ /<
4478             return $string;
4479             }
4480             }
4481 1769         4527  
4482 17 50       69 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4483             while ($string !~ /\G \z/oxgc) {
4484             if (0) {
4485             }
4486 190         13240  
4487 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ewindows1252::PREMATCH()]}
4488 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4489             $e_string .= q{Ewindows1252::PREMATCH()};
4490             $slash = 'div';
4491             }
4492              
4493 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ewindows1252::MATCH()]}
4494 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4495             $e_string .= q{Ewindows1252::MATCH()};
4496             $slash = 'div';
4497             }
4498              
4499 0         0 # $', ${'} --> $', ${'}
4500 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4501             $e_string .= $1;
4502             $slash = 'div';
4503             }
4504              
4505 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ewindows1252::POSTMATCH()]}
4506 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4507             $e_string .= q{Ewindows1252::POSTMATCH()};
4508             $slash = 'div';
4509             }
4510              
4511 0         0 # bareword
4512 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4513             $e_string .= $1;
4514             $slash = 'div';
4515             }
4516              
4517 0         0 # $0 --> $0
4518 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4519             $e_string .= $1;
4520             $slash = 'div';
4521 0         0 }
4522 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4523             $e_string .= $1;
4524             $slash = 'div';
4525             }
4526              
4527 0         0 # $$ --> $$
4528 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4529             $e_string .= $1;
4530             $slash = 'div';
4531             }
4532              
4533             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4534 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4535 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4536             $e_string .= e_capture($1);
4537             $slash = 'div';
4538 0         0 }
4539 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4540             $e_string .= e_capture($1);
4541             $slash = 'div';
4542             }
4543              
4544 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4545 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4546             $e_string .= e_capture($1.'->'.$2);
4547             $slash = 'div';
4548             }
4549              
4550 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4551 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4552             $e_string .= e_capture($1.'->'.$2);
4553             $slash = 'div';
4554             }
4555              
4556 0         0 # $$foo
4557 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4558             $e_string .= e_capture($1);
4559             $slash = 'div';
4560             }
4561              
4562 0         0 # ${ foo }
4563 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4564             $e_string .= '${' . $1 . '}';
4565             $slash = 'div';
4566             }
4567              
4568 0         0 # ${ ... }
4569 3         9 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4570             $e_string .= e_capture($1);
4571             $slash = 'div';
4572             }
4573              
4574             # variable or function
4575 3         15 # $ @ % & * $ #
4576 7         19 elsif ($string =~ /\G ( (?: [\$\@\%\&\*] | \$\# | -> | \b sub \b) (?>\s*) (?: split | chop | index | rindex | lc | uc | fc | chr | ord | reverse | getc | tr | y | q | qq | qx | qw | m | s | qr | glob | lstat | opendir | stat | unlink | chdir ) ) \b /oxmsgc) {
4577             $e_string .= $1;
4578             $slash = 'div';
4579             }
4580             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4581 7         33 # $ @ # \ ' " / ? ( ) [ ] < >
4582 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4583             $e_string .= $1;
4584             $slash = 'div';
4585             }
4586 0         0  
  0         0  
4587 0         0 # subroutines of package Ewindows1252
  0         0  
4588 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4589 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4590 0         0 elsif ($string =~ /\G \b Windows1252::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4591 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4592 0         0 elsif ($string =~ /\G \b Windows1252::eval \b /oxgc) { $e_string .= 'eval Windows1252::escape'; $slash = 'm//'; }
  0         0  
4593 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4594 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ewindows1252::chop'; $slash = 'm//'; }
  0         0  
4595 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4596 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4597 0         0 elsif ($string =~ /\G \b Windows1252::index \b /oxgc) { $e_string .= 'Windows1252::index'; $slash = 'm//'; }
  0         0  
4598 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ewindows1252::index'; $slash = 'm//'; }
  0         0  
4599 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4600 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4601 0         0 elsif ($string =~ /\G \b Windows1252::rindex \b /oxgc) { $e_string .= 'Windows1252::rindex'; $slash = 'm//'; }
  0         0  
4602 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ewindows1252::rindex'; $slash = 'm//'; }
  0         0  
4603 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::lc'; $slash = 'm//'; }
  0         0  
4604 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::lcfirst'; $slash = 'm//'; }
  0         0  
4605 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::uc'; $slash = 'm//'; }
  0         0  
4606             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::ucfirst'; $slash = 'm//'; }
4607             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::fc'; $slash = 'm//'; }
4608 0         0  
  0         0  
4609 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4610 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4611 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4612 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4613 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4614 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4615             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4616 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4617 0         0  
  0         0  
4618 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4619 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4620 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4621 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4622 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4623             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4624             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4625 0         0  
  0         0  
4626 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4627 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4628 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4629             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4630 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4631 0         0  
  0         0  
4632 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4633 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4634 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::chr'; $slash = 'm//'; }
  0         0  
4635 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4636 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4637 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ewindows1252::glob'; $slash = 'm//'; }
  0         0  
4638 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ewindows1252::lc_'; $slash = 'm//'; }
  0         0  
4639 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ewindows1252::lcfirst_'; $slash = 'm//'; }
  0         0  
4640 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ewindows1252::uc_'; $slash = 'm//'; }
  0         0  
4641 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ewindows1252::ucfirst_'; $slash = 'm//'; }
  0         0  
4642             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ewindows1252::fc_'; $slash = 'm//'; }
4643 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4644 0         0  
  0         0  
4645 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4646 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4647 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ewindows1252::chr_'; $slash = 'm//'; }
  0         0  
4648 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4649 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4650 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ewindows1252::glob_'; $slash = 'm//'; }
  0         0  
4651             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4652             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4653 0         0 # split
4654             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4655 0         0 $slash = 'm//';
4656 0         0  
4657 0         0 my $e = '';
4658             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4659             $e .= $1;
4660             }
4661 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4662             # end of split
4663             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ewindows1252::split' . $e; }
4664 0         0  
  0         0  
4665             # split scalar value
4666             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . e_string($1); next E_STRING_LOOP; }
4667 0         0  
  0         0  
4668 0         0 # split literal space
  0         0  
4669 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4670 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4671 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4672 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4673 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4674 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4675 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4676 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4677 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4678 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4679 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4680 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4681             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {' '}; next E_STRING_LOOP; }
4682             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ewindows1252::split' . $e . qq {" "}; next E_STRING_LOOP; }
4683              
4684 0 0       0 # split qq//
  0         0  
  0         0  
4685             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4686 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4687 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4688 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4689 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4690 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4691 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4692 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4693 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4694             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4695 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
4696             }
4697             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4698             }
4699             }
4700              
4701 0 0       0 # split qr//
  0         0  
  0         0  
4702             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4703 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4704 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4705 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4706 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4707 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4708 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4709 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4710 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4711 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4712             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4713 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
4714             }
4715             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4716             }
4717             }
4718              
4719 0 0       0 # split q//
  0         0  
  0         0  
4720             elsif ($string =~ /\G \b (q) \b /oxgc) {
4721 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4722 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4723 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4724 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4725 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4726 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4727 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4728 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4729             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4730 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
4731             }
4732             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4733             }
4734             }
4735              
4736 0 0       0 # split m//
  0         0  
  0         0  
4737             elsif ($string =~ /\G \b (m) \b /oxgc) {
4738 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 # #
4739 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4740 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4741 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4742 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4743 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4744 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4745 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4746 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4747             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4748 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
4749             }
4750             die __FILE__, ": Search pattern not terminated\n";
4751             }
4752             }
4753              
4754 0         0 # split ''
4755 0         0 elsif ($string =~ /\G (\') /oxgc) {
4756 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4757 0         0 while ($string !~ /\G \z/oxgc) {
4758 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4759 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4760             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4761 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4762             }
4763             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4764             }
4765              
4766 0         0 # split ""
4767 0         0 elsif ($string =~ /\G (\") /oxgc) {
4768 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4769 0         0 while ($string !~ /\G \z/oxgc) {
4770 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4771 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4772             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4773 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4774             }
4775             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4776             }
4777              
4778 0         0 # split //
4779 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4780 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4781 0         0 while ($string !~ /\G \z/oxgc) {
4782 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4783 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4784             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4785 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4786             }
4787             die __FILE__, ": Search pattern not terminated\n";
4788             }
4789             }
4790              
4791 0         0 # qq//
4792 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4793 0         0 my $ope = $1;
4794             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4795             $e_string .= e_qq($ope,$1,$3,$2);
4796 0         0 }
4797 0         0 else {
4798 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4799 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4800 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4801 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4802 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4803 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4804             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4805 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4806             }
4807             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4808             }
4809             }
4810              
4811 0         0 # qx//
4812 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4813 0         0 my $ope = $1;
4814             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4815             $e_string .= e_qq($ope,$1,$3,$2);
4816 0         0 }
4817 0         0 else {
4818 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4819 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4820 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4821 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4822 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4823 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4824 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4825             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4826 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4827             }
4828             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4829             }
4830             }
4831              
4832 0         0 # q//
4833 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4834 0         0 my $ope = $1;
4835             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4836             $e_string .= e_q($ope,$1,$3,$2);
4837 0         0 }
4838 0         0 else {
4839 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4840 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4841 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4842 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4843 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4844 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4845             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4846 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
4847             }
4848             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4849             }
4850             }
4851 0         0  
4852             # ''
4853             elsif ($string =~ /\G (?
4854 0         0  
4855             # ""
4856             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4857 0         0  
4858             # ``
4859             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4860 0         0  
4861             # <<>> (a safer ARGV)
4862             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4863 0         0  
4864             # <<= <=> <= < operator
4865             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4866 0         0  
4867             #
4868             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4869              
4870 0         0 # --- glob
4871             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4872             $e_string .= 'Ewindows1252::glob("' . $1 . '")';
4873             }
4874              
4875 0         0 # << (bit shift) --- not here document
4876 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4877             $slash = 'm//';
4878             $e_string .= $1;
4879             }
4880              
4881 0         0 # <<~'HEREDOC'
4882 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4883 0         0 $slash = 'm//';
4884             my $here_quote = $1;
4885             my $delimiter = $2;
4886 0 0       0  
4887 0         0 # get here document
4888 0         0 if ($here_script eq '') {
4889             $here_script = CORE::substr $_, pos $_;
4890 0 0       0 $here_script =~ s/.*?\n//oxm;
4891 0         0 }
4892 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4893 0         0 my $heredoc = $1;
4894 0         0 my $indent = $2;
4895 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4896             push @heredoc, $heredoc . qq{\n$delimiter\n};
4897             push @heredoc_delimiter, qq{\\s*$delimiter};
4898 0         0 }
4899             else {
4900 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4901             }
4902             $e_string .= qq{<<'$delimiter'};
4903             }
4904              
4905 0         0 # <<~\HEREDOC
4906 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4907 0         0 $slash = 'm//';
4908             my $here_quote = $1;
4909             my $delimiter = $2;
4910 0 0       0  
4911 0         0 # get here document
4912 0         0 if ($here_script eq '') {
4913             $here_script = CORE::substr $_, pos $_;
4914 0 0       0 $here_script =~ s/.*?\n//oxm;
4915 0         0 }
4916 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4917 0         0 my $heredoc = $1;
4918 0         0 my $indent = $2;
4919 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4920             push @heredoc, $heredoc . qq{\n$delimiter\n};
4921             push @heredoc_delimiter, qq{\\s*$delimiter};
4922 0         0 }
4923             else {
4924 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4925             }
4926             $e_string .= qq{<<\\$delimiter};
4927             }
4928              
4929 0         0 # <<~"HEREDOC"
4930 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4931 0         0 $slash = 'm//';
4932             my $here_quote = $1;
4933             my $delimiter = $2;
4934 0 0       0  
4935 0         0 # get here document
4936 0         0 if ($here_script eq '') {
4937             $here_script = CORE::substr $_, pos $_;
4938 0 0       0 $here_script =~ s/.*?\n//oxm;
4939 0         0 }
4940 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4941 0         0 my $heredoc = $1;
4942 0         0 my $indent = $2;
4943 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4944             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4945             push @heredoc_delimiter, qq{\\s*$delimiter};
4946 0         0 }
4947             else {
4948 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4949             }
4950             $e_string .= qq{<<"$delimiter"};
4951             }
4952              
4953 0         0 # <<~HEREDOC
4954 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4955 0         0 $slash = 'm//';
4956             my $here_quote = $1;
4957             my $delimiter = $2;
4958 0 0       0  
4959 0         0 # get here document
4960 0         0 if ($here_script eq '') {
4961             $here_script = CORE::substr $_, pos $_;
4962 0 0       0 $here_script =~ s/.*?\n//oxm;
4963 0         0 }
4964 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4965 0         0 my $heredoc = $1;
4966 0         0 my $indent = $2;
4967 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4968             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4969             push @heredoc_delimiter, qq{\\s*$delimiter};
4970 0         0 }
4971             else {
4972 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4973             }
4974             $e_string .= qq{<<$delimiter};
4975             }
4976              
4977 0         0 # <<~`HEREDOC`
4978 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4979 0         0 $slash = 'm//';
4980             my $here_quote = $1;
4981             my $delimiter = $2;
4982 0 0       0  
4983 0         0 # get here document
4984 0         0 if ($here_script eq '') {
4985             $here_script = CORE::substr $_, pos $_;
4986 0 0       0 $here_script =~ s/.*?\n//oxm;
4987 0         0 }
4988 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4989 0         0 my $heredoc = $1;
4990 0         0 my $indent = $2;
4991 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4992             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4993             push @heredoc_delimiter, qq{\\s*$delimiter};
4994 0         0 }
4995             else {
4996 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4997             }
4998             $e_string .= qq{<<`$delimiter`};
4999             }
5000              
5001 0         0 # <<'HEREDOC'
5002 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
5003 0         0 $slash = 'm//';
5004             my $here_quote = $1;
5005             my $delimiter = $2;
5006 0 0       0  
5007 0         0 # get here document
5008 0         0 if ($here_script eq '') {
5009             $here_script = CORE::substr $_, pos $_;
5010 0 0       0 $here_script =~ s/.*?\n//oxm;
5011 0         0 }
5012 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5013             push @heredoc, $1 . qq{\n$delimiter\n};
5014             push @heredoc_delimiter, $delimiter;
5015 0         0 }
5016             else {
5017 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5018             }
5019             $e_string .= $here_quote;
5020             }
5021              
5022 0         0 # <<\HEREDOC
5023 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
5024 0         0 $slash = 'm//';
5025             my $here_quote = $1;
5026             my $delimiter = $2;
5027 0 0       0  
5028 0         0 # get here document
5029 0         0 if ($here_script eq '') {
5030             $here_script = CORE::substr $_, pos $_;
5031 0 0       0 $here_script =~ s/.*?\n//oxm;
5032 0         0 }
5033 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5034             push @heredoc, $1 . qq{\n$delimiter\n};
5035             push @heredoc_delimiter, $delimiter;
5036 0         0 }
5037             else {
5038 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5039             }
5040             $e_string .= $here_quote;
5041             }
5042              
5043 0         0 # <<"HEREDOC"
5044 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
5045 0         0 $slash = 'm//';
5046             my $here_quote = $1;
5047             my $delimiter = $2;
5048 0 0       0  
5049 0         0 # get here document
5050 0         0 if ($here_script eq '') {
5051             $here_script = CORE::substr $_, pos $_;
5052 0 0       0 $here_script =~ s/.*?\n//oxm;
5053 0         0 }
5054 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5055             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5056             push @heredoc_delimiter, $delimiter;
5057 0         0 }
5058             else {
5059 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5060             }
5061             $e_string .= $here_quote;
5062             }
5063              
5064 0         0 # <
5065 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
5066 0         0 $slash = 'm//';
5067             my $here_quote = $1;
5068             my $delimiter = $2;
5069 0 0       0  
5070 0         0 # get here document
5071 0         0 if ($here_script eq '') {
5072             $here_script = CORE::substr $_, pos $_;
5073 0 0       0 $here_script =~ s/.*?\n//oxm;
5074 0         0 }
5075 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5076             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5077             push @heredoc_delimiter, $delimiter;
5078 0         0 }
5079             else {
5080 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5081             }
5082             $e_string .= $here_quote;
5083             }
5084              
5085 0         0 # <<`HEREDOC`
5086 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
5087 0         0 $slash = 'm//';
5088             my $here_quote = $1;
5089             my $delimiter = $2;
5090 0 0       0  
5091 0         0 # get here document
5092 0         0 if ($here_script eq '') {
5093             $here_script = CORE::substr $_, pos $_;
5094 0 0       0 $here_script =~ s/.*?\n//oxm;
5095 0         0 }
5096 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
5097             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
5098             push @heredoc_delimiter, $delimiter;
5099 0         0 }
5100             else {
5101 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
5102             }
5103             $e_string .= $here_quote;
5104             }
5105              
5106             # any operator before div
5107             elsif ($string =~ /\G (
5108             -- | \+\+ |
5109 0         0 [\)\}\]]
  18         31  
5110              
5111             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5112              
5113             # yada-yada or triple-dot operator
5114             elsif ($string =~ /\G (
5115 18         53 \.\.\.
  0         0  
5116              
5117             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5118              
5119             # any operator before m//
5120             elsif ($string =~ /\G ((?>
5121              
5122             !~~ | !~ | != | ! |
5123             %= | % |
5124             &&= | && | &= | &\.= | &\. | & |
5125             -= | -> | - |
5126             :(?>\s*)= |
5127             : |
5128             <<>> |
5129             <<= | <=> | <= | < |
5130             == | => | =~ | = |
5131             >>= | >> | >= | > |
5132             \*\*= | \*\* | \*= | \* |
5133             \+= | \+ |
5134             \.\. | \.= | \. |
5135             \/\/= | \/\/ |
5136             \/= | \/ |
5137             \? |
5138             \\ |
5139             \^= | \^\.= | \^\. | \^ |
5140             \b x= |
5141             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5142             ~~ | ~\. | ~ |
5143             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5144             \b(?: print )\b |
5145              
5146 0         0 [,;\(\{\[]
  31         63  
5147              
5148             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5149 31         107  
5150             # other any character
5151             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5152              
5153 131         364 # system error
5154             else {
5155             die __FILE__, ": Oops, this shouldn't happen!\n";
5156             }
5157 0         0 }
5158              
5159             return $e_string;
5160             }
5161              
5162             #
5163             # character class
5164 17     1919 0 98 #
5165             sub character_class {
5166 1919 100       3472 my($char,$modifier) = @_;
5167 1919 100       3442  
5168 52         108 if ($char eq '.') {
5169             if ($modifier =~ /s/) {
5170             return '${Ewindows1252::dot_s}';
5171 17         59 }
5172             else {
5173             return '${Ewindows1252::dot}';
5174             }
5175 35         104 }
5176             else {
5177             return Ewindows1252::classic_character_class($char);
5178             }
5179             }
5180              
5181             #
5182             # escape capture ($1, $2, $3, ...)
5183             #
5184 1867     212 0 3639 sub e_capture {
5185              
5186             return join '', '${', $_[0], '}';
5187             }
5188              
5189             #
5190             # escape transliteration (tr/// or y///)
5191 212     3 0 767 #
5192 3         17 sub e_tr {
5193 3   50     6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5194             my $e_tr = '';
5195 3         7 $modifier ||= '';
5196              
5197             $slash = 'div';
5198 3         5  
5199             # quote character class 1
5200             $charclass = q_tr($charclass);
5201 3         7  
5202             # quote character class 2
5203             $charclass2 = q_tr($charclass2);
5204 3 50       5  
5205 3 0       10 # /b /B modifier
5206 0         0 if ($modifier =~ tr/bB//d) {
5207             if ($variable eq '') {
5208             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5209 0         0 }
5210             else {
5211             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5212             }
5213 0 100       0 }
5214 3         9 else {
5215             if ($variable eq '') {
5216             $e_tr = qq{Ewindows1252::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5217 2         6 }
5218             else {
5219             $e_tr = qq{Ewindows1252::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5220             }
5221             }
5222 1         4  
5223 3         11 # clear tr/// variable
5224             $tr_variable = '';
5225 3         4 $bind_operator = '';
5226              
5227             return $e_tr;
5228             }
5229              
5230             #
5231             # quote for escape transliteration (tr/// or y///)
5232 3     6 0 17 #
5233             sub q_tr {
5234             my($charclass) = @_;
5235 6 50       11  
    0          
    0          
    0          
    0          
    0          
5236 6         12 # quote character class
5237             if ($charclass !~ /'/oxms) {
5238             return e_q('', "'", "'", $charclass); # --> q' '
5239 6         10 }
5240             elsif ($charclass !~ /\//oxms) {
5241             return e_q('q', '/', '/', $charclass); # --> q/ /
5242 0         0 }
5243             elsif ($charclass !~ /\#/oxms) {
5244             return e_q('q', '#', '#', $charclass); # --> q# #
5245 0         0 }
5246             elsif ($charclass !~ /[\<\>]/oxms) {
5247             return e_q('q', '<', '>', $charclass); # --> q< >
5248 0         0 }
5249             elsif ($charclass !~ /[\(\)]/oxms) {
5250             return e_q('q', '(', ')', $charclass); # --> q( )
5251 0         0 }
5252             elsif ($charclass !~ /[\{\}]/oxms) {
5253             return e_q('q', '{', '}', $charclass); # --> q{ }
5254 0         0 }
5255 0 0       0 else {
5256 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5257             if ($charclass !~ /\Q$char\E/xms) {
5258             return e_q('q', $char, $char, $charclass);
5259             }
5260             }
5261 0         0 }
5262              
5263             return e_q('q', '{', '}', $charclass);
5264             }
5265              
5266             #
5267             # escape q string (q//, '')
5268 0     1264 0 0 #
5269             sub e_q {
5270 1264         4246 my($ope,$delimiter,$end_delimiter,$string) = @_;
5271              
5272 1264         2124 $slash = 'div';
5273              
5274             return join '', $ope, $delimiter, $string, $end_delimiter;
5275             }
5276              
5277             #
5278             # escape qq string (qq//, "", qx//, ``)
5279 1264     4050 0 6651 #
5280             sub e_qq {
5281 4050         10444 my($ope,$delimiter,$end_delimiter,$string) = @_;
5282              
5283 4050         6413 $slash = 'div';
5284 4050         5047  
5285             my $left_e = 0;
5286             my $right_e = 0;
5287 4050         4554  
5288             # split regexp
5289             my @char = $string =~ /\G((?>
5290             [^\\\$] |
5291             \\x\{ (?>[0-9A-Fa-f]+) \} |
5292             \\o\{ (?>[0-7]+) \} |
5293             \\N\{ (?>[^0-9\}][^\}]*) \} |
5294             \\ $q_char |
5295             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5296             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5297             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5298             \$ (?>\s* [0-9]+) |
5299             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5300             \$ \$ (?![\w\{]) |
5301             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5302             $q_char
5303 4050         159569 ))/oxmsg;
5304              
5305             for (my $i=0; $i <= $#char; $i++) {
5306 4050 50 33     14015  
    50 33        
    100          
    100          
    50          
5307 114823         401137 # "\L\u" --> "\u\L"
5308             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5309             @char[$i,$i+1] = @char[$i+1,$i];
5310             }
5311              
5312 0         0 # "\U\l" --> "\l\U"
5313             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5314             @char[$i,$i+1] = @char[$i+1,$i];
5315             }
5316              
5317 0         0 # octal escape sequence
5318             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5319             $char[$i] = Ewindows1252::octchr($1);
5320             }
5321              
5322 1         3 # hexadecimal escape sequence
5323             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5324             $char[$i] = Ewindows1252::hexchr($1);
5325             }
5326              
5327 1         4 # \N{CHARNAME} --> N{CHARNAME}
5328             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5329             $char[$i] = $1;
5330 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5331              
5332             if (0) {
5333             }
5334              
5335             # \F
5336             #
5337             # P.69 Table 2-6. Translation escapes
5338             # in Chapter 2: Bits and Pieces
5339             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5340             # (and so on)
5341 114823         1029828  
5342 0 50       0 # \u \l \U \L \F \Q \E
5343 484         1045 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5344             if ($right_e < $left_e) {
5345             $char[$i] = '\\' . $char[$i];
5346             }
5347             }
5348             elsif ($char[$i] eq '\u') {
5349              
5350             # "STRING @{[ LIST EXPR ]} MORE STRING"
5351              
5352             # P.257 Other Tricks You Can Do with Hard References
5353             # in Chapter 8: References
5354             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5355              
5356             # P.353 Other Tricks You Can Do with Hard References
5357             # in Chapter 8: References
5358             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5359              
5360 0         0 # (and so on)
5361 0         0  
5362             $char[$i] = '@{[Ewindows1252::ucfirst qq<';
5363             $left_e++;
5364 0         0 }
5365 0         0 elsif ($char[$i] eq '\l') {
5366             $char[$i] = '@{[Ewindows1252::lcfirst qq<';
5367             $left_e++;
5368 0         0 }
5369 0         0 elsif ($char[$i] eq '\U') {
5370             $char[$i] = '@{[Ewindows1252::uc qq<';
5371             $left_e++;
5372 0         0 }
5373 0         0 elsif ($char[$i] eq '\L') {
5374             $char[$i] = '@{[Ewindows1252::lc qq<';
5375             $left_e++;
5376 0         0 }
5377 24         45 elsif ($char[$i] eq '\F') {
5378             $char[$i] = '@{[Ewindows1252::fc qq<';
5379             $left_e++;
5380 24         42 }
5381 0         0 elsif ($char[$i] eq '\Q') {
5382             $char[$i] = '@{[CORE::quotemeta qq<';
5383             $left_e++;
5384 0 50       0 }
5385 24         66 elsif ($char[$i] eq '\E') {
5386 24         33 if ($right_e < $left_e) {
5387             $char[$i] = '>]}';
5388             $right_e++;
5389 24         46 }
5390             else {
5391             $char[$i] = '';
5392             }
5393 0         0 }
5394 0 0       0 elsif ($char[$i] eq '\Q') {
5395 0         0 while (1) {
5396             if (++$i > $#char) {
5397 0 0       0 last;
5398 0         0 }
5399             if ($char[$i] eq '\E') {
5400             last;
5401             }
5402             }
5403             }
5404             elsif ($char[$i] eq '\E') {
5405             }
5406              
5407             # $0 --> $0
5408             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5409             }
5410             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5411             }
5412              
5413             # $$ --> $$
5414             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5415             }
5416              
5417             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5418 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5419             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5420             $char[$i] = e_capture($1);
5421 205         401 }
5422             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5423             $char[$i] = e_capture($1);
5424             }
5425              
5426 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5427             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5428             $char[$i] = e_capture($1.'->'.$2);
5429             }
5430              
5431 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5432             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5433             $char[$i] = e_capture($1.'->'.$2);
5434             }
5435              
5436 0         0 # $$foo
5437             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5438             $char[$i] = e_capture($1);
5439             }
5440              
5441 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
5442             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5443             $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
5444             }
5445              
5446 44         114 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
5447             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5448             $char[$i] = '@{[Ewindows1252::MATCH()]}';
5449             }
5450              
5451 45         117 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
5452             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5453             $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
5454             }
5455              
5456             # ${ foo } --> ${ foo }
5457             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5458             }
5459              
5460 33         94 # ${ ... }
5461             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5462             $char[$i] = e_capture($1);
5463             }
5464             }
5465 0 50       0  
5466 4050         9135 # return string
5467             if ($left_e > $right_e) {
5468 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5469             }
5470             return join '', $ope, $delimiter, @char, $end_delimiter;
5471             }
5472              
5473             #
5474             # escape qw string (qw//)
5475 4050     16 0 38202 #
5476             sub e_qw {
5477 16         72 my($ope,$delimiter,$end_delimiter,$string) = @_;
5478              
5479             $slash = 'div';
5480 16         35  
  16         200  
5481 483 50       847 # choice again delimiter
    0          
    0          
    0          
    0          
5482 16         124 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5483             if (not $octet{$end_delimiter}) {
5484             return join '', $ope, $delimiter, $string, $end_delimiter;
5485 16         147 }
5486             elsif (not $octet{')'}) {
5487             return join '', $ope, '(', $string, ')';
5488 0         0 }
5489             elsif (not $octet{'}'}) {
5490             return join '', $ope, '{', $string, '}';
5491 0         0 }
5492             elsif (not $octet{']'}) {
5493             return join '', $ope, '[', $string, ']';
5494 0         0 }
5495             elsif (not $octet{'>'}) {
5496             return join '', $ope, '<', $string, '>';
5497 0         0 }
5498 0 0       0 else {
5499 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5500             if (not $octet{$char}) {
5501             return join '', $ope, $char, $string, $char;
5502             }
5503             }
5504             }
5505 0         0  
5506 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5507 0         0 my @string = CORE::split(/\s+/, $string);
5508 0         0 for my $string (@string) {
5509 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5510 0         0 for my $octet (@octet) {
5511             if ($octet =~ /\A (['\\]) \z/oxms) {
5512             $octet = '\\' . $1;
5513 0         0 }
5514             }
5515 0         0 $string = join '', @octet;
  0         0  
5516             }
5517             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5518             }
5519              
5520             #
5521             # escape here document (<<"HEREDOC", <
5522 0     93 0 0 #
5523             sub e_heredoc {
5524 93         253 my($string) = @_;
5525              
5526 93         168 $slash = 'm//';
5527              
5528 93         308 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5529 93         151  
5530             my $left_e = 0;
5531             my $right_e = 0;
5532 93         121  
5533             # split regexp
5534             my @char = $string =~ /\G((?>
5535             [^\\\$] |
5536             \\x\{ (?>[0-9A-Fa-f]+) \} |
5537             \\o\{ (?>[0-7]+) \} |
5538             \\N\{ (?>[^0-9\}][^\}]*) \} |
5539             \\ $q_char |
5540             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5541             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5542             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5543             \$ (?>\s* [0-9]+) |
5544             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5545             \$ \$ (?![\w\{]) |
5546             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5547             $q_char
5548 93         13925 ))/oxmsg;
5549              
5550             for (my $i=0; $i <= $#char; $i++) {
5551 93 50 33     418  
    50 33        
    100          
    100          
    50          
5552 3307         11744 # "\L\u" --> "\u\L"
5553             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5554             @char[$i,$i+1] = @char[$i+1,$i];
5555             }
5556              
5557 0         0 # "\U\l" --> "\l\U"
5558             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5559             @char[$i,$i+1] = @char[$i+1,$i];
5560             }
5561              
5562 0         0 # octal escape sequence
5563             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5564             $char[$i] = Ewindows1252::octchr($1);
5565             }
5566              
5567 1         3 # hexadecimal escape sequence
5568             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5569             $char[$i] = Ewindows1252::hexchr($1);
5570             }
5571              
5572 1         3 # \N{CHARNAME} --> N{CHARNAME}
5573             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5574             $char[$i] = $1;
5575 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5576              
5577             if (0) {
5578             }
5579 3307         50184  
5580 0 0       0 # \u \l \U \L \F \Q \E
5581 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5582             if ($right_e < $left_e) {
5583             $char[$i] = '\\' . $char[$i];
5584             }
5585 0         0 }
5586 0         0 elsif ($char[$i] eq '\u') {
5587             $char[$i] = '@{[Ewindows1252::ucfirst qq<';
5588             $left_e++;
5589 0         0 }
5590 0         0 elsif ($char[$i] eq '\l') {
5591             $char[$i] = '@{[Ewindows1252::lcfirst qq<';
5592             $left_e++;
5593 0         0 }
5594 0         0 elsif ($char[$i] eq '\U') {
5595             $char[$i] = '@{[Ewindows1252::uc qq<';
5596             $left_e++;
5597 0         0 }
5598 0         0 elsif ($char[$i] eq '\L') {
5599             $char[$i] = '@{[Ewindows1252::lc qq<';
5600             $left_e++;
5601 0         0 }
5602 0         0 elsif ($char[$i] eq '\F') {
5603             $char[$i] = '@{[Ewindows1252::fc qq<';
5604             $left_e++;
5605 0         0 }
5606 0         0 elsif ($char[$i] eq '\Q') {
5607             $char[$i] = '@{[CORE::quotemeta qq<';
5608             $left_e++;
5609 0 0       0 }
5610 0         0 elsif ($char[$i] eq '\E') {
5611 0         0 if ($right_e < $left_e) {
5612             $char[$i] = '>]}';
5613             $right_e++;
5614 0         0 }
5615             else {
5616             $char[$i] = '';
5617             }
5618 0         0 }
5619 0 0       0 elsif ($char[$i] eq '\Q') {
5620 0         0 while (1) {
5621             if (++$i > $#char) {
5622 0 0       0 last;
5623 0         0 }
5624             if ($char[$i] eq '\E') {
5625             last;
5626             }
5627             }
5628             }
5629             elsif ($char[$i] eq '\E') {
5630             }
5631              
5632             # $0 --> $0
5633             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5634             }
5635             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5636             }
5637              
5638             # $$ --> $$
5639             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5640             }
5641              
5642             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5643 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5644             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5645             $char[$i] = e_capture($1);
5646 0         0 }
5647             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5648             $char[$i] = e_capture($1);
5649             }
5650              
5651 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5652             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5653             $char[$i] = e_capture($1.'->'.$2);
5654             }
5655              
5656 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5657             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5658             $char[$i] = e_capture($1.'->'.$2);
5659             }
5660              
5661 0         0 # $$foo
5662             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5663             $char[$i] = e_capture($1);
5664             }
5665              
5666 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
5667             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5668             $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
5669             }
5670              
5671 8         44 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
5672             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5673             $char[$i] = '@{[Ewindows1252::MATCH()]}';
5674             }
5675              
5676 8         56 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
5677             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5678             $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
5679             }
5680              
5681             # ${ foo } --> ${ foo }
5682             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5683             }
5684              
5685 6         41 # ${ ... }
5686             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5687             $char[$i] = e_capture($1);
5688             }
5689             }
5690 0 50       0  
5691 93         229 # return string
5692             if ($left_e > $right_e) {
5693 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5694             }
5695             return join '', @char;
5696             }
5697              
5698             #
5699             # escape regexp (m//, qr//)
5700 93     652 0 771 #
5701 652   100     3727 sub e_qr {
5702             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5703 652         4853 $modifier ||= '';
5704 652 50       1348  
5705 652         1595 $modifier =~ tr/p//d;
5706 0         0 if ($modifier =~ /([adlu])/oxms) {
5707 0 0       0 my $line = 0;
5708 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5709 0         0 if ($filename ne __FILE__) {
5710             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5711             last;
5712 0         0 }
5713             }
5714             die qq{Unsupported modifier "$1" used at line $line.\n};
5715 0         0 }
5716              
5717             $slash = 'div';
5718 652 100       1039  
    100          
5719 652         20391 # literal null string pattern
5720 8         14 if ($string eq '') {
5721 8         10 $modifier =~ tr/bB//d;
5722             $modifier =~ tr/i//d;
5723             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5724             }
5725              
5726             # /b /B modifier
5727             elsif ($modifier =~ tr/bB//d) {
5728 8 50       43  
5729 2         7 # choice again delimiter
5730 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5731 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5732 0         0 my %octet = map {$_ => 1} @char;
5733 0         0 if (not $octet{')'}) {
5734             $delimiter = '(';
5735             $end_delimiter = ')';
5736 0         0 }
5737 0         0 elsif (not $octet{'}'}) {
5738             $delimiter = '{';
5739             $end_delimiter = '}';
5740 0         0 }
5741 0         0 elsif (not $octet{']'}) {
5742             $delimiter = '[';
5743             $end_delimiter = ']';
5744 0         0 }
5745 0         0 elsif (not $octet{'>'}) {
5746             $delimiter = '<';
5747             $end_delimiter = '>';
5748 0         0 }
5749 0 0       0 else {
5750 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5751 0         0 if (not $octet{$char}) {
5752 0         0 $delimiter = $char;
5753             $end_delimiter = $char;
5754             last;
5755             }
5756             }
5757             }
5758 0 50 33     0 }
5759 2         10  
5760             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5761             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5762 0         0 }
5763             else {
5764             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5765             }
5766 2 100       11 }
5767 642         1794  
5768             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5769             my $metachar = qr/[\@\\|[\]{^]/oxms;
5770 642         2676  
5771             # split regexp
5772             my @char = $string =~ /\G((?>
5773             [^\\\$\@\[\(] |
5774             \\x (?>[0-9A-Fa-f]{1,2}) |
5775             \\ (?>[0-7]{2,3}) |
5776             \\c [\x40-\x5F] |
5777             \\x\{ (?>[0-9A-Fa-f]+) \} |
5778             \\o\{ (?>[0-7]+) \} |
5779             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5780             \\ $q_char |
5781             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5782             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5783             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5784             [\$\@] $qq_variable |
5785             \$ (?>\s* [0-9]+) |
5786             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5787             \$ \$ (?![\w\{]) |
5788             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5789             \[\^ |
5790             \[\: (?>[a-z]+) :\] |
5791             \[\:\^ (?>[a-z]+) :\] |
5792             \(\? |
5793             $q_char
5794             ))/oxmsg;
5795 642 50       67690  
5796 642         2848 # choice again delimiter
  0         0  
5797 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5798 0         0 my %octet = map {$_ => 1} @char;
5799 0         0 if (not $octet{')'}) {
5800             $delimiter = '(';
5801             $end_delimiter = ')';
5802 0         0 }
5803 0         0 elsif (not $octet{'}'}) {
5804             $delimiter = '{';
5805             $end_delimiter = '}';
5806 0         0 }
5807 0         0 elsif (not $octet{']'}) {
5808             $delimiter = '[';
5809             $end_delimiter = ']';
5810 0         0 }
5811 0         0 elsif (not $octet{'>'}) {
5812             $delimiter = '<';
5813             $end_delimiter = '>';
5814 0         0 }
5815 0 0       0 else {
5816 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5817 0         0 if (not $octet{$char}) {
5818 0         0 $delimiter = $char;
5819             $end_delimiter = $char;
5820             last;
5821             }
5822             }
5823             }
5824 0         0 }
5825 642         1096  
5826 642         877 my $left_e = 0;
5827             my $right_e = 0;
5828             for (my $i=0; $i <= $#char; $i++) {
5829 642 50 66     2000  
    50 66        
    100          
    100          
    100          
    100          
5830 1872         10364 # "\L\u" --> "\u\L"
5831             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5832             @char[$i,$i+1] = @char[$i+1,$i];
5833             }
5834              
5835 0         0 # "\U\l" --> "\l\U"
5836             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5837             @char[$i,$i+1] = @char[$i+1,$i];
5838             }
5839              
5840 0         0 # octal escape sequence
5841             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5842             $char[$i] = Ewindows1252::octchr($1);
5843             }
5844              
5845 1         3 # hexadecimal escape sequence
5846             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5847             $char[$i] = Ewindows1252::hexchr($1);
5848             }
5849              
5850             # \b{...} --> b\{...}
5851             # \B{...} --> B\{...}
5852             # \N{CHARNAME} --> N\{CHARNAME}
5853             # \p{PROPERTY} --> p\{PROPERTY}
5854 1         3 # \P{PROPERTY} --> P\{PROPERTY}
5855             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5856             $char[$i] = $1 . '\\' . $2;
5857             }
5858              
5859 6         19 # \p, \P, \X --> p, P, X
5860             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5861             $char[$i] = $1;
5862 4 100 100     13 }
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5863              
5864             if (0) {
5865             }
5866 1872         5584  
5867 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5868 6         79 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5869             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)) {
5870             $char[$i] .= join '', splice @char, $i+1, 3;
5871 0         0 }
5872             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)) {
5873             $char[$i] .= join '', splice @char, $i+1, 2;
5874 0         0 }
5875             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)) {
5876             $char[$i] .= join '', splice @char, $i+1, 1;
5877             }
5878             }
5879              
5880 0         0 # open character class [...]
5881             elsif ($char[$i] eq '[') {
5882             my $left = $i;
5883              
5884             # [] make die "Unmatched [] in regexp ...\n"
5885 328 100       456 # (and so on)
5886 328         776  
5887             if ($char[$i+1] eq ']') {
5888             $i++;
5889 3         8 }
5890 328 50       414  
5891 1379         2094 while (1) {
5892             if (++$i > $#char) {
5893 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5894 1379         2304 }
5895             if ($char[$i] eq ']') {
5896             my $right = $i;
5897 328 100       480  
5898 328         1940 # [...]
  30         65  
5899             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5900             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);
5901 90         138 }
5902             else {
5903             splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
5904 298         1505 }
5905 328         595  
5906             $i = $left;
5907             last;
5908             }
5909             }
5910             }
5911              
5912 328         996 # open character class [^...]
5913             elsif ($char[$i] eq '[^') {
5914             my $left = $i;
5915              
5916             # [^] make die "Unmatched [] in regexp ...\n"
5917 74 100       97 # (and so on)
5918 74         170  
5919             if ($char[$i+1] eq ']') {
5920             $i++;
5921 4         7 }
5922 74 50       95  
5923 272         422 while (1) {
5924             if (++$i > $#char) {
5925 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5926 272         482 }
5927             if ($char[$i] eq ']') {
5928             my $right = $i;
5929 74 100       98  
5930 74         385 # [^...]
  30         70  
5931             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5932             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);
5933 90         151 }
5934             else {
5935             splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5936 44         192 }
5937 74         149  
5938             $i = $left;
5939             last;
5940             }
5941             }
5942             }
5943              
5944 74         194 # rewrite character class or escape character
5945             elsif (my $char = character_class($char[$i],$modifier)) {
5946             $char[$i] = $char;
5947             }
5948              
5949 139 50       376 # /i modifier
5950 20         181 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
5951             if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
5952             $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
5953 20         32 }
5954             else {
5955             $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
5956             }
5957             }
5958              
5959 0 50       0 # \u \l \U \L \F \Q \E
5960 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5961             if ($right_e < $left_e) {
5962             $char[$i] = '\\' . $char[$i];
5963             }
5964 0         0 }
5965 0         0 elsif ($char[$i] eq '\u') {
5966             $char[$i] = '@{[Ewindows1252::ucfirst qq<';
5967             $left_e++;
5968 0         0 }
5969 0         0 elsif ($char[$i] eq '\l') {
5970             $char[$i] = '@{[Ewindows1252::lcfirst qq<';
5971             $left_e++;
5972 0         0 }
5973 1         4 elsif ($char[$i] eq '\U') {
5974             $char[$i] = '@{[Ewindows1252::uc qq<';
5975             $left_e++;
5976 1         3 }
5977 1         2 elsif ($char[$i] eq '\L') {
5978             $char[$i] = '@{[Ewindows1252::lc qq<';
5979             $left_e++;
5980 1         3 }
5981 18         40 elsif ($char[$i] eq '\F') {
5982             $char[$i] = '@{[Ewindows1252::fc qq<';
5983             $left_e++;
5984 18         46 }
5985 1         2 elsif ($char[$i] eq '\Q') {
5986             $char[$i] = '@{[CORE::quotemeta qq<';
5987             $left_e++;
5988 1 50       2 }
5989 21         47 elsif ($char[$i] eq '\E') {
5990 21         34 if ($right_e < $left_e) {
5991             $char[$i] = '>]}';
5992             $right_e++;
5993 21         50 }
5994             else {
5995             $char[$i] = '';
5996             }
5997 0         0 }
5998 0 0       0 elsif ($char[$i] eq '\Q') {
5999 0         0 while (1) {
6000             if (++$i > $#char) {
6001 0 0       0 last;
6002 0         0 }
6003             if ($char[$i] eq '\E') {
6004             last;
6005             }
6006             }
6007             }
6008             elsif ($char[$i] eq '\E') {
6009             }
6010              
6011 0 0       0 # $0 --> $0
6012 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6013             if ($ignorecase) {
6014             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6015             }
6016 0 0       0 }
6017 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6018             if ($ignorecase) {
6019             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6020             }
6021             }
6022              
6023             # $$ --> $$
6024             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6025             }
6026              
6027             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6028 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6029 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6030 0         0 $char[$i] = e_capture($1);
6031             if ($ignorecase) {
6032             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6033             }
6034 0         0 }
6035 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6036 0         0 $char[$i] = e_capture($1);
6037             if ($ignorecase) {
6038             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6039             }
6040             }
6041              
6042 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6043 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6044 0         0 $char[$i] = e_capture($1.'->'.$2);
6045             if ($ignorecase) {
6046             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6047             }
6048             }
6049              
6050 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6051 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6052 0         0 $char[$i] = e_capture($1.'->'.$2);
6053             if ($ignorecase) {
6054             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6055             }
6056             }
6057              
6058 0         0 # $$foo
6059 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6060 0         0 $char[$i] = e_capture($1);
6061             if ($ignorecase) {
6062             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6063             }
6064             }
6065              
6066 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
6067 8         22 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6068             if ($ignorecase) {
6069             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::PREMATCH())]}';
6070 0         0 }
6071             else {
6072             $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
6073             }
6074             }
6075              
6076 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
6077 8         23 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6078             if ($ignorecase) {
6079             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::MATCH())]}';
6080 0         0 }
6081             else {
6082             $char[$i] = '@{[Ewindows1252::MATCH()]}';
6083             }
6084             }
6085              
6086 8 50       23 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
6087 6         17 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6088             if ($ignorecase) {
6089             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::POSTMATCH())]}';
6090 0         0 }
6091             else {
6092             $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
6093             }
6094             }
6095              
6096 6 0       19 # ${ foo }
6097 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6098             if ($ignorecase) {
6099             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6100             }
6101             }
6102              
6103 0         0 # ${ ... }
6104 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6105 0         0 $char[$i] = e_capture($1);
6106             if ($ignorecase) {
6107             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6108             }
6109             }
6110              
6111 0         0 # $scalar or @array
6112 21 100       54 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6113 21         118 $char[$i] = e_string($char[$i]);
6114             if ($ignorecase) {
6115             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6116             }
6117             }
6118              
6119 11 100 33     39 # quote character before ? + * {
    50          
6120             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6121             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6122 138         938 }
6123 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6124 0         0 my $char = $char[$i-1];
6125             if ($char[$i] eq '{') {
6126             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6127 0         0 }
6128             else {
6129             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6130             }
6131 0         0 }
6132             else {
6133             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6134             }
6135             }
6136             }
6137 127         514  
6138 642 50       2424 # make regexp string
6139 642 0 0     1477 $modifier =~ tr/i//d;
6140 0         0 if ($left_e > $right_e) {
6141             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6142             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6143 0         0 }
6144             else {
6145             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6146 0 50 33     0 }
6147 642         3588 }
6148             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6149             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6150 0         0 }
6151             else {
6152             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6153             }
6154             }
6155              
6156             #
6157             # double quote stuff
6158 642     180 0 5729 #
6159             sub qq_stuff {
6160             my($delimiter,$end_delimiter,$stuff) = @_;
6161 180 100       284  
6162 180         380 # scalar variable or array variable
6163             if ($stuff =~ /\A [\$\@] /oxms) {
6164             return $stuff;
6165             }
6166 100         342  
  80         172  
6167 80         229 # quote by delimiter
6168 80 50       192 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6169 80 50       137 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6170 80 50       120 next if $char eq $delimiter;
6171 80         145 next if $char eq $end_delimiter;
6172             if (not $octet{$char}) {
6173             return join '', 'qq', $char, $stuff, $char;
6174 80         321 }
6175             }
6176             return join '', 'qq', '<', $stuff, '>';
6177             }
6178              
6179             #
6180             # escape regexp (m'', qr'', and m''b, qr''b)
6181 0     10 0 0 #
6182 10   50     45 sub e_qr_q {
6183             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6184 10         44 $modifier ||= '';
6185 10 50       17  
6186 10         20 $modifier =~ tr/p//d;
6187 0         0 if ($modifier =~ /([adlu])/oxms) {
6188 0 0       0 my $line = 0;
6189 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6190 0         0 if ($filename ne __FILE__) {
6191             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6192             last;
6193 0         0 }
6194             }
6195             die qq{Unsupported modifier "$1" used at line $line.\n};
6196 0         0 }
6197              
6198             $slash = 'div';
6199 10 100       18  
    50          
6200 10         20 # literal null string pattern
6201 8         11 if ($string eq '') {
6202 8         11 $modifier =~ tr/bB//d;
6203             $modifier =~ tr/i//d;
6204             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6205             }
6206              
6207 8         39 # with /b /B modifier
6208             elsif ($modifier =~ tr/bB//d) {
6209             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6210             }
6211              
6212 0         0 # without /b /B modifier
6213             else {
6214             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6215             }
6216             }
6217              
6218             #
6219             # escape regexp (m'', qr'')
6220 2     2 0 7 #
6221             sub e_qr_qt {
6222 2 50       7 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6223              
6224             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6225 2         6  
6226             # split regexp
6227             my @char = $string =~ /\G((?>
6228             [^\\\[\$\@\/] |
6229             [\x00-\xFF] |
6230             \[\^ |
6231             \[\: (?>[a-z]+) \:\] |
6232             \[\:\^ (?>[a-z]+) \:\] |
6233             [\$\@\/] |
6234             \\ (?:$q_char) |
6235             (?:$q_char)
6236             ))/oxmsg;
6237 2         62  
6238 2 50 33     11 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6239             for (my $i=0; $i <= $#char; $i++) {
6240             if (0) {
6241             }
6242 2         16  
6243 0         0 # open character class [...]
6244 0 0       0 elsif ($char[$i] eq '[') {
6245 0         0 my $left = $i;
6246             if ($char[$i+1] eq ']') {
6247 0         0 $i++;
6248 0 0       0 }
6249 0         0 while (1) {
6250             if (++$i > $#char) {
6251 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6252 0         0 }
6253             if ($char[$i] eq ']') {
6254             my $right = $i;
6255 0         0  
6256             # [...]
6257 0         0 splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
6258 0         0  
6259             $i = $left;
6260             last;
6261             }
6262             }
6263             }
6264              
6265 0         0 # open character class [^...]
6266 0 0       0 elsif ($char[$i] eq '[^') {
6267 0         0 my $left = $i;
6268             if ($char[$i+1] eq ']') {
6269 0         0 $i++;
6270 0 0       0 }
6271 0         0 while (1) {
6272             if (++$i > $#char) {
6273 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6274 0         0 }
6275             if ($char[$i] eq ']') {
6276             my $right = $i;
6277 0         0  
6278             # [^...]
6279 0         0 splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6280 0         0  
6281             $i = $left;
6282             last;
6283             }
6284             }
6285             }
6286              
6287 0         0 # escape $ @ / and \
6288             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6289             $char[$i] = '\\' . $char[$i];
6290             }
6291              
6292 0         0 # rewrite character class or escape character
6293             elsif (my $char = character_class($char[$i],$modifier)) {
6294             $char[$i] = $char;
6295             }
6296              
6297 0 0       0 # /i modifier
6298 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
6299             if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
6300             $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
6301 0         0 }
6302             else {
6303             $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
6304             }
6305             }
6306              
6307 0 0       0 # quote character before ? + * {
6308             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6309             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6310 0         0 }
6311             else {
6312             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6313             }
6314             }
6315 0         0 }
6316 2         6  
6317             $delimiter = '/';
6318 2         3 $end_delimiter = '/';
6319 2         3  
6320             $modifier =~ tr/i//d;
6321             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6322             }
6323              
6324             #
6325             # escape regexp (m''b, qr''b)
6326 2     0 0 15 #
6327             sub e_qr_qb {
6328             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6329 0         0  
6330             # split regexp
6331             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6332 0         0  
6333 0 0       0 # unescape character
    0          
6334             for (my $i=0; $i <= $#char; $i++) {
6335             if (0) {
6336             }
6337 0         0  
6338             # remain \\
6339             elsif ($char[$i] eq '\\\\') {
6340             }
6341              
6342 0         0 # escape $ @ / and \
6343             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6344             $char[$i] = '\\' . $char[$i];
6345             }
6346 0         0 }
6347 0         0  
6348 0         0 $delimiter = '/';
6349             $end_delimiter = '/';
6350             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6351             }
6352              
6353             #
6354             # escape regexp (s/here//)
6355 0     76 0 0 #
6356 76   100     241 sub e_s1 {
6357             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6358 76         329 $modifier ||= '';
6359 76 50       147  
6360 76         267 $modifier =~ tr/p//d;
6361 0         0 if ($modifier =~ /([adlu])/oxms) {
6362 0 0       0 my $line = 0;
6363 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6364 0         0 if ($filename ne __FILE__) {
6365             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6366             last;
6367 0         0 }
6368             }
6369             die qq{Unsupported modifier "$1" used at line $line.\n};
6370 0         0 }
6371              
6372             $slash = 'div';
6373 76 100       147  
    50          
6374 76         250 # literal null string pattern
6375 8         11 if ($string eq '') {
6376 8         8 $modifier =~ tr/bB//d;
6377             $modifier =~ tr/i//d;
6378             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6379             }
6380              
6381             # /b /B modifier
6382             elsif ($modifier =~ tr/bB//d) {
6383 8 0       52  
6384 0         0 # choice again delimiter
6385 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6386 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6387 0         0 my %octet = map {$_ => 1} @char;
6388 0         0 if (not $octet{')'}) {
6389             $delimiter = '(';
6390             $end_delimiter = ')';
6391 0         0 }
6392 0         0 elsif (not $octet{'}'}) {
6393             $delimiter = '{';
6394             $end_delimiter = '}';
6395 0         0 }
6396 0         0 elsif (not $octet{']'}) {
6397             $delimiter = '[';
6398             $end_delimiter = ']';
6399 0         0 }
6400 0         0 elsif (not $octet{'>'}) {
6401             $delimiter = '<';
6402             $end_delimiter = '>';
6403 0         0 }
6404 0 0       0 else {
6405 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6406 0         0 if (not $octet{$char}) {
6407 0         0 $delimiter = $char;
6408             $end_delimiter = $char;
6409             last;
6410             }
6411             }
6412             }
6413 0         0 }
6414 0         0  
6415             my $prematch = '';
6416             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6417 0 100       0 }
6418 68         209  
6419             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6420             my $metachar = qr/[\@\\|[\]{^]/oxms;
6421 68         372  
6422             # split regexp
6423             my @char = $string =~ /\G((?>
6424             [^\\\$\@\[\(] |
6425             \\ (?>[1-9][0-9]*) |
6426             \\g (?>\s*) (?>[1-9][0-9]*) |
6427             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6428             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6429             \\x (?>[0-9A-Fa-f]{1,2}) |
6430             \\ (?>[0-7]{2,3}) |
6431             \\c [\x40-\x5F] |
6432             \\x\{ (?>[0-9A-Fa-f]+) \} |
6433             \\o\{ (?>[0-7]+) \} |
6434             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6435             \\ $q_char |
6436             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6437             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6438             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6439             [\$\@] $qq_variable |
6440             \$ (?>\s* [0-9]+) |
6441             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6442             \$ \$ (?![\w\{]) |
6443             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6444             \[\^ |
6445             \[\: (?>[a-z]+) :\] |
6446             \[\:\^ (?>[a-z]+) :\] |
6447             \(\? |
6448             $q_char
6449             ))/oxmsg;
6450 68 50       17360  
6451 68         467 # choice again delimiter
  0         0  
6452 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6453 0         0 my %octet = map {$_ => 1} @char;
6454 0         0 if (not $octet{')'}) {
6455             $delimiter = '(';
6456             $end_delimiter = ')';
6457 0         0 }
6458 0         0 elsif (not $octet{'}'}) {
6459             $delimiter = '{';
6460             $end_delimiter = '}';
6461 0         0 }
6462 0         0 elsif (not $octet{']'}) {
6463             $delimiter = '[';
6464             $end_delimiter = ']';
6465 0         0 }
6466 0         0 elsif (not $octet{'>'}) {
6467             $delimiter = '<';
6468             $end_delimiter = '>';
6469 0         0 }
6470 0 0       0 else {
6471 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6472 0         0 if (not $octet{$char}) {
6473 0         0 $delimiter = $char;
6474             $end_delimiter = $char;
6475             last;
6476             }
6477             }
6478             }
6479             }
6480 0         0  
  68         160  
6481             # count '('
6482 253         437 my $parens = grep { $_ eq '(' } @char;
6483 68         105  
6484 68         104 my $left_e = 0;
6485             my $right_e = 0;
6486             for (my $i=0; $i <= $#char; $i++) {
6487 68 50 33     199  
    50 33        
    100          
    100          
    50          
    50          
6488 195         1199 # "\L\u" --> "\u\L"
6489             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6490             @char[$i,$i+1] = @char[$i+1,$i];
6491             }
6492              
6493 0         0 # "\U\l" --> "\l\U"
6494             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6495             @char[$i,$i+1] = @char[$i+1,$i];
6496             }
6497              
6498 0         0 # octal escape sequence
6499             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6500             $char[$i] = Ewindows1252::octchr($1);
6501             }
6502              
6503 1         3 # hexadecimal escape sequence
6504             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6505             $char[$i] = Ewindows1252::hexchr($1);
6506             }
6507              
6508             # \b{...} --> b\{...}
6509             # \B{...} --> B\{...}
6510             # \N{CHARNAME} --> N\{CHARNAME}
6511             # \p{PROPERTY} --> p\{PROPERTY}
6512 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6513             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6514             $char[$i] = $1 . '\\' . $2;
6515             }
6516              
6517 0         0 # \p, \P, \X --> p, P, X
6518             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6519             $char[$i] = $1;
6520 0 50 66     0 }
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6521              
6522             if (0) {
6523             }
6524 195         689  
6525 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6526 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6527             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)) {
6528             $char[$i] .= join '', splice @char, $i+1, 3;
6529 0         0 }
6530             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)) {
6531             $char[$i] .= join '', splice @char, $i+1, 2;
6532 0         0 }
6533             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)) {
6534             $char[$i] .= join '', splice @char, $i+1, 1;
6535             }
6536             }
6537              
6538 0         0 # open character class [...]
6539 13 50       21 elsif ($char[$i] eq '[') {
6540 13         46 my $left = $i;
6541             if ($char[$i+1] eq ']') {
6542 0         0 $i++;
6543 13 50       21 }
6544 58         91 while (1) {
6545             if (++$i > $#char) {
6546 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6547 58         117 }
6548             if ($char[$i] eq ']') {
6549             my $right = $i;
6550 13 50       22  
6551 13         81 # [...]
  0         0  
6552             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6553             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);
6554 0         0 }
6555             else {
6556             splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
6557 13         75 }
6558 13         27  
6559             $i = $left;
6560             last;
6561             }
6562             }
6563             }
6564              
6565 13         32 # open character class [^...]
6566 0 0       0 elsif ($char[$i] eq '[^') {
6567 0         0 my $left = $i;
6568             if ($char[$i+1] eq ']') {
6569 0         0 $i++;
6570 0 0       0 }
6571 0         0 while (1) {
6572             if (++$i > $#char) {
6573 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6574 0         0 }
6575             if ($char[$i] eq ']') {
6576             my $right = $i;
6577 0 0       0  
6578 0         0 # [^...]
  0         0  
6579             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6580             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);
6581 0         0 }
6582             else {
6583             splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6584 0         0 }
6585 0         0  
6586             $i = $left;
6587             last;
6588             }
6589             }
6590             }
6591              
6592 0         0 # rewrite character class or escape character
6593             elsif (my $char = character_class($char[$i],$modifier)) {
6594             $char[$i] = $char;
6595             }
6596              
6597 7 50       14 # /i modifier
6598 3         5 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
6599             if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
6600             $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
6601 3         5 }
6602             else {
6603             $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
6604             }
6605             }
6606              
6607 0 0       0 # \u \l \U \L \F \Q \E
6608 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6609             if ($right_e < $left_e) {
6610             $char[$i] = '\\' . $char[$i];
6611             }
6612 0         0 }
6613 0         0 elsif ($char[$i] eq '\u') {
6614             $char[$i] = '@{[Ewindows1252::ucfirst qq<';
6615             $left_e++;
6616 0         0 }
6617 0         0 elsif ($char[$i] eq '\l') {
6618             $char[$i] = '@{[Ewindows1252::lcfirst qq<';
6619             $left_e++;
6620 0         0 }
6621 0         0 elsif ($char[$i] eq '\U') {
6622             $char[$i] = '@{[Ewindows1252::uc qq<';
6623             $left_e++;
6624 0         0 }
6625 0         0 elsif ($char[$i] eq '\L') {
6626             $char[$i] = '@{[Ewindows1252::lc qq<';
6627             $left_e++;
6628 0         0 }
6629 0         0 elsif ($char[$i] eq '\F') {
6630             $char[$i] = '@{[Ewindows1252::fc qq<';
6631             $left_e++;
6632 0         0 }
6633 0         0 elsif ($char[$i] eq '\Q') {
6634             $char[$i] = '@{[CORE::quotemeta qq<';
6635             $left_e++;
6636 0 0       0 }
6637 0         0 elsif ($char[$i] eq '\E') {
6638 0         0 if ($right_e < $left_e) {
6639             $char[$i] = '>]}';
6640             $right_e++;
6641 0         0 }
6642             else {
6643             $char[$i] = '';
6644             }
6645 0         0 }
6646 0 0       0 elsif ($char[$i] eq '\Q') {
6647 0         0 while (1) {
6648             if (++$i > $#char) {
6649 0 0       0 last;
6650 0         0 }
6651             if ($char[$i] eq '\E') {
6652             last;
6653             }
6654             }
6655             }
6656             elsif ($char[$i] eq '\E') {
6657             }
6658              
6659             # \0 --> \0
6660             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6661             }
6662              
6663             # \g{N}, \g{-N}
6664              
6665             # P.108 Using Simple Patterns
6666             # in Chapter 7: In the World of Regular Expressions
6667             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6668              
6669             # P.221 Capturing
6670             # in Chapter 5: Pattern Matching
6671             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6672              
6673             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6674             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6675             }
6676              
6677             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6678             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6679             }
6680              
6681             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6682             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6683             }
6684              
6685             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6686             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6687             }
6688              
6689 0 0       0 # $0 --> $0
6690 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6691             if ($ignorecase) {
6692             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6693             }
6694 0 0       0 }
6695 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6696             if ($ignorecase) {
6697             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6698             }
6699             }
6700              
6701             # $$ --> $$
6702             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6703             }
6704              
6705             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6706 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6707 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6708 0         0 $char[$i] = e_capture($1);
6709             if ($ignorecase) {
6710             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6711             }
6712 0         0 }
6713 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6714 0         0 $char[$i] = e_capture($1);
6715             if ($ignorecase) {
6716             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6717             }
6718             }
6719              
6720 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6721 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6722 0         0 $char[$i] = e_capture($1.'->'.$2);
6723             if ($ignorecase) {
6724             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6725             }
6726             }
6727              
6728 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6729 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6730 0         0 $char[$i] = e_capture($1.'->'.$2);
6731             if ($ignorecase) {
6732             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6733             }
6734             }
6735              
6736 0         0 # $$foo
6737 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6738 0         0 $char[$i] = e_capture($1);
6739             if ($ignorecase) {
6740             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6741             }
6742             }
6743              
6744 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
6745 4         14 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6746             if ($ignorecase) {
6747             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::PREMATCH())]}';
6748 0         0 }
6749             else {
6750             $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
6751             }
6752             }
6753              
6754 4 50       13 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
6755 4         15 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6756             if ($ignorecase) {
6757             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::MATCH())]}';
6758 0         0 }
6759             else {
6760             $char[$i] = '@{[Ewindows1252::MATCH()]}';
6761             }
6762             }
6763              
6764 4 50       14 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
6765 3         9 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6766             if ($ignorecase) {
6767             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::POSTMATCH())]}';
6768 0         0 }
6769             else {
6770             $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
6771             }
6772             }
6773              
6774 3 0       12 # ${ foo }
6775 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6776             if ($ignorecase) {
6777             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6778             }
6779             }
6780              
6781 0         0 # ${ ... }
6782 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6783 0         0 $char[$i] = e_capture($1);
6784             if ($ignorecase) {
6785             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6786             }
6787             }
6788              
6789 0         0 # $scalar or @array
6790 4 50       22 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6791 4         23 $char[$i] = e_string($char[$i]);
6792             if ($ignorecase) {
6793             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
6794             }
6795             }
6796              
6797 0 50       0 # quote character before ? + * {
6798             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6799             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6800 13         70 }
6801             else {
6802             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6803             }
6804             }
6805             }
6806 13         66  
6807 68         149 # make regexp string
6808 68 50       124 my $prematch = '';
6809 68         212 $modifier =~ tr/i//d;
6810             if ($left_e > $right_e) {
6811 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6812             }
6813             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6814             }
6815              
6816             #
6817             # escape regexp (s'here'' or s'here''b)
6818 68     21 0 899 #
6819 21   100     53 sub e_s1_q {
6820             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6821 21         81 $modifier ||= '';
6822 21 50       30  
6823 21         46 $modifier =~ tr/p//d;
6824 0         0 if ($modifier =~ /([adlu])/oxms) {
6825 0 0       0 my $line = 0;
6826 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6827 0         0 if ($filename ne __FILE__) {
6828             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6829             last;
6830 0         0 }
6831             }
6832             die qq{Unsupported modifier "$1" used at line $line.\n};
6833 0         0 }
6834              
6835             $slash = 'div';
6836 21 100       31  
    50          
6837 21         55 # literal null string pattern
6838 8         10 if ($string eq '') {
6839 8         12 $modifier =~ tr/bB//d;
6840             $modifier =~ tr/i//d;
6841             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6842             }
6843              
6844 8         46 # with /b /B modifier
6845             elsif ($modifier =~ tr/bB//d) {
6846             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6847             }
6848              
6849 0         0 # without /b /B modifier
6850             else {
6851             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6852             }
6853             }
6854              
6855             #
6856             # escape regexp (s'here'')
6857 13     13 0 33 #
6858             sub e_s1_qt {
6859 13 50       29 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6860              
6861             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6862 13         28  
6863             # split regexp
6864             my @char = $string =~ /\G((?>
6865             [^\\\[\$\@\/] |
6866             [\x00-\xFF] |
6867             \[\^ |
6868             \[\: (?>[a-z]+) \:\] |
6869             \[\:\^ (?>[a-z]+) \:\] |
6870             [\$\@\/] |
6871             \\ (?:$q_char) |
6872             (?:$q_char)
6873             ))/oxmsg;
6874 13         208  
6875 13 50 33     44 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6876             for (my $i=0; $i <= $#char; $i++) {
6877             if (0) {
6878             }
6879 25         109  
6880 0         0 # open character class [...]
6881 0 0       0 elsif ($char[$i] eq '[') {
6882 0         0 my $left = $i;
6883             if ($char[$i+1] eq ']') {
6884 0         0 $i++;
6885 0 0       0 }
6886 0         0 while (1) {
6887             if (++$i > $#char) {
6888 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6889 0         0 }
6890             if ($char[$i] eq ']') {
6891             my $right = $i;
6892 0         0  
6893             # [...]
6894 0         0 splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
6895 0         0  
6896             $i = $left;
6897             last;
6898             }
6899             }
6900             }
6901              
6902 0         0 # open character class [^...]
6903 0 0       0 elsif ($char[$i] eq '[^') {
6904 0         0 my $left = $i;
6905             if ($char[$i+1] eq ']') {
6906 0         0 $i++;
6907 0 0       0 }
6908 0         0 while (1) {
6909             if (++$i > $#char) {
6910 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6911 0         0 }
6912             if ($char[$i] eq ']') {
6913             my $right = $i;
6914 0         0  
6915             # [^...]
6916 0         0 splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6917 0         0  
6918             $i = $left;
6919             last;
6920             }
6921             }
6922             }
6923              
6924 0         0 # escape $ @ / and \
6925             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6926             $char[$i] = '\\' . $char[$i];
6927             }
6928              
6929 0         0 # rewrite character class or escape character
6930             elsif (my $char = character_class($char[$i],$modifier)) {
6931             $char[$i] = $char;
6932             }
6933              
6934 6 0       13 # /i modifier
6935 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
6936             if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
6937             $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
6938 0         0 }
6939             else {
6940             $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
6941             }
6942             }
6943              
6944 0 0       0 # quote character before ? + * {
6945             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6946             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6947 0         0 }
6948             else {
6949             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6950             }
6951             }
6952 0         0 }
6953 13         25  
6954 13         18 $modifier =~ tr/i//d;
6955 13         18 $delimiter = '/';
6956 13         18 $end_delimiter = '/';
6957             my $prematch = '';
6958             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6959             }
6960              
6961             #
6962             # escape regexp (s'here''b)
6963 13     0 0 99 #
6964             sub e_s1_qb {
6965             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6966 0         0  
6967             # split regexp
6968             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6969 0         0  
6970 0 0       0 # unescape character
    0          
6971             for (my $i=0; $i <= $#char; $i++) {
6972             if (0) {
6973             }
6974 0         0  
6975             # remain \\
6976             elsif ($char[$i] eq '\\\\') {
6977             }
6978              
6979 0         0 # escape $ @ / and \
6980             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6981             $char[$i] = '\\' . $char[$i];
6982             }
6983 0         0 }
6984 0         0  
6985 0         0 $delimiter = '/';
6986 0         0 $end_delimiter = '/';
6987             my $prematch = '';
6988             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6989             }
6990              
6991             #
6992             # escape regexp (s''here')
6993 0     16 0 0 #
6994             sub e_s2_q {
6995 16         32 my($ope,$delimiter,$end_delimiter,$string) = @_;
6996              
6997 16         19 $slash = 'div';
6998 16         93  
6999 16 100       49 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
7000             for (my $i=0; $i <= $#char; $i++) {
7001             if (0) {
7002             }
7003 9         33  
7004             # not escape \\
7005             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
7006             }
7007              
7008 0         0 # escape $ @ / and \
7009             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
7010             $char[$i] = '\\' . $char[$i];
7011             }
7012 5         14 }
7013              
7014             return join '', $ope, $delimiter, @char, $end_delimiter;
7015             }
7016              
7017             #
7018             # escape regexp (s/here/and here/modifier)
7019 16     97 0 49 #
7020 97   100     766 sub e_sub {
7021             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
7022 97         403 $modifier ||= '';
7023 97 50       225  
7024 97         343 $modifier =~ tr/p//d;
7025 0         0 if ($modifier =~ /([adlu])/oxms) {
7026 0 0       0 my $line = 0;
7027 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7028 0         0 if ($filename ne __FILE__) {
7029             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7030             last;
7031 0         0 }
7032             }
7033             die qq{Unsupported modifier "$1" used at line $line.\n};
7034 0 100       0 }
7035 97         266  
7036 36         55 if ($variable eq '') {
7037             $variable = '$_';
7038             $bind_operator = ' =~ ';
7039 36         132 }
7040              
7041             $slash = 'div';
7042              
7043             # P.128 Start of match (or end of previous match): \G
7044             # P.130 Advanced Use of \G with Perl
7045             # in Chapter 3: Overview of Regular Expression Features and Flavors
7046             # P.312 Iterative Matching: Scalar Context, with /g
7047             # in Chapter 7: Perl
7048             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
7049              
7050             # P.181 Where You Left Off: The \G Assertion
7051             # in Chapter 5: Pattern Matching
7052             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7053              
7054             # P.220 Where You Left Off: The \G Assertion
7055             # in Chapter 5: Pattern Matching
7056 97         167 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7057 97         158  
7058             my $e_modifier = $modifier =~ tr/e//d;
7059 97         155 my $r_modifier = $modifier =~ tr/r//d;
7060 97 50       139  
7061 97         394 my $my = '';
7062 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
7063 0         0 $my = $variable;
7064             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
7065             $variable =~ s/ = .+ \z//oxms;
7066 0         0 }
7067 97         235  
7068             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
7069             $variable_basename =~ s/ \s+ \z//oxms;
7070 97         203  
7071 97 100       187 # quote replacement string
7072 97         235 my $e_replacement = '';
7073 17         36 if ($e_modifier >= 1) {
7074             $e_replacement = e_qq('', '', '', $replacement);
7075             $e_modifier--;
7076 17 100       33 }
7077 80         185 else {
7078             if ($delimiter2 eq "'") {
7079             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
7080 16         34 }
7081             else {
7082             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
7083             }
7084 64         185 }
7085              
7086             my $sub = '';
7087 97 100       164  
7088 97 100       220 # with /r
7089             if ($r_modifier) {
7090             if (0) {
7091             }
7092 8         18  
7093 0 50       0 # s///gr without multibyte anchoring
7094             elsif ($modifier =~ /g/oxms) {
7095             $sub = sprintf(
7096             # 1 2 3 4 5
7097             q,
7098              
7099             $variable, # 1
7100             ($delimiter1 eq "'") ? # 2
7101             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7102             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7103             $s_matched, # 3
7104             $e_replacement, # 4
7105             '$Ewindows1252::re_r=CORE::eval $Ewindows1252::re_r; ' x $e_modifier, # 5
7106             );
7107             }
7108              
7109             # s///r
7110 4         12 else {
7111              
7112 4 50       4 my $prematch = q{$`};
7113              
7114             $sub = sprintf(
7115             # 1 2 3 4 5 6 7
7116             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Ewindows1252::re_r=%s; %s"%s$Ewindows1252::re_r$'" } : %s>,
7117              
7118             $variable, # 1
7119             ($delimiter1 eq "'") ? # 2
7120             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7121             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7122             $s_matched, # 3
7123             $e_replacement, # 4
7124             '$Ewindows1252::re_r=CORE::eval $Ewindows1252::re_r; ' x $e_modifier, # 5
7125             $prematch, # 6
7126             $variable, # 7
7127             );
7128             }
7129 4 50       10  
7130 8         23 # $var !~ s///r doesn't make sense
7131             if ($bind_operator =~ / !~ /oxms) {
7132             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7133             }
7134             }
7135              
7136 0 100       0 # without /r
7137             else {
7138             if (0) {
7139             }
7140 89         258  
7141 0 100       0 # s///g without multibyte anchoring
    100          
7142             elsif ($modifier =~ /g/oxms) {
7143             $sub = sprintf(
7144             # 1 2 3 4 5 6 7 8
7145             q,
7146              
7147             $variable, # 1
7148             ($delimiter1 eq "'") ? # 2
7149             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7150             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7151             $s_matched, # 3
7152             $e_replacement, # 4
7153             '$Ewindows1252::re_r=CORE::eval $Ewindows1252::re_r; ' x $e_modifier, # 5
7154             $variable, # 6
7155             $variable, # 7
7156             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7157             );
7158             }
7159              
7160             # s///
7161 22         82 else {
7162              
7163 67 100       119 my $prematch = q{$`};
    100          
7164              
7165             $sub = sprintf(
7166              
7167             ($bind_operator =~ / =~ /oxms) ?
7168              
7169             # 1 2 3 4 5 6 7 8
7170             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Ewindows1252::re_r=%s; %s%s="%s$Ewindows1252::re_r$'"; 1 } : undef> :
7171              
7172             # 1 2 3 4 5 6 7 8
7173             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Ewindows1252::re_r=%s; %s%s="%s$Ewindows1252::re_r$'"; undef }>,
7174              
7175             $variable, # 1
7176             $bind_operator, # 2
7177             ($delimiter1 eq "'") ? # 3
7178             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7179             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7180             $s_matched, # 4
7181             $e_replacement, # 5
7182             '$Ewindows1252::re_r=CORE::eval $Ewindows1252::re_r; ' x $e_modifier, # 6
7183             $variable, # 7
7184             $prematch, # 8
7185             );
7186             }
7187             }
7188 67 50       570  
7189 97         274 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7190             if ($my ne '') {
7191             $sub = "($my, $sub)[1]";
7192             }
7193 0         0  
7194 97         149 # clear s/// variable
7195             $sub_variable = '';
7196 97         133 $bind_operator = '';
7197              
7198             return $sub;
7199             }
7200              
7201             #
7202             # escape regexp of split qr//
7203 97     74 0 912 #
7204 74   100     337 sub e_split {
7205             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7206 74         377 $modifier ||= '';
7207 74 50       127  
7208 74         181 $modifier =~ tr/p//d;
7209 0         0 if ($modifier =~ /([adlu])/oxms) {
7210 0 0       0 my $line = 0;
7211 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7212 0         0 if ($filename ne __FILE__) {
7213             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7214             last;
7215 0         0 }
7216             }
7217             die qq{Unsupported modifier "$1" used at line $line.\n};
7218 0         0 }
7219              
7220             $slash = 'div';
7221 74 50       150  
7222 74         256 # /b /B modifier
7223             if ($modifier =~ tr/bB//d) {
7224             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7225 0 50       0 }
7226 74         218  
7227             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7228             my $metachar = qr/[\@\\|[\]{^]/oxms;
7229 74         291  
7230             # split regexp
7231             my @char = $string =~ /\G((?>
7232             [^\\\$\@\[\(] |
7233             \\x (?>[0-9A-Fa-f]{1,2}) |
7234             \\ (?>[0-7]{2,3}) |
7235             \\c [\x40-\x5F] |
7236             \\x\{ (?>[0-9A-Fa-f]+) \} |
7237             \\o\{ (?>[0-7]+) \} |
7238             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7239             \\ $q_char |
7240             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7241             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7242             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7243             [\$\@] $qq_variable |
7244             \$ (?>\s* [0-9]+) |
7245             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7246             \$ \$ (?![\w\{]) |
7247             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7248             \[\^ |
7249             \[\: (?>[a-z]+) :\] |
7250             \[\:\^ (?>[a-z]+) :\] |
7251             \(\? |
7252             $q_char
7253 74         8826 ))/oxmsg;
7254 74         255  
7255 74         106 my $left_e = 0;
7256             my $right_e = 0;
7257             for (my $i=0; $i <= $#char; $i++) {
7258 74 50 33     347  
    50 33        
    100          
    100          
    50          
    50          
7259 249         1357 # "\L\u" --> "\u\L"
7260             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7261             @char[$i,$i+1] = @char[$i+1,$i];
7262             }
7263              
7264 0         0 # "\U\l" --> "\l\U"
7265             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7266             @char[$i,$i+1] = @char[$i+1,$i];
7267             }
7268              
7269 0         0 # octal escape sequence
7270             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7271             $char[$i] = Ewindows1252::octchr($1);
7272             }
7273              
7274 1         4 # hexadecimal escape sequence
7275             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7276             $char[$i] = Ewindows1252::hexchr($1);
7277             }
7278              
7279             # \b{...} --> b\{...}
7280             # \B{...} --> B\{...}
7281             # \N{CHARNAME} --> N\{CHARNAME}
7282             # \p{PROPERTY} --> p\{PROPERTY}
7283 1         3 # \P{PROPERTY} --> P\{PROPERTY}
7284             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7285             $char[$i] = $1 . '\\' . $2;
7286             }
7287              
7288 0         0 # \p, \P, \X --> p, P, X
7289             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7290             $char[$i] = $1;
7291 0 50 100     0 }
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7292              
7293             if (0) {
7294             }
7295 249         819  
7296 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7297 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7298             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)) {
7299             $char[$i] .= join '', splice @char, $i+1, 3;
7300 0         0 }
7301             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)) {
7302             $char[$i] .= join '', splice @char, $i+1, 2;
7303 0         0 }
7304             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)) {
7305             $char[$i] .= join '', splice @char, $i+1, 1;
7306             }
7307             }
7308              
7309 0         0 # open character class [...]
7310 3 50       7 elsif ($char[$i] eq '[') {
7311 3         10 my $left = $i;
7312             if ($char[$i+1] eq ']') {
7313 0         0 $i++;
7314 3 50       5 }
7315 7         15 while (1) {
7316             if (++$i > $#char) {
7317 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7318 7         14 }
7319             if ($char[$i] eq ']') {
7320             my $right = $i;
7321 3 50       4  
7322 3         17 # [...]
  0         0  
7323             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7324             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);
7325 0         0 }
7326             else {
7327             splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
7328 3         19 }
7329 3         7  
7330             $i = $left;
7331             last;
7332             }
7333             }
7334             }
7335              
7336 3         7 # open character class [^...]
7337 0 0       0 elsif ($char[$i] eq '[^') {
7338 0         0 my $left = $i;
7339             if ($char[$i+1] eq ']') {
7340 0         0 $i++;
7341 0 0       0 }
7342 0         0 while (1) {
7343             if (++$i > $#char) {
7344 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7345 0         0 }
7346             if ($char[$i] eq ']') {
7347             my $right = $i;
7348 0 0       0  
7349 0         0 # [^...]
  0         0  
7350             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7351             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);
7352 0         0 }
7353             else {
7354             splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7355 0         0 }
7356 0         0  
7357             $i = $left;
7358             last;
7359             }
7360             }
7361             }
7362              
7363 0         0 # rewrite character class or escape character
7364             elsif (my $char = character_class($char[$i],$modifier)) {
7365             $char[$i] = $char;
7366             }
7367              
7368             # P.794 29.2.161. split
7369             # in Chapter 29: Functions
7370             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7371              
7372             # P.951 split
7373             # in Chapter 27: Functions
7374             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7375              
7376             # said "The //m modifier is assumed when you split on the pattern /^/",
7377             # but perl5.008 is not so. Therefore, this software adds //m.
7378             # (and so on)
7379              
7380 1         2 # split(m/^/) --> split(m/^/m)
7381             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7382             $modifier .= 'm';
7383             }
7384              
7385 7 0       21 # /i modifier
7386 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
7387             if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
7388             $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
7389 0         0 }
7390             else {
7391             $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
7392             }
7393             }
7394              
7395 0 0       0 # \u \l \U \L \F \Q \E
7396 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7397             if ($right_e < $left_e) {
7398             $char[$i] = '\\' . $char[$i];
7399             }
7400 0         0 }
7401 0         0 elsif ($char[$i] eq '\u') {
7402             $char[$i] = '@{[Ewindows1252::ucfirst qq<';
7403             $left_e++;
7404 0         0 }
7405 0         0 elsif ($char[$i] eq '\l') {
7406             $char[$i] = '@{[Ewindows1252::lcfirst qq<';
7407             $left_e++;
7408 0         0 }
7409 0         0 elsif ($char[$i] eq '\U') {
7410             $char[$i] = '@{[Ewindows1252::uc qq<';
7411             $left_e++;
7412 0         0 }
7413 0         0 elsif ($char[$i] eq '\L') {
7414             $char[$i] = '@{[Ewindows1252::lc qq<';
7415             $left_e++;
7416 0         0 }
7417 0         0 elsif ($char[$i] eq '\F') {
7418             $char[$i] = '@{[Ewindows1252::fc qq<';
7419             $left_e++;
7420 0         0 }
7421 0         0 elsif ($char[$i] eq '\Q') {
7422             $char[$i] = '@{[CORE::quotemeta qq<';
7423             $left_e++;
7424 0 0       0 }
7425 0         0 elsif ($char[$i] eq '\E') {
7426 0         0 if ($right_e < $left_e) {
7427             $char[$i] = '>]}';
7428             $right_e++;
7429 0         0 }
7430             else {
7431             $char[$i] = '';
7432             }
7433 0         0 }
7434 0 0       0 elsif ($char[$i] eq '\Q') {
7435 0         0 while (1) {
7436             if (++$i > $#char) {
7437 0 0       0 last;
7438 0         0 }
7439             if ($char[$i] eq '\E') {
7440             last;
7441             }
7442             }
7443             }
7444             elsif ($char[$i] eq '\E') {
7445             }
7446              
7447 0 0       0 # $0 --> $0
7448 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7449             if ($ignorecase) {
7450             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7451             }
7452 0 0       0 }
7453 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7454             if ($ignorecase) {
7455             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7456             }
7457             }
7458              
7459             # $$ --> $$
7460             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7461             }
7462              
7463             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7464 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7465 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7466 0         0 $char[$i] = e_capture($1);
7467             if ($ignorecase) {
7468             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7469             }
7470 0         0 }
7471 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7472 0         0 $char[$i] = e_capture($1);
7473             if ($ignorecase) {
7474             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7475             }
7476             }
7477              
7478 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7479 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7480 0         0 $char[$i] = e_capture($1.'->'.$2);
7481             if ($ignorecase) {
7482             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7483             }
7484             }
7485              
7486 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7487 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7488 0         0 $char[$i] = e_capture($1.'->'.$2);
7489             if ($ignorecase) {
7490             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7491             }
7492             }
7493              
7494 0         0 # $$foo
7495 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7496 0         0 $char[$i] = e_capture($1);
7497             if ($ignorecase) {
7498             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7499             }
7500             }
7501              
7502 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ewindows1252::PREMATCH()
7503 12         32 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7504             if ($ignorecase) {
7505             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::PREMATCH())]}';
7506 0         0 }
7507             else {
7508             $char[$i] = '@{[Ewindows1252::PREMATCH()]}';
7509             }
7510             }
7511              
7512 12 50       52 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ewindows1252::MATCH()
7513 12         38 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7514             if ($ignorecase) {
7515             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::MATCH())]}';
7516 0         0 }
7517             else {
7518             $char[$i] = '@{[Ewindows1252::MATCH()]}';
7519             }
7520             }
7521              
7522 12 50       57 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ewindows1252::POSTMATCH()
7523 9         24 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7524             if ($ignorecase) {
7525             $char[$i] = '@{[Ewindows1252::ignorecase(Ewindows1252::POSTMATCH())]}';
7526 0         0 }
7527             else {
7528             $char[$i] = '@{[Ewindows1252::POSTMATCH()]}';
7529             }
7530             }
7531              
7532 9 0       38 # ${ foo }
7533 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7534             if ($ignorecase) {
7535             $char[$i] = '@{[Ewindows1252::ignorecase(' . $1 . ')]}';
7536             }
7537             }
7538              
7539 0         0 # ${ ... }
7540 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7541 0         0 $char[$i] = e_capture($1);
7542             if ($ignorecase) {
7543             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7544             }
7545             }
7546              
7547 0         0 # $scalar or @array
7548 3 50       8 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7549 3         13 $char[$i] = e_string($char[$i]);
7550             if ($ignorecase) {
7551             $char[$i] = '@{[Ewindows1252::ignorecase(' . $char[$i] . ')]}';
7552             }
7553             }
7554              
7555 0 50       0 # quote character before ? + * {
7556             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7557             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7558 1         6 }
7559             else {
7560             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7561             }
7562             }
7563             }
7564 0         0  
7565 74 50       209 # make regexp string
7566 74         163 $modifier =~ tr/i//d;
7567             if ($left_e > $right_e) {
7568 0         0 return join '', 'Ewindows1252::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7569             }
7570             return join '', 'Ewindows1252::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7571             }
7572              
7573             #
7574             # escape regexp of split qr''
7575 74     0 0 736 #
7576 0   0       sub e_split_q {
7577             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7578 0           $modifier ||= '';
7579 0 0          
7580 0           $modifier =~ tr/p//d;
7581 0           if ($modifier =~ /([adlu])/oxms) {
7582 0 0         my $line = 0;
7583 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7584 0           if ($filename ne __FILE__) {
7585             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7586             last;
7587 0           }
7588             }
7589             die qq{Unsupported modifier "$1" used at line $line.\n};
7590 0           }
7591              
7592             $slash = 'div';
7593 0 0          
7594 0           # /b /B modifier
7595             if ($modifier =~ tr/bB//d) {
7596             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7597 0 0         }
7598              
7599             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7600 0            
7601             # split regexp
7602             my @char = $string =~ /\G((?>
7603             [^\\\[] |
7604             [\x00-\xFF] |
7605             \[\^ |
7606             \[\: (?>[a-z]+) \:\] |
7607             \[\:\^ (?>[a-z]+) \:\] |
7608             \\ (?:$q_char) |
7609             (?:$q_char)
7610             ))/oxmsg;
7611 0            
7612 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7613             for (my $i=0; $i <= $#char; $i++) {
7614             if (0) {
7615             }
7616 0            
7617 0           # open character class [...]
7618 0 0         elsif ($char[$i] eq '[') {
7619 0           my $left = $i;
7620             if ($char[$i+1] eq ']') {
7621 0           $i++;
7622 0 0         }
7623 0           while (1) {
7624             if (++$i > $#char) {
7625 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7626 0           }
7627             if ($char[$i] eq ']') {
7628             my $right = $i;
7629 0            
7630             # [...]
7631 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_qr(@char[$left+1..$right-1], $modifier);
7632 0            
7633             $i = $left;
7634             last;
7635             }
7636             }
7637             }
7638              
7639 0           # open character class [^...]
7640 0 0         elsif ($char[$i] eq '[^') {
7641 0           my $left = $i;
7642             if ($char[$i+1] eq ']') {
7643 0           $i++;
7644 0 0         }
7645 0           while (1) {
7646             if (++$i > $#char) {
7647 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7648 0           }
7649             if ($char[$i] eq ']') {
7650             my $right = $i;
7651 0            
7652             # [^...]
7653 0           splice @char, $left, $right-$left+1, Ewindows1252::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7654 0            
7655             $i = $left;
7656             last;
7657             }
7658             }
7659             }
7660              
7661 0           # rewrite character class or escape character
7662             elsif (my $char = character_class($char[$i],$modifier)) {
7663             $char[$i] = $char;
7664             }
7665              
7666 0           # split(m/^/) --> split(m/^/m)
7667             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7668             $modifier .= 'm';
7669             }
7670              
7671 0 0         # /i modifier
7672 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ewindows1252::uc($char[$i]) ne Ewindows1252::fc($char[$i]))) {
7673             if (CORE::length(Ewindows1252::fc($char[$i])) == 1) {
7674             $char[$i] = '[' . Ewindows1252::uc($char[$i]) . Ewindows1252::fc($char[$i]) . ']';
7675 0           }
7676             else {
7677             $char[$i] = '(?:' . Ewindows1252::uc($char[$i]) . '|' . Ewindows1252::fc($char[$i]) . ')';
7678             }
7679             }
7680              
7681 0 0         # quote character before ? + * {
7682             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7683             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7684 0           }
7685             else {
7686             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7687             }
7688             }
7689 0           }
7690 0            
7691             $modifier =~ tr/i//d;
7692             return join '', 'Ewindows1252::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7693             }
7694              
7695             #
7696             # instead of Carp::carp
7697 0     0 0   #
7698 0           sub carp {
7699             my($package,$filename,$line) = caller(1);
7700             print STDERR "@_ at $filename line $line.\n";
7701             }
7702              
7703             #
7704             # instead of Carp::croak
7705 0     0 0   #
7706 0           sub croak {
7707 0           my($package,$filename,$line) = caller(1);
7708             print STDERR "@_ at $filename line $line.\n";
7709             die "\n";
7710             }
7711              
7712             #
7713             # instead of Carp::cluck
7714 0     0 0   #
7715 0           sub cluck {
7716 0           my $i = 0;
7717 0           my @cluck = ();
7718 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7719             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7720 0           $i++;
7721 0           }
7722 0           print STDERR CORE::reverse @cluck;
7723             print STDERR "\n";
7724             print STDERR @_;
7725             }
7726              
7727             #
7728             # instead of Carp::confess
7729 0     0 0   #
7730 0           sub confess {
7731 0           my $i = 0;
7732 0           my @confess = ();
7733 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7734             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7735 0           $i++;
7736 0           }
7737 0           print STDERR CORE::reverse @confess;
7738 0           print STDERR "\n";
7739             print STDERR @_;
7740             die "\n";
7741             }
7742              
7743             1;
7744              
7745             __END__