File Coverage

Char/Ewindows1258.pm
Criterion Covered Total %
statement 83 3062 2.7
branch 4 2670 0.1
condition 1 373 0.2
subroutine 36 125 28.8
pod 7 74 9.4
total 131 6304 2.0


line stmt bran cond sub pod time code
1             #
2             # This file is *** FOR CPAN USE ONLY ***.
3             #
4             package Char::Ewindows1258;
5             ######################################################################
6             #
7             # Char::Ewindows1258 - Run-time routines for Char/Windows1258.pm
8             #
9             # http://search.cpan.org/dist/Char-Windows1258/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
12             ######################################################################
13              
14 197     197   4311 use 5.00503; # Galapagos Consensus 1998 for primetools
  197         586  
  197         10435  
15             # use 5.008001; # Lancaster Consensus 2013 for toolchains
16              
17             # 12.3. Delaying use Until Runtime
18             # in Chapter 12. Packages, Libraries, and Modules
19             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
20             # (and so on)
21              
22 197     197   13593 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  197     197   1060  
  197         317  
  197         32969  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.02 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 197 50   197   1190 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 197         257 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 197         26781 if (CORE::ord('A') != 0x41) {
33             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).";
34             }
35             }
36              
37             BEGIN {
38              
39             # instead of utf8.pm
40 197     197   11687 CORE::eval q{
  197     197   1097  
  197     79   311  
  197         25692  
  79         12646  
  64         10731  
  66         11673  
  68         10572  
  58         9610  
  59         11012  
41             no warnings qw(redefine);
42             *utf8::upgrade = sub { CORE::length $_[0] };
43             *utf8::downgrade = sub { 1 };
44             *utf8::encode = sub { };
45             *utf8::decode = sub { 1 };
46             *utf8::is_utf8 = sub { };
47             *utf8::valid = sub { 1 };
48             };
49 197 50       104770 if ($@) {
50 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
51 0         0 *utf8::downgrade = sub { 1 };
  0         0  
52 0         0 *utf8::encode = sub { };
  0         0  
53 0         0 *utf8::decode = sub { 1 };
  0         0  
54 0         0 *utf8::is_utf8 = sub { };
  0         0  
55 0         0 *utf8::valid = sub { 1 };
  0         0  
56             }
57             }
58              
59             # instead of Symbol.pm
60             BEGIN {
61 197     197   472 my $genpkg = "Symbol::";
62 197         8595 my $genseq = 0;
63              
64             sub gensym () {
65 0     0 0 0 my $name = "GEN" . $genseq++;
66              
67             # here, no strict qw(refs); if strict.pm exists
68              
69 0         0 my $ref = \*{$genpkg . $name};
  0         0  
70 0         0 delete $$genpkg{$name};
71 0         0 return $ref;
72             }
73              
74             sub qualify ($;$) {
75 0     0 0 0 my ($name) = @_;
76 0 0 0     0 if (!ref($name) && (Char::Ewindows1258::index($name, '::') == -1) && (Char::Ewindows1258::index($name, "'") == -1)) {
      0        
77 0         0 my $pkg;
78 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
79              
80             # Global names: special character, "^xyz", or other.
81 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
82             # RGS 2001-11-05 : translate leading ^X to control-char
83 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
84 0         0 $pkg = "main";
85             }
86             else {
87 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
88             }
89 0         0 $name = $pkg . "::" . $name;
90             }
91 0         0 return $name;
92             }
93              
94             sub qualify_to_ref ($;$) {
95              
96             # here, no strict qw(refs); if strict.pm exists
97              
98 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
99             }
100             }
101              
102             # Column: local $@
103             # in Chapter 9. Osaete okitai Perl no kiso
104             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
105             # (and so on)
106              
107             # use strict; if strict.pm exists
108             BEGIN {
109 197 50   197   360 if (CORE::eval { local $@; CORE::require strict }) {
  197         352  
  197         1888  
110 197         24465 strict::->import;
111             }
112             }
113              
114             # P.714 29.2.39. flock
115             # in Chapter 29: Functions
116             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
117              
118             # P.863 flock
119             # in Chapter 27: Functions
120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
121              
122             sub LOCK_SH() {1}
123             sub LOCK_EX() {2}
124             sub LOCK_UN() {8}
125             sub LOCK_NB() {4}
126              
127             # instead of Carp.pm
128             sub carp;
129             sub croak;
130             sub cluck;
131             sub confess;
132              
133             # 6.18. Matching Multiple-Byte Characters
134             # in Chapter 6. Pattern Matching
135             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
136             # (and so on)
137              
138             # regexp of character
139 197     197   12562 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  197     197   1031  
  197         283  
  197         16528  
140 197     197   13963 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  197     197   1292  
  197         570  
  197         13864  
141 197     197   11081 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  197     197   1252  
  197         318  
  197         14117  
142              
143             #
144             # Windows-1258 character range per length
145             #
146             my %range_tr = ();
147              
148             #
149             # alias of encoding name
150             #
151 197     197   11894 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  197     197   1103  
  197         387  
  197         298588  
152              
153             #
154             # Windows-1258 case conversion
155             #
156             my %lc = ();
157             @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)} =
158             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);
159             my %uc = ();
160             @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)} =
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 %fc = ();
163             @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)} =
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              
166             if (0) {
167             }
168              
169             elsif (__PACKAGE__ =~ / \b Ewindows1258 \z/oxms) {
170             %range_tr = (
171             1 => [ [0x00..0xFF],
172             ],
173             );
174             $encoding_alias = qr/ \b (?: windows-?1258 ) \b /oxmsi;
175              
176             %lc = (%lc,
177             "\x8C" => "\x9C", # LATIN LIGATURE OE
178             "\x9F" => "\xFF", # LATIN LETTER Y WITH DIAERESIS
179             "\xC0" => "\xE0", # LATIN LETTER A WITH GRAVE
180             "\xC1" => "\xE1", # LATIN LETTER A WITH ACUTE
181             "\xC2" => "\xE2", # LATIN LETTER A WITH CIRCUMFLEX
182             "\xC3" => "\xE3", # LATIN LETTER A WITH BREVE
183             "\xC4" => "\xE4", # LATIN LETTER A WITH DIAERESIS
184             "\xC5" => "\xE5", # LATIN LETTER A WITH RING ABOVE
185             "\xC6" => "\xE6", # LATIN LETTER AE
186             "\xC7" => "\xE7", # LATIN LETTER C WITH CEDILLA
187             "\xC8" => "\xE8", # LATIN LETTER E WITH GRAVE
188             "\xC9" => "\xE9", # LATIN LETTER E WITH ACUTE
189             "\xCA" => "\xEA", # LATIN LETTER E WITH CIRCUMFLEX
190             "\xCB" => "\xEB", # LATIN LETTER E WITH DIAERESIS
191             "\xCD" => "\xED", # LATIN LETTER I WITH ACUTE
192             "\xCE" => "\xEE", # LATIN LETTER I WITH CIRCUMFLEX
193             "\xCF" => "\xEF", # LATIN LETTER I WITH DIAERESIS
194             "\xD0" => "\xF0", # LATIN LETTER D WITH STROKE
195             "\xD1" => "\xF1", # LATIN LETTER N WITH TILDE
196             "\xD3" => "\xF3", # LATIN LETTER O WITH ACUTE
197             "\xD4" => "\xF4", # LATIN LETTER O WITH CIRCUMFLEX
198             "\xD5" => "\xF5", # LATIN LETTER O WITH HORN
199             "\xD6" => "\xF6", # LATIN LETTER O WITH DIAERESIS
200             "\xD8" => "\xF8", # LATIN LETTER O WITH STROKE
201             "\xD9" => "\xF9", # LATIN LETTER U WITH GRAVE
202             "\xDA" => "\xFA", # LATIN LETTER U WITH ACUTE
203             "\xDB" => "\xFB", # LATIN LETTER U WITH CIRCUMFLEX
204             "\xDC" => "\xFC", # LATIN LETTER U WITH DIAERESIS
205             "\xDD" => "\xFD", # LATIN LETTER U WITH HORN
206             );
207              
208             %uc = (%uc,
209             "\x9C" => "\x8C", # LATIN LIGATURE OE
210             "\xFF" => "\x9F", # LATIN LETTER Y WITH DIAERESIS
211             "\xE0" => "\xC0", # LATIN LETTER A WITH GRAVE
212             "\xE1" => "\xC1", # LATIN LETTER A WITH ACUTE
213             "\xE2" => "\xC2", # LATIN LETTER A WITH CIRCUMFLEX
214             "\xE3" => "\xC3", # LATIN LETTER A WITH BREVE
215             "\xE4" => "\xC4", # LATIN LETTER A WITH DIAERESIS
216             "\xE5" => "\xC5", # LATIN LETTER A WITH RING ABOVE
217             "\xE6" => "\xC6", # LATIN LETTER AE
218             "\xE7" => "\xC7", # LATIN LETTER C WITH CEDILLA
219             "\xE8" => "\xC8", # LATIN LETTER E WITH GRAVE
220             "\xE9" => "\xC9", # LATIN LETTER E WITH ACUTE
221             "\xEA" => "\xCA", # LATIN LETTER E WITH CIRCUMFLEX
222             "\xEB" => "\xCB", # LATIN LETTER E WITH DIAERESIS
223             "\xED" => "\xCD", # LATIN LETTER I WITH ACUTE
224             "\xEE" => "\xCE", # LATIN LETTER I WITH CIRCUMFLEX
225             "\xEF" => "\xCF", # LATIN LETTER I WITH DIAERESIS
226             "\xF0" => "\xD0", # LATIN LETTER D WITH STROKE
227             "\xF1" => "\xD1", # LATIN LETTER N WITH TILDE
228             "\xF3" => "\xD3", # LATIN LETTER O WITH ACUTE
229             "\xF4" => "\xD4", # LATIN LETTER O WITH CIRCUMFLEX
230             "\xF5" => "\xD5", # LATIN LETTER O WITH HORN
231             "\xF6" => "\xD6", # LATIN LETTER O WITH DIAERESIS
232             "\xF8" => "\xD8", # LATIN LETTER O WITH STROKE
233             "\xF9" => "\xD9", # LATIN LETTER U WITH GRAVE
234             "\xFA" => "\xDA", # LATIN LETTER U WITH ACUTE
235             "\xFB" => "\xDB", # LATIN LETTER U WITH CIRCUMFLEX
236             "\xFC" => "\xDC", # LATIN LETTER U WITH DIAERESIS
237             "\xFD" => "\xDD", # LATIN LETTER U WITH HORN
238             );
239              
240             %fc = (%fc,
241             "\x8C" => "\x9C", # LATIN CAPITAL LIGATURE OE --> LATIN SMALL LIGATURE OE
242             "\x9F" => "\xFF", # LATIN CAPITAL LETTER Y WITH DIAERESIS --> LATIN SMALL LETTER Y WITH DIAERESIS
243             "\xC0" => "\xE0", # LATIN CAPITAL LETTER A WITH GRAVE --> LATIN SMALL LETTER A WITH GRAVE
244             "\xC1" => "\xE1", # LATIN CAPITAL LETTER A WITH ACUTE --> LATIN SMALL LETTER A WITH ACUTE
245             "\xC2" => "\xE2", # LATIN CAPITAL LETTER A WITH CIRCUMFLEX --> LATIN SMALL LETTER A WITH CIRCUMFLEX
246             "\xC3" => "\xE3", # LATIN CAPITAL LETTER A WITH BREVE --> LATIN SMALL LETTER A WITH BREVE
247             "\xC4" => "\xE4", # LATIN CAPITAL LETTER A WITH DIAERESIS --> LATIN SMALL LETTER A WITH DIAERESIS
248             "\xC5" => "\xE5", # LATIN CAPITAL LETTER A WITH RING ABOVE --> LATIN SMALL LETTER A WITH RING ABOVE
249             "\xC6" => "\xE6", # LATIN CAPITAL LETTER AE --> LATIN SMALL LETTER AE
250             "\xC7" => "\xE7", # LATIN CAPITAL LETTER C WITH CEDILLA --> LATIN SMALL LETTER C WITH CEDILLA
251             "\xC8" => "\xE8", # LATIN CAPITAL LETTER E WITH GRAVE --> LATIN SMALL LETTER E WITH GRAVE
252             "\xC9" => "\xE9", # LATIN CAPITAL LETTER E WITH ACUTE --> LATIN SMALL LETTER E WITH ACUTE
253             "\xCA" => "\xEA", # LATIN CAPITAL LETTER E WITH CIRCUMFLEX --> LATIN SMALL LETTER E WITH CIRCUMFLEX
254             "\xCB" => "\xEB", # LATIN CAPITAL LETTER E WITH DIAERESIS --> LATIN SMALL LETTER E WITH DIAERESIS
255             "\xCD" => "\xED", # LATIN CAPITAL LETTER I WITH ACUTE --> LATIN SMALL LETTER I WITH ACUTE
256             "\xCE" => "\xEE", # LATIN CAPITAL LETTER I WITH CIRCUMFLEX --> LATIN SMALL LETTER I WITH CIRCUMFLEX
257             "\xCF" => "\xEF", # LATIN CAPITAL LETTER I WITH DIAERESIS --> LATIN SMALL LETTER I WITH DIAERESIS
258             "\xD0" => "\xF0", # LATIN CAPITAL LETTER D WITH STROKE --> LATIN SMALL LETTER D WITH STROKE
259             "\xD1" => "\xF1", # LATIN CAPITAL LETTER N WITH TILDE --> LATIN SMALL LETTER N WITH TILDE
260             "\xD3" => "\xF3", # LATIN CAPITAL LETTER O WITH ACUTE --> LATIN SMALL LETTER O WITH ACUTE
261             "\xD4" => "\xF4", # LATIN CAPITAL LETTER O WITH CIRCUMFLEX --> LATIN SMALL LETTER O WITH CIRCUMFLEX
262             "\xD5" => "\xF5", # LATIN CAPITAL LETTER O WITH HORN --> LATIN SMALL LETTER O WITH HORN
263             "\xD6" => "\xF6", # LATIN CAPITAL LETTER O WITH DIAERESIS --> LATIN SMALL LETTER O WITH DIAERESIS
264             "\xD8" => "\xF8", # LATIN CAPITAL LETTER O WITH STROKE --> LATIN SMALL LETTER O WITH STROKE
265             "\xD9" => "\xF9", # LATIN CAPITAL LETTER U WITH GRAVE --> LATIN SMALL LETTER U WITH GRAVE
266             "\xDA" => "\xFA", # LATIN CAPITAL LETTER U WITH ACUTE --> LATIN SMALL LETTER U WITH ACUTE
267             "\xDB" => "\xFB", # LATIN CAPITAL LETTER U WITH CIRCUMFLEX --> LATIN SMALL LETTER U WITH CIRCUMFLEX
268             "\xDC" => "\xFC", # LATIN CAPITAL LETTER U WITH DIAERESIS --> LATIN SMALL LETTER U WITH DIAERESIS
269             "\xDD" => "\xFD", # LATIN CAPITAL LETTER U WITH HORN --> LATIN SMALL LETTER U WITH HORN
270             "\xDF" => "\x73\x73", # LATIN SMALL LETTER SHARP S --> LATIN SMALL LETTER S, LATIN SMALL LETTER S
271             );
272             }
273              
274             else {
275             croak "Don't know my package name '@{[__PACKAGE__]}'";
276             }
277              
278             #
279             # @ARGV wildcard globbing
280             #
281             sub import {
282              
283 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
284 0         0 my @argv = ();
285 0         0 for (@ARGV) {
286              
287             # has space
288 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
289 0 0       0 if (my @glob = Char::Ewindows1258::glob(qq{"$_"})) {
290 0         0 push @argv, @glob;
291             }
292             else {
293 0         0 push @argv, $_;
294             }
295             }
296              
297             # has wildcard metachar
298             elsif (/\A (?:$q_char)*? [*?] /oxms) {
299 0 0       0 if (my @glob = Char::Ewindows1258::glob($_)) {
300 0         0 push @argv, @glob;
301             }
302             else {
303 0         0 push @argv, $_;
304             }
305             }
306              
307             # no wildcard globbing
308             else {
309 0         0 push @argv, $_;
310             }
311             }
312 0         0 @ARGV = @argv;
313             }
314             }
315              
316             # P.230 Care with Prototypes
317             # in Chapter 6: Subroutines
318             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
319             #
320             # If you aren't careful, you can get yourself into trouble with prototypes.
321             # But if you are careful, you can do a lot of neat things with them. This is
322             # all very powerful, of course, and should only be used in moderation to make
323             # the world a better place.
324              
325             # P.332 Care with Prototypes
326             # in Chapter 7: Subroutines
327             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
328             #
329             # If you aren't careful, you can get yourself into trouble with prototypes.
330             # But if you are careful, you can do a lot of neat things with them. This is
331             # all very powerful, of course, and should only be used in moderation to make
332             # the world a better place.
333              
334             #
335             # Prototypes of subroutines
336             #
337 0     0   0 sub unimport {}
338             sub Char::Ewindows1258::split(;$$$);
339             sub Char::Ewindows1258::tr($$$$;$);
340             sub Char::Ewindows1258::chop(@);
341             sub Char::Ewindows1258::index($$;$);
342             sub Char::Ewindows1258::rindex($$;$);
343             sub Char::Ewindows1258::lcfirst(@);
344             sub Char::Ewindows1258::lcfirst_();
345             sub Char::Ewindows1258::lc(@);
346             sub Char::Ewindows1258::lc_();
347             sub Char::Ewindows1258::ucfirst(@);
348             sub Char::Ewindows1258::ucfirst_();
349             sub Char::Ewindows1258::uc(@);
350             sub Char::Ewindows1258::uc_();
351             sub Char::Ewindows1258::fc(@);
352             sub Char::Ewindows1258::fc_();
353             sub Char::Ewindows1258::ignorecase;
354             sub Char::Ewindows1258::classic_character_class;
355             sub Char::Ewindows1258::capture;
356             sub Char::Ewindows1258::chr(;$);
357             sub Char::Ewindows1258::chr_();
358             sub Char::Ewindows1258::glob($);
359             sub Char::Ewindows1258::glob_();
360              
361             sub Char::Windows1258::ord(;$);
362             sub Char::Windows1258::ord_();
363             sub Char::Windows1258::reverse(@);
364             sub Char::Windows1258::getc(;*@);
365             sub Char::Windows1258::length(;$);
366             sub Char::Windows1258::substr($$;$$);
367             sub Char::Windows1258::index($$;$);
368             sub Char::Windows1258::rindex($$;$);
369             sub Char::Windows1258::escape(;$);
370              
371             #
372             # Regexp work
373             #
374 197     197   15546 BEGIN { CORE::eval q{ use vars qw(
  197     197   1356  
  197         325  
  197         95767  
375             $Char::Windows1258::re_a
376             $Char::Windows1258::re_t
377             $Char::Windows1258::re_n
378             $Char::Windows1258::re_r
379             ) } }
380              
381             #
382             # Character class
383             #
384 197     197   14809 BEGIN { CORE::eval q{ use vars qw(
  197     197   1154  
  197         299  
  197         2732904  
385             $dot
386             $dot_s
387             $eD
388             $eS
389             $eW
390             $eH
391             $eV
392             $eR
393             $eN
394             $not_alnum
395             $not_alpha
396             $not_ascii
397             $not_blank
398             $not_cntrl
399             $not_digit
400             $not_graph
401             $not_lower
402             $not_lower_i
403             $not_print
404             $not_punct
405             $not_space
406             $not_upper
407             $not_upper_i
408             $not_word
409             $not_xdigit
410             $eb
411             $eB
412             ) } }
413              
414             ${Char::Ewindows1258::dot} = qr{(?:[^\x0A])};
415             ${Char::Ewindows1258::dot_s} = qr{(?:[\x00-\xFF])};
416             ${Char::Ewindows1258::eD} = qr{(?:[^0-9])};
417              
418             # Vertical tabs are now whitespace
419             # \s in a regex now matches a vertical tab in all circumstances.
420             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
421             # ${Char::Ewindows1258::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
422             # ${Char::Ewindows1258::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
423             ${Char::Ewindows1258::eS} = qr{(?:[^\s])};
424              
425             ${Char::Ewindows1258::eW} = qr{(?:[^0-9A-Z_a-z])};
426             ${Char::Ewindows1258::eH} = qr{(?:[^\x09\x20])};
427             ${Char::Ewindows1258::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
428             ${Char::Ewindows1258::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
429             ${Char::Ewindows1258::eN} = qr{(?:[^\x0A])};
430             ${Char::Ewindows1258::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
431             ${Char::Ewindows1258::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
432             ${Char::Ewindows1258::not_ascii} = qr{(?:[^\x00-\x7F])};
433             ${Char::Ewindows1258::not_blank} = qr{(?:[^\x09\x20])};
434             ${Char::Ewindows1258::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
435             ${Char::Ewindows1258::not_digit} = qr{(?:[^\x30-\x39])};
436             ${Char::Ewindows1258::not_graph} = qr{(?:[^\x21-\x7F])};
437             ${Char::Ewindows1258::not_lower} = qr{(?:[^\x61-\x7A])};
438             ${Char::Ewindows1258::not_lower_i} = qr{(?:[\x00-\xFF])};
439             ${Char::Ewindows1258::not_print} = qr{(?:[^\x20-\x7F])};
440             ${Char::Ewindows1258::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
441             ${Char::Ewindows1258::not_space} = qr{(?:[^\s\x0B])};
442             ${Char::Ewindows1258::not_upper} = qr{(?:[^\x41-\x5A])};
443             ${Char::Ewindows1258::not_upper_i} = qr{(?:[\x00-\xFF])};
444             ${Char::Ewindows1258::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
445             ${Char::Ewindows1258::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
446             ${Char::Ewindows1258::eb} = qr{(?:\A(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[0-9A-Z_a-z])|(?<=[0-9A-Z_a-z])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]|\z))};
447             ${Char::Ewindows1258::eB} = qr{(?:(?<=[0-9A-Z_a-z])(?=[0-9A-Z_a-z])|(?<=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF])(?=[\x00-\x2F\x40\x5B-\x5E\x60\x7B-\xFF]))};
448              
449             # avoid: Name "Char::Ewindows1258::foo" used only once: possible typo at here.
450             ${Char::Ewindows1258::dot} = ${Char::Ewindows1258::dot};
451             ${Char::Ewindows1258::dot_s} = ${Char::Ewindows1258::dot_s};
452             ${Char::Ewindows1258::eD} = ${Char::Ewindows1258::eD};
453             ${Char::Ewindows1258::eS} = ${Char::Ewindows1258::eS};
454             ${Char::Ewindows1258::eW} = ${Char::Ewindows1258::eW};
455             ${Char::Ewindows1258::eH} = ${Char::Ewindows1258::eH};
456             ${Char::Ewindows1258::eV} = ${Char::Ewindows1258::eV};
457             ${Char::Ewindows1258::eR} = ${Char::Ewindows1258::eR};
458             ${Char::Ewindows1258::eN} = ${Char::Ewindows1258::eN};
459             ${Char::Ewindows1258::not_alnum} = ${Char::Ewindows1258::not_alnum};
460             ${Char::Ewindows1258::not_alpha} = ${Char::Ewindows1258::not_alpha};
461             ${Char::Ewindows1258::not_ascii} = ${Char::Ewindows1258::not_ascii};
462             ${Char::Ewindows1258::not_blank} = ${Char::Ewindows1258::not_blank};
463             ${Char::Ewindows1258::not_cntrl} = ${Char::Ewindows1258::not_cntrl};
464             ${Char::Ewindows1258::not_digit} = ${Char::Ewindows1258::not_digit};
465             ${Char::Ewindows1258::not_graph} = ${Char::Ewindows1258::not_graph};
466             ${Char::Ewindows1258::not_lower} = ${Char::Ewindows1258::not_lower};
467             ${Char::Ewindows1258::not_lower_i} = ${Char::Ewindows1258::not_lower_i};
468             ${Char::Ewindows1258::not_print} = ${Char::Ewindows1258::not_print};
469             ${Char::Ewindows1258::not_punct} = ${Char::Ewindows1258::not_punct};
470             ${Char::Ewindows1258::not_space} = ${Char::Ewindows1258::not_space};
471             ${Char::Ewindows1258::not_upper} = ${Char::Ewindows1258::not_upper};
472             ${Char::Ewindows1258::not_upper_i} = ${Char::Ewindows1258::not_upper_i};
473             ${Char::Ewindows1258::not_word} = ${Char::Ewindows1258::not_word};
474             ${Char::Ewindows1258::not_xdigit} = ${Char::Ewindows1258::not_xdigit};
475             ${Char::Ewindows1258::eb} = ${Char::Ewindows1258::eb};
476             ${Char::Ewindows1258::eB} = ${Char::Ewindows1258::eB};
477              
478             #
479             # Windows-1258 split
480             #
481             sub Char::Ewindows1258::split(;$$$) {
482              
483             # P.794 29.2.161. split
484             # in Chapter 29: Functions
485             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
486              
487             # P.951 split
488             # in Chapter 27: Functions
489             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
490              
491 0     0 0 0 my $pattern = $_[0];
492 0         0 my $string = $_[1];
493 0         0 my $limit = $_[2];
494              
495             # if $pattern is also omitted or is the literal space, " "
496 0 0       0 if (not defined $pattern) {
497 0         0 $pattern = ' ';
498             }
499              
500             # if $string is omitted, the function splits the $_ string
501 0 0       0 if (not defined $string) {
502 0 0       0 if (defined $_) {
503 0         0 $string = $_;
504             }
505             else {
506 0         0 $string = '';
507             }
508             }
509              
510 0         0 my @split = ();
511              
512             # when string is empty
513 0 0       0 if ($string eq '') {
    0          
514              
515             # resulting list value in list context
516 0 0       0 if (wantarray) {
517 0         0 return @split;
518             }
519              
520             # count of substrings in scalar context
521             else {
522 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
523 0         0 @_ = @split;
524 0         0 return scalar @_;
525             }
526             }
527              
528             # split's first argument is more consistently interpreted
529             #
530             # After some changes earlier in v5.17, split's behavior has been simplified:
531             # if the PATTERN argument evaluates to a string containing one space, it is
532             # treated the way that a literal string containing one space once was.
533             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
534              
535             # if $pattern is also omitted or is the literal space, " ", the function splits
536             # on whitespace, /\s+/, after skipping any leading whitespace
537             # (and so on)
538              
539             elsif ($pattern eq ' ') {
540 0 0       0 if (not defined $limit) {
541 0         0 return CORE::split(' ', $string);
542             }
543             else {
544 0         0 return CORE::split(' ', $string, $limit);
545             }
546             }
547              
548             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
549 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
550              
551             # a pattern capable of matching either the null string or something longer than the
552             # null string will split the value of $string into separate characters wherever it
553             # matches the null string between characters
554             # (and so on)
555              
556 0 0       0 if ('' =~ / \A $pattern \z /xms) {
557 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
558 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
559              
560             # P.1024 Appendix W.10 Multibyte Processing
561             # of ISBN 1-56592-224-7 CJKV Information Processing
562             # (and so on)
563              
564             # the //m modifier is assumed when you split on the pattern /^/
565             # (and so on)
566              
567             # V
568 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
569              
570             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
571             # is included in the resulting list, interspersed with the fields that are ordinarily returned
572             # (and so on)
573              
574 0         0 local $@;
575 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
576 0         0 push @split, CORE::eval('$' . $digit);
577             }
578             }
579             }
580              
581             else {
582 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
583              
584             # V
585 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
586 0         0 local $@;
587 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
588 0         0 push @split, CORE::eval('$' . $digit);
589             }
590             }
591             }
592             }
593              
594             elsif ($limit > 0) {
595 0 0       0 if ('' =~ / \A $pattern \z /xms) {
596 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
597 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
598              
599             # V
600 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
601 0         0 local $@;
602 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
603 0         0 push @split, CORE::eval('$' . $digit);
604             }
605             }
606             }
607             }
608             else {
609 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
610 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
611              
612             # V
613 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
614 0         0 local $@;
615 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
616 0         0 push @split, CORE::eval('$' . $digit);
617             }
618             }
619             }
620             }
621             }
622              
623 0 0       0 if (CORE::length($string) > 0) {
624 0         0 push @split, $string;
625             }
626              
627             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
628 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
629 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
630 0         0 pop @split;
631             }
632             }
633              
634             # resulting list value in list context
635 0 0       0 if (wantarray) {
636 0         0 return @split;
637             }
638              
639             # count of substrings in scalar context
640             else {
641 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
642 0         0 @_ = @split;
643 0         0 return scalar @_;
644             }
645             }
646              
647             #
648             # get last subexpression offsets
649             #
650             sub _last_subexpression_offsets {
651 0     0   0 my $pattern = $_[0];
652              
653             # remove comment
654 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
655              
656 0         0 my $modifier = '';
657 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
658 0         0 $modifier = $1;
659 0         0 $modifier =~ s/-[A-Za-z]*//;
660             }
661              
662             # with /x modifier
663 0         0 my @char = ();
664 0 0       0 if ($modifier =~ /x/oxms) {
665 0         0 @char = $pattern =~ /\G(
666             \\ (?:$q_char) |
667             \# (?:$q_char)*? $ |
668             \[ (?: \\\] | (?:$q_char))+? \] |
669             \(\? |
670             (?:$q_char)
671             )/oxmsg;
672             }
673              
674             # without /x modifier
675             else {
676 0         0 @char = $pattern =~ /\G(
677             \\ (?:$q_char) |
678             \[ (?: \\\] | (?:$q_char))+? \] |
679             \(\? |
680             (?:$q_char)
681             )/oxmsg;
682             }
683              
684 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
685             }
686              
687             #
688             # Windows-1258 transliteration (tr///)
689             #
690             sub Char::Ewindows1258::tr($$$$;$) {
691              
692 0     0 0 0 my $bind_operator = $_[1];
693 0         0 my $searchlist = $_[2];
694 0         0 my $replacementlist = $_[3];
695 0   0     0 my $modifier = $_[4] || '';
696              
697 0 0       0 if ($modifier =~ /r/oxms) {
698 0 0       0 if ($bind_operator =~ / !~ /oxms) {
699 0         0 croak "Using !~ with tr///r doesn't make sense";
700             }
701             }
702              
703 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
704 0         0 my @searchlist = _charlist_tr($searchlist);
705 0         0 my @replacementlist = _charlist_tr($replacementlist);
706              
707 0         0 my %tr = ();
708 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
709 0 0       0 if (not exists $tr{$searchlist[$i]}) {
710 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
711 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
712             }
713             elsif ($modifier =~ /d/oxms) {
714 0         0 $tr{$searchlist[$i]} = '';
715             }
716             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
717 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
718             }
719             else {
720 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
721             }
722             }
723             }
724              
725 0         0 my $tr = 0;
726 0         0 my $replaced = '';
727 0 0       0 if ($modifier =~ /c/oxms) {
728 0         0 while (defined(my $char = shift @char)) {
729 0 0       0 if (not exists $tr{$char}) {
730 0 0       0 if (defined $replacementlist[0]) {
731 0         0 $replaced .= $replacementlist[0];
732             }
733 0         0 $tr++;
734 0 0       0 if ($modifier =~ /s/oxms) {
735 0   0     0 while (@char and (not exists $tr{$char[0]})) {
736 0         0 shift @char;
737 0         0 $tr++;
738             }
739             }
740             }
741             else {
742 0         0 $replaced .= $char;
743             }
744             }
745             }
746             else {
747 0         0 while (defined(my $char = shift @char)) {
748 0 0       0 if (exists $tr{$char}) {
749 0         0 $replaced .= $tr{$char};
750 0         0 $tr++;
751 0 0       0 if ($modifier =~ /s/oxms) {
752 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
753 0         0 shift @char;
754 0         0 $tr++;
755             }
756             }
757             }
758             else {
759 0         0 $replaced .= $char;
760             }
761             }
762             }
763              
764 0 0       0 if ($modifier =~ /r/oxms) {
765 0         0 return $replaced;
766             }
767             else {
768 0         0 $_[0] = $replaced;
769 0 0       0 if ($bind_operator =~ / !~ /oxms) {
770 0         0 return not $tr;
771             }
772             else {
773 0         0 return $tr;
774             }
775             }
776             }
777              
778             #
779             # Windows-1258 chop
780             #
781             sub Char::Ewindows1258::chop(@) {
782              
783 0     0 0 0 my $chop;
784 0 0       0 if (@_ == 0) {
785 0         0 my @char = /\G ($q_char) /oxmsg;
786 0         0 $chop = pop @char;
787 0         0 $_ = join '', @char;
788             }
789             else {
790 0         0 for (@_) {
791 0         0 my @char = /\G ($q_char) /oxmsg;
792 0         0 $chop = pop @char;
793 0         0 $_ = join '', @char;
794             }
795             }
796 0         0 return $chop;
797             }
798              
799             #
800             # Windows-1258 index by octet
801             #
802             sub Char::Ewindows1258::index($$;$) {
803              
804 0     0 1 0 my($str,$substr,$position) = @_;
805 0   0     0 $position ||= 0;
806 0         0 my $pos = 0;
807              
808 0         0 while ($pos < CORE::length($str)) {
809 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
810 0 0       0 if ($pos >= $position) {
811 0         0 return $pos;
812             }
813             }
814 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
815 0         0 $pos += CORE::length($1);
816             }
817             else {
818 0         0 $pos += 1;
819             }
820             }
821 0         0 return -1;
822             }
823              
824             #
825             # Windows-1258 reverse index
826             #
827             sub Char::Ewindows1258::rindex($$;$) {
828              
829 0     0 0 0 my($str,$substr,$position) = @_;
830 0   0     0 $position ||= CORE::length($str) - 1;
831 0         0 my $pos = 0;
832 0         0 my $rindex = -1;
833              
834 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
835 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
836 0         0 $rindex = $pos;
837             }
838 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
839 0         0 $pos += CORE::length($1);
840             }
841             else {
842 0         0 $pos += 1;
843             }
844             }
845 0         0 return $rindex;
846             }
847              
848             #
849             # Windows-1258 lower case first with parameter
850             #
851             sub Char::Ewindows1258::lcfirst(@) {
852 0 0   0 0 0 if (@_) {
853 0         0 my $s = shift @_;
854 0 0 0     0 if (@_ and wantarray) {
855 0         0 return Char::Ewindows1258::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
856             }
857             else {
858 0         0 return Char::Ewindows1258::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
859             }
860             }
861             else {
862 0         0 return Char::Ewindows1258::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
863             }
864             }
865              
866             #
867             # Windows-1258 lower case first without parameter
868             #
869             sub Char::Ewindows1258::lcfirst_() {
870 0     0 0 0 return Char::Ewindows1258::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
871             }
872              
873             #
874             # Windows-1258 lower case with parameter
875             #
876             sub Char::Ewindows1258::lc(@) {
877 0 0   0 0 0 if (@_) {
878 0         0 my $s = shift @_;
879 0 0 0     0 if (@_ and wantarray) {
880 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
881             }
882             else {
883 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
884             }
885             }
886             else {
887 0         0 return Char::Ewindows1258::lc_();
888             }
889             }
890              
891             #
892             # Windows-1258 lower case without parameter
893             #
894             sub Char::Ewindows1258::lc_() {
895 0     0 0 0 my $s = $_;
896 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
897             }
898              
899             #
900             # Windows-1258 upper case first with parameter
901             #
902             sub Char::Ewindows1258::ucfirst(@) {
903 0 0   0 0 0 if (@_) {
904 0         0 my $s = shift @_;
905 0 0 0     0 if (@_ and wantarray) {
906 0         0 return Char::Ewindows1258::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
907             }
908             else {
909 0         0 return Char::Ewindows1258::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
910             }
911             }
912             else {
913 0         0 return Char::Ewindows1258::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
914             }
915             }
916              
917             #
918             # Windows-1258 upper case first without parameter
919             #
920             sub Char::Ewindows1258::ucfirst_() {
921 0     0 0 0 return Char::Ewindows1258::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
922             }
923              
924             #
925             # Windows-1258 upper case with parameter
926             #
927             sub Char::Ewindows1258::uc(@) {
928 0 0   0 0 0 if (@_) {
929 0         0 my $s = shift @_;
930 0 0 0     0 if (@_ and wantarray) {
931 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
932             }
933             else {
934 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
935             }
936             }
937             else {
938 0         0 return Char::Ewindows1258::uc_();
939             }
940             }
941              
942             #
943             # Windows-1258 upper case without parameter
944             #
945             sub Char::Ewindows1258::uc_() {
946 0     0 0 0 my $s = $_;
947 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
948             }
949              
950             #
951             # Windows-1258 fold case with parameter
952             #
953             sub Char::Ewindows1258::fc(@) {
954 0 0   0 0 0 if (@_) {
955 0         0 my $s = shift @_;
956 0 0 0     0 if (@_ and wantarray) {
957 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
958             }
959             else {
960 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
961             }
962             }
963             else {
964 0         0 return Char::Ewindows1258::fc_();
965             }
966             }
967              
968             #
969             # Windows-1258 fold case without parameter
970             #
971             sub Char::Ewindows1258::fc_() {
972 0     0 0 0 my $s = $_;
973 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
974             }
975              
976             #
977             # Windows-1258 regexp capture
978             #
979             {
980             sub Char::Ewindows1258::capture {
981 0     0 1 0 return $_[0];
982             }
983             }
984              
985             #
986             # Windows-1258 regexp ignore case modifier
987             #
988             sub Char::Ewindows1258::ignorecase {
989              
990 0     0 0 0 my @string = @_;
991 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
992              
993             # ignore case of $scalar or @array
994 0         0 for my $string (@string) {
995              
996             # split regexp
997 0         0 my @char = $string =~ /\G(
998             \[\^ |
999             \\? (?:$q_char)
1000             )/oxmsg;
1001              
1002             # unescape character
1003 0         0 for (my $i=0; $i <= $#char; $i++) {
1004 0 0       0 next if not defined $char[$i];
1005              
1006             # open character class [...]
1007 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1008 0         0 my $left = $i;
1009              
1010             # [] make die "unmatched [] in regexp ..."
1011              
1012 0 0       0 if ($char[$i+1] eq ']') {
1013 0         0 $i++;
1014             }
1015              
1016 0         0 while (1) {
1017 0 0       0 if (++$i > $#char) {
1018 0         0 croak "Unmatched [] in regexp";
1019             }
1020 0 0       0 if ($char[$i] eq ']') {
1021 0         0 my $right = $i;
1022 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1023              
1024             # escape character
1025 0         0 for my $char (@charlist) {
1026 0 0       0 if (0) {
1027             }
1028              
1029 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1030 0         0 $char = $1 . '\\' . $char;
1031             }
1032             }
1033              
1034             # [...]
1035 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1036              
1037 0         0 $i = $left;
1038 0         0 last;
1039             }
1040             }
1041             }
1042              
1043             # open character class [^...]
1044             elsif ($char[$i] eq '[^') {
1045 0         0 my $left = $i;
1046              
1047             # [^] make die "unmatched [] in regexp ..."
1048              
1049 0 0       0 if ($char[$i+1] eq ']') {
1050 0         0 $i++;
1051             }
1052              
1053 0         0 while (1) {
1054 0 0       0 if (++$i > $#char) {
1055 0         0 croak "Unmatched [] in regexp";
1056             }
1057 0 0       0 if ($char[$i] eq ']') {
1058 0         0 my $right = $i;
1059 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1060              
1061             # escape character
1062 0         0 for my $char (@charlist) {
1063 0 0       0 if (0) {
1064             }
1065              
1066 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
1067 0         0 $char = '\\' . $char;
1068             }
1069             }
1070              
1071             # [^...]
1072 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1073              
1074 0         0 $i = $left;
1075 0         0 last;
1076             }
1077             }
1078             }
1079              
1080             # rewrite classic character class or escape character
1081             elsif (my $char = classic_character_class($char[$i])) {
1082 0         0 $char[$i] = $char;
1083             }
1084              
1085             # with /i modifier
1086             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1087 0         0 my $uc = Char::Ewindows1258::uc($char[$i]);
1088 0         0 my $fc = Char::Ewindows1258::fc($char[$i]);
1089 0 0       0 if ($uc ne $fc) {
1090 0 0       0 if (CORE::length($fc) == 1) {
1091 0         0 $char[$i] = '[' . $uc . $fc . ']';
1092             }
1093             else {
1094 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1095             }
1096             }
1097             }
1098             }
1099              
1100             # characterize
1101 0         0 for (my $i=0; $i <= $#char; $i++) {
1102 0 0       0 next if not defined $char[$i];
1103              
1104 0 0       0 if (0) {
1105             }
1106              
1107             # quote character before ? + * {
1108 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1109 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1110 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1111             }
1112             }
1113             }
1114              
1115 0         0 $string = join '', @char;
1116             }
1117              
1118             # make regexp string
1119 0         0 return @string;
1120             }
1121              
1122             #
1123             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1124             #
1125             sub Char::Ewindows1258::classic_character_class {
1126 0     0 0 0 my($char) = @_;
1127              
1128             return {
1129 0   0     0 '\D' => '${Char::Ewindows1258::eD}',
1130             '\S' => '${Char::Ewindows1258::eS}',
1131             '\W' => '${Char::Ewindows1258::eW}',
1132             '\d' => '[0-9]',
1133              
1134             # Before Perl 5.6, \s only matched the five whitespace characters
1135             # tab, newline, form-feed, carriage return, and the space character
1136             # itself, which, taken together, is the character class [\t\n\f\r ].
1137              
1138             # Vertical tabs are now whitespace
1139             # \s in a regex now matches a vertical tab in all circumstances.
1140             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1141             # \t \n \v \f \r space
1142             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1143             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1144             '\s' => '\s',
1145              
1146             '\w' => '[0-9A-Z_a-z]',
1147             '\C' => '[\x00-\xFF]',
1148             '\X' => 'X',
1149              
1150             # \h \v \H \V
1151              
1152             # P.114 Character Class Shortcuts
1153             # in Chapter 7: In the World of Regular Expressions
1154             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1155              
1156             # P.357 13.2.3 Whitespace
1157             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1158             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1159             #
1160             # 0x00009 CHARACTER TABULATION h s
1161             # 0x0000a LINE FEED (LF) vs
1162             # 0x0000b LINE TABULATION v
1163             # 0x0000c FORM FEED (FF) vs
1164             # 0x0000d CARRIAGE RETURN (CR) vs
1165             # 0x00020 SPACE h s
1166              
1167             # P.196 Table 5-9. Alphanumeric regex metasymbols
1168             # in Chapter 5. Pattern Matching
1169             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1170              
1171             # (and so on)
1172              
1173             '\H' => '${Char::Ewindows1258::eH}',
1174             '\V' => '${Char::Ewindows1258::eV}',
1175             '\h' => '[\x09\x20]',
1176             '\v' => '[\x0A\x0B\x0C\x0D]',
1177             '\R' => '${Char::Ewindows1258::eR}',
1178              
1179             # \N
1180             #
1181             # http://perldoc.perl.org/perlre.html
1182             # Character Classes and other Special Escapes
1183             # Any character but \n (experimental). Not affected by /s modifier
1184              
1185             '\N' => '${Char::Ewindows1258::eN}',
1186              
1187             # \b \B
1188              
1189             # P.180 Boundaries: The \b and \B Assertions
1190             # in Chapter 5: Pattern Matching
1191             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1192              
1193             # P.219 Boundaries: The \b and \B Assertions
1194             # in Chapter 5: Pattern Matching
1195             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1196              
1197             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1198             '\b' => '${Char::Ewindows1258::eb}',
1199              
1200             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1201             '\B' => '${Char::Ewindows1258::eB}',
1202              
1203             }->{$char} || '';
1204             }
1205              
1206             #
1207             # prepare Windows-1258 characters per length
1208             #
1209              
1210             # 1 octet characters
1211             my @chars1 = ();
1212             sub chars1 {
1213 0 0   0 0 0 if (@chars1) {
1214 0         0 return @chars1;
1215             }
1216 0 0       0 if (exists $range_tr{1}) {
1217 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1218 0         0 while (my @range = splice(@ranges,0,1)) {
1219 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1220 0         0 push @chars1, pack 'C', $oct0;
1221             }
1222             }
1223             }
1224 0         0 return @chars1;
1225             }
1226              
1227             # 2 octets characters
1228             my @chars2 = ();
1229             sub chars2 {
1230 0 0   0 0 0 if (@chars2) {
1231 0         0 return @chars2;
1232             }
1233 0 0       0 if (exists $range_tr{2}) {
1234 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1235 0         0 while (my @range = splice(@ranges,0,2)) {
1236 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1237 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1238 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1239             }
1240             }
1241             }
1242             }
1243 0         0 return @chars2;
1244             }
1245              
1246             # 3 octets characters
1247             my @chars3 = ();
1248             sub chars3 {
1249 0 0   0 0 0 if (@chars3) {
1250 0         0 return @chars3;
1251             }
1252 0 0       0 if (exists $range_tr{3}) {
1253 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1254 0         0 while (my @range = splice(@ranges,0,3)) {
1255 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1256 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1257 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1258 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1259             }
1260             }
1261             }
1262             }
1263             }
1264 0         0 return @chars3;
1265             }
1266              
1267             # 4 octets characters
1268             my @chars4 = ();
1269             sub chars4 {
1270 0 0   0 0 0 if (@chars4) {
1271 0         0 return @chars4;
1272             }
1273 0 0       0 if (exists $range_tr{4}) {
1274 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1275 0         0 while (my @range = splice(@ranges,0,4)) {
1276 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1277 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1278 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1279 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1280 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1281             }
1282             }
1283             }
1284             }
1285             }
1286             }
1287 0         0 return @chars4;
1288             }
1289              
1290             #
1291             # Windows-1258 open character list for tr
1292             #
1293             sub _charlist_tr {
1294              
1295 0     0   0 local $_ = shift @_;
1296              
1297             # unescape character
1298 0         0 my @char = ();
1299 0         0 while (not /\G \z/oxmsgc) {
1300 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1301 0         0 push @char, '\-';
1302             }
1303             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1304 0         0 push @char, CORE::chr(oct $1);
1305             }
1306             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1307 0         0 push @char, CORE::chr(hex $1);
1308             }
1309             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1310 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1311             }
1312             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1313 0         0 push @char, {
1314             '\0' => "\0",
1315             '\n' => "\n",
1316             '\r' => "\r",
1317             '\t' => "\t",
1318             '\f' => "\f",
1319             '\b' => "\x08", # \b means backspace in character class
1320             '\a' => "\a",
1321             '\e' => "\e",
1322             }->{$1};
1323             }
1324             elsif (/\G \\ ($q_char) /oxmsgc) {
1325 0         0 push @char, $1;
1326             }
1327             elsif (/\G ($q_char) /oxmsgc) {
1328 0         0 push @char, $1;
1329             }
1330             }
1331              
1332             # join separated multiple-octet
1333 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1334              
1335             # unescape '-'
1336 0         0 my @i = ();
1337 0         0 for my $i (0 .. $#char) {
1338 0 0       0 if ($char[$i] eq '\-') {
    0          
1339 0         0 $char[$i] = '-';
1340             }
1341             elsif ($char[$i] eq '-') {
1342 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1343 0         0 push @i, $i;
1344             }
1345             }
1346             }
1347              
1348             # open character list (reverse for splice)
1349 0         0 for my $i (CORE::reverse @i) {
1350 0         0 my @range = ();
1351              
1352             # range error
1353 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1354 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1355             }
1356              
1357             # range of multiple-octet code
1358 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1359 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1360 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1361             }
1362             elsif (CORE::length($char[$i+1]) == 2) {
1363 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1364 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1365             }
1366             elsif (CORE::length($char[$i+1]) == 3) {
1367 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1368 0         0 push @range, chars2();
1369 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1370             }
1371             elsif (CORE::length($char[$i+1]) == 4) {
1372 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1373 0         0 push @range, chars2();
1374 0         0 push @range, chars3();
1375 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1376             }
1377             else {
1378 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1379             }
1380             }
1381             elsif (CORE::length($char[$i-1]) == 2) {
1382 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1383 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1384             }
1385             elsif (CORE::length($char[$i+1]) == 3) {
1386 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1387 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1388             }
1389             elsif (CORE::length($char[$i+1]) == 4) {
1390 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1391 0         0 push @range, chars3();
1392 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1393             }
1394             else {
1395 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1396             }
1397             }
1398             elsif (CORE::length($char[$i-1]) == 3) {
1399 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1400 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1401             }
1402             elsif (CORE::length($char[$i+1]) == 4) {
1403 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1404 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1405             }
1406             else {
1407 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1408             }
1409             }
1410             elsif (CORE::length($char[$i-1]) == 4) {
1411 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1412 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1413             }
1414             else {
1415 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1416             }
1417             }
1418             else {
1419 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1420             }
1421              
1422 0         0 splice @char, $i-1, 3, @range;
1423             }
1424              
1425 0         0 return @char;
1426             }
1427              
1428             #
1429             # Windows-1258 open character class
1430             #
1431             sub _cc {
1432 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1433 0         0 die __FILE__, ": subroutine cc got no parameter.";
1434             }
1435             elsif (scalar(@_) == 1) {
1436 0         0 return sprintf('\x%02X',$_[0]);
1437             }
1438             elsif (scalar(@_) == 2) {
1439 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1440 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1441             }
1442             elsif ($_[0] == $_[1]) {
1443 0         0 return sprintf('\x%02X',$_[0]);
1444             }
1445             elsif (($_[0]+1) == $_[1]) {
1446 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1447             }
1448             else {
1449 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1450             }
1451             }
1452             else {
1453 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1454             }
1455             }
1456              
1457             #
1458             # Windows-1258 octet range
1459             #
1460             sub _octets {
1461 0     0   0 my $length = shift @_;
1462              
1463 0 0       0 if ($length == 1) {
1464 0         0 my($a1) = unpack 'C', $_[0];
1465 0         0 my($z1) = unpack 'C', $_[1];
1466              
1467 0 0       0 if ($a1 > $z1) {
1468 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1469             }
1470              
1471 0 0       0 if ($a1 == $z1) {
    0          
1472 0         0 return sprintf('\x%02X',$a1);
1473             }
1474             elsif (($a1+1) == $z1) {
1475 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1476             }
1477             else {
1478 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1479             }
1480             }
1481             else {
1482 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1483             }
1484             }
1485              
1486             #
1487             # Windows-1258 range regexp
1488             #
1489             sub _range_regexp {
1490 0     0   0 my($length,$first,$last) = @_;
1491              
1492 0         0 my @range_regexp = ();
1493 0 0       0 if (not exists $range_tr{$length}) {
1494 0         0 return @range_regexp;
1495             }
1496              
1497 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1498 0         0 while (my @range = splice(@ranges,0,$length)) {
1499 0         0 my $min = '';
1500 0         0 my $max = '';
1501 0         0 for (my $i=0; $i < $length; $i++) {
1502 0         0 $min .= pack 'C', $range[$i][0];
1503 0         0 $max .= pack 'C', $range[$i][-1];
1504             }
1505              
1506             # min___max
1507             # FIRST_____________LAST
1508             # (nothing)
1509              
1510 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1511             }
1512              
1513             # **********
1514             # min_________max
1515             # FIRST_____________LAST
1516             # **********
1517              
1518             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1519 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1520             }
1521              
1522             # **********************
1523             # min________________max
1524             # FIRST_____________LAST
1525             # **********************
1526              
1527             elsif (($min eq $first) and ($max eq $last)) {
1528 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1529             }
1530              
1531             # *********
1532             # min___max
1533             # FIRST_____________LAST
1534             # *********
1535              
1536             elsif (($first le $min) and ($max le $last)) {
1537 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1538             }
1539              
1540             # **********************
1541             # min__________________________max
1542             # FIRST_____________LAST
1543             # **********************
1544              
1545             elsif (($min le $first) and ($last le $max)) {
1546 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1547             }
1548              
1549             # *********
1550             # min________max
1551             # FIRST_____________LAST
1552             # *********
1553              
1554             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1555 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1556             }
1557              
1558             # min___max
1559             # FIRST_____________LAST
1560             # (nothing)
1561              
1562             elsif ($last lt $min) {
1563             }
1564              
1565             else {
1566 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1567             }
1568             }
1569              
1570 0         0 return @range_regexp;
1571             }
1572              
1573             #
1574             # Windows-1258 open character list for qr and not qr
1575             #
1576             sub _charlist {
1577              
1578 0     0   0 my $modifier = pop @_;
1579 0         0 my @char = @_;
1580              
1581 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1582              
1583             # unescape character
1584 0         0 for (my $i=0; $i <= $#char; $i++) {
1585              
1586             # escape - to ...
1587 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1588 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1589 0         0 $char[$i] = '...';
1590             }
1591             }
1592              
1593             # octal escape sequence
1594             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1595 0         0 $char[$i] = octchr($1);
1596             }
1597              
1598             # hexadecimal escape sequence
1599             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1600 0         0 $char[$i] = hexchr($1);
1601             }
1602              
1603             # \N{CHARNAME} --> N\{CHARNAME}
1604             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1605 0         0 $char[$i] = $1 . '\\' . $2;
1606             }
1607              
1608             # \p{PROPERTY} --> p\{PROPERTY}
1609             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1610 0         0 $char[$i] = $1 . '\\' . $2;
1611             }
1612              
1613             # \P{PROPERTY} --> P\{PROPERTY}
1614             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1615 0         0 $char[$i] = $1 . '\\' . $2;
1616             }
1617              
1618             # \p, \P, \X --> p, P, X
1619             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1620 0         0 $char[$i] = $1;
1621             }
1622              
1623             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1624 0         0 $char[$i] = CORE::chr oct $1;
1625             }
1626             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1627 0         0 $char[$i] = CORE::chr hex $1;
1628             }
1629             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1630 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1631             }
1632             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1633 0         0 $char[$i] = {
1634             '\0' => "\0",
1635             '\n' => "\n",
1636             '\r' => "\r",
1637             '\t' => "\t",
1638             '\f' => "\f",
1639             '\b' => "\x08", # \b means backspace in character class
1640             '\a' => "\a",
1641             '\e' => "\e",
1642             '\d' => '[0-9]',
1643              
1644             # Vertical tabs are now whitespace
1645             # \s in a regex now matches a vertical tab in all circumstances.
1646             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1647             # \t \n \v \f \r space
1648             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1649             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1650             '\s' => '\s',
1651              
1652             '\w' => '[0-9A-Z_a-z]',
1653             '\D' => '${Char::Ewindows1258::eD}',
1654             '\S' => '${Char::Ewindows1258::eS}',
1655             '\W' => '${Char::Ewindows1258::eW}',
1656              
1657             '\H' => '${Char::Ewindows1258::eH}',
1658             '\V' => '${Char::Ewindows1258::eV}',
1659             '\h' => '[\x09\x20]',
1660             '\v' => '[\x0A\x0B\x0C\x0D]',
1661             '\R' => '${Char::Ewindows1258::eR}',
1662              
1663             }->{$1};
1664             }
1665              
1666             # POSIX-style character classes
1667             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1668 0         0 $char[$i] = {
1669              
1670             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1671             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1672             '[:^lower:]' => '${Char::Ewindows1258::not_lower_i}',
1673             '[:^upper:]' => '${Char::Ewindows1258::not_upper_i}',
1674              
1675             }->{$1};
1676             }
1677             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1678 0         0 $char[$i] = {
1679              
1680             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1681             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1682             '[:ascii:]' => '[\x00-\x7F]',
1683             '[:blank:]' => '[\x09\x20]',
1684             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1685             '[:digit:]' => '[\x30-\x39]',
1686             '[:graph:]' => '[\x21-\x7F]',
1687             '[:lower:]' => '[\x61-\x7A]',
1688             '[:print:]' => '[\x20-\x7F]',
1689             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1690              
1691             # P.174 POSIX-Style Character Classes
1692             # in Chapter 5: Pattern Matching
1693             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1694              
1695             # P.311 11.2.4 Character Classes and other Special Escapes
1696             # in Chapter 11: perlre: Perl regular expressions
1697             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1698              
1699             # P.210 POSIX-Style Character Classes
1700             # in Chapter 5: Pattern Matching
1701             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1702              
1703             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1704              
1705             '[:upper:]' => '[\x41-\x5A]',
1706             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1707             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1708             '[:^alnum:]' => '${Char::Ewindows1258::not_alnum}',
1709             '[:^alpha:]' => '${Char::Ewindows1258::not_alpha}',
1710             '[:^ascii:]' => '${Char::Ewindows1258::not_ascii}',
1711             '[:^blank:]' => '${Char::Ewindows1258::not_blank}',
1712             '[:^cntrl:]' => '${Char::Ewindows1258::not_cntrl}',
1713             '[:^digit:]' => '${Char::Ewindows1258::not_digit}',
1714             '[:^graph:]' => '${Char::Ewindows1258::not_graph}',
1715             '[:^lower:]' => '${Char::Ewindows1258::not_lower}',
1716             '[:^print:]' => '${Char::Ewindows1258::not_print}',
1717             '[:^punct:]' => '${Char::Ewindows1258::not_punct}',
1718             '[:^space:]' => '${Char::Ewindows1258::not_space}',
1719             '[:^upper:]' => '${Char::Ewindows1258::not_upper}',
1720             '[:^word:]' => '${Char::Ewindows1258::not_word}',
1721             '[:^xdigit:]' => '${Char::Ewindows1258::not_xdigit}',
1722              
1723             }->{$1};
1724             }
1725             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1726 0         0 $char[$i] = $1;
1727             }
1728             }
1729              
1730             # open character list
1731 0         0 my @singleoctet = ();
1732 0         0 my @multipleoctet = ();
1733 0         0 for (my $i=0; $i <= $#char; ) {
1734              
1735             # escaped -
1736 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1737 0         0 $i += 1;
1738 0         0 next;
1739             }
1740              
1741             # make range regexp
1742             elsif ($char[$i] eq '...') {
1743              
1744             # range error
1745 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1746 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1747             }
1748             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1749 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1750 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1751             }
1752             }
1753              
1754             # make range regexp per length
1755 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1756 0         0 my @regexp = ();
1757              
1758             # is first and last
1759 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1760 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1761             }
1762              
1763             # is first
1764             elsif ($length == CORE::length($char[$i-1])) {
1765 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1766             }
1767              
1768             # is inside in first and last
1769             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1770 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1771             }
1772              
1773             # is last
1774             elsif ($length == CORE::length($char[$i+1])) {
1775 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1776             }
1777              
1778             else {
1779 0         0 die __FILE__, ": subroutine make_regexp panic.";
1780             }
1781              
1782 0 0       0 if ($length == 1) {
1783 0         0 push @singleoctet, @regexp;
1784             }
1785             else {
1786 0         0 push @multipleoctet, @regexp;
1787             }
1788             }
1789              
1790 0         0 $i += 2;
1791             }
1792              
1793             # with /i modifier
1794             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1795 0 0       0 if ($modifier =~ /i/oxms) {
1796 0         0 my $uc = Char::Ewindows1258::uc($char[$i]);
1797 0         0 my $fc = Char::Ewindows1258::fc($char[$i]);
1798 0 0       0 if ($uc ne $fc) {
1799 0 0       0 if (CORE::length($fc) == 1) {
1800 0         0 push @singleoctet, $uc, $fc;
1801             }
1802             else {
1803 0         0 push @singleoctet, $uc;
1804 0         0 push @multipleoctet, $fc;
1805             }
1806             }
1807             else {
1808 0         0 push @singleoctet, $char[$i];
1809             }
1810             }
1811             else {
1812 0         0 push @singleoctet, $char[$i];
1813             }
1814 0         0 $i += 1;
1815             }
1816              
1817             # single character of single octet code
1818             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1819 0         0 push @singleoctet, "\t", "\x20";
1820 0         0 $i += 1;
1821             }
1822             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1823 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1824 0         0 $i += 1;
1825             }
1826             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1827 0         0 push @singleoctet, $char[$i];
1828 0         0 $i += 1;
1829             }
1830              
1831             # single character of multiple-octet code
1832             else {
1833 0         0 push @multipleoctet, $char[$i];
1834 0         0 $i += 1;
1835             }
1836             }
1837              
1838             # quote metachar
1839 0         0 for (@singleoctet) {
1840 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1841 0         0 $_ = '-';
1842             }
1843             elsif (/\A \n \z/oxms) {
1844 0         0 $_ = '\n';
1845             }
1846             elsif (/\A \r \z/oxms) {
1847 0         0 $_ = '\r';
1848             }
1849             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1850 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1851             }
1852             elsif (/\A [\x00-\xFF] \z/oxms) {
1853 0         0 $_ = quotemeta $_;
1854             }
1855             }
1856              
1857             # return character list
1858 0         0 return \@singleoctet, \@multipleoctet;
1859             }
1860              
1861             #
1862             # Windows-1258 octal escape sequence
1863             #
1864             sub octchr {
1865 0     0 0 0 my($octdigit) = @_;
1866              
1867 0         0 my @binary = ();
1868 0         0 for my $octal (split(//,$octdigit)) {
1869 0         0 push @binary, {
1870             '0' => '000',
1871             '1' => '001',
1872             '2' => '010',
1873             '3' => '011',
1874             '4' => '100',
1875             '5' => '101',
1876             '6' => '110',
1877             '7' => '111',
1878             }->{$octal};
1879             }
1880 0         0 my $binary = join '', @binary;
1881              
1882 0         0 my $octchr = {
1883             # 1234567
1884             1 => pack('B*', "0000000$binary"),
1885             2 => pack('B*', "000000$binary"),
1886             3 => pack('B*', "00000$binary"),
1887             4 => pack('B*', "0000$binary"),
1888             5 => pack('B*', "000$binary"),
1889             6 => pack('B*', "00$binary"),
1890             7 => pack('B*', "0$binary"),
1891             0 => pack('B*', "$binary"),
1892              
1893             }->{CORE::length($binary) % 8};
1894              
1895 0         0 return $octchr;
1896             }
1897              
1898             #
1899             # Windows-1258 hexadecimal escape sequence
1900             #
1901             sub hexchr {
1902 0     0 0 0 my($hexdigit) = @_;
1903              
1904 0         0 my $hexchr = {
1905             1 => pack('H*', "0$hexdigit"),
1906             0 => pack('H*', "$hexdigit"),
1907              
1908             }->{CORE::length($_[0]) % 2};
1909              
1910 0         0 return $hexchr;
1911             }
1912              
1913             #
1914             # Windows-1258 open character list for qr
1915             #
1916             sub charlist_qr {
1917              
1918 0     0 0 0 my $modifier = pop @_;
1919 0         0 my @char = @_;
1920              
1921 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1922 0         0 my @singleoctet = @$singleoctet;
1923 0         0 my @multipleoctet = @$multipleoctet;
1924              
1925             # return character list
1926 0 0       0 if (scalar(@singleoctet) >= 1) {
1927              
1928             # with /i modifier
1929 0 0       0 if ($modifier =~ m/i/oxms) {
1930 0         0 my %singleoctet_ignorecase = ();
1931 0         0 for (@singleoctet) {
1932 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1933 0         0 for my $ord (hex($1) .. hex($2)) {
1934 0         0 my $char = CORE::chr($ord);
1935 0         0 my $uc = Char::Ewindows1258::uc($char);
1936 0         0 my $fc = Char::Ewindows1258::fc($char);
1937 0 0       0 if ($uc eq $fc) {
1938 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1939             }
1940             else {
1941 0 0       0 if (CORE::length($fc) == 1) {
1942 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1943 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1944             }
1945             else {
1946 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1947 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1948             }
1949             }
1950             }
1951             }
1952 0 0       0 if ($_ ne '') {
1953 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1954             }
1955             }
1956 0         0 my $i = 0;
1957 0         0 my @singleoctet_ignorecase = ();
1958 0         0 for my $ord (0 .. 255) {
1959 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1960 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1961             }
1962             else {
1963 0         0 $i++;
1964             }
1965             }
1966 0         0 @singleoctet = ();
1967 0         0 for my $range (@singleoctet_ignorecase) {
1968 0 0       0 if (ref $range) {
1969 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1970 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1971             }
1972             elsif (scalar(@{$range}) == 2) {
1973 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1974             }
1975             else {
1976 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1977             }
1978             }
1979             }
1980             }
1981              
1982 0         0 my $not_anchor = '';
1983              
1984 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1985             }
1986 0 0       0 if (scalar(@multipleoctet) >= 2) {
1987 0         0 return '(?:' . join('|', @multipleoctet) . ')';
1988             }
1989             else {
1990 0         0 return $multipleoctet[0];
1991             }
1992             }
1993              
1994             #
1995             # Windows-1258 open character list for not qr
1996             #
1997             sub charlist_not_qr {
1998              
1999 0     0 0 0 my $modifier = pop @_;
2000 0         0 my @char = @_;
2001              
2002 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2003 0         0 my @singleoctet = @$singleoctet;
2004 0         0 my @multipleoctet = @$multipleoctet;
2005              
2006             # with /i modifier
2007 0 0       0 if ($modifier =~ m/i/oxms) {
2008 0         0 my %singleoctet_ignorecase = ();
2009 0         0 for (@singleoctet) {
2010 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2011 0         0 for my $ord (hex($1) .. hex($2)) {
2012 0         0 my $char = CORE::chr($ord);
2013 0         0 my $uc = Char::Ewindows1258::uc($char);
2014 0         0 my $fc = Char::Ewindows1258::fc($char);
2015 0 0       0 if ($uc eq $fc) {
2016 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2017             }
2018             else {
2019 0 0       0 if (CORE::length($fc) == 1) {
2020 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2021 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2022             }
2023             else {
2024 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2025 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2026             }
2027             }
2028             }
2029             }
2030 0 0       0 if ($_ ne '') {
2031 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2032             }
2033             }
2034 0         0 my $i = 0;
2035 0         0 my @singleoctet_ignorecase = ();
2036 0         0 for my $ord (0 .. 255) {
2037 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
2038 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
2039             }
2040             else {
2041 0         0 $i++;
2042             }
2043             }
2044 0         0 @singleoctet = ();
2045 0         0 for my $range (@singleoctet_ignorecase) {
2046 0 0       0 if (ref $range) {
2047 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
2048 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2049             }
2050             elsif (scalar(@{$range}) == 2) {
2051 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2052             }
2053             else {
2054 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2055             }
2056             }
2057             }
2058             }
2059              
2060             # return character list
2061 0 0       0 if (scalar(@multipleoctet) >= 1) {
2062 0 0       0 if (scalar(@singleoctet) >= 1) {
2063              
2064             # any character other than multiple-octet and single octet character class
2065 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
2066             }
2067             else {
2068              
2069             # any character other than multiple-octet character class
2070 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2071             }
2072             }
2073             else {
2074 0 0       0 if (scalar(@singleoctet) >= 1) {
2075              
2076             # any character other than single octet character class
2077 0         0 return '(?:[^' . join('', @singleoctet) . '])';
2078             }
2079             else {
2080              
2081             # any character
2082 0         0 return "(?:$your_char)";
2083             }
2084             }
2085             }
2086              
2087             #
2088             # open file in read mode
2089             #
2090             sub _open_r {
2091 197     197   610 my(undef,$file) = @_;
2092 197         880 $file =~ s#\A (\s) #./$1#oxms;
2093 197   33     22082 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2094             open($_[0],"< $file\0");
2095             }
2096              
2097             #
2098             # open file in write mode
2099             #
2100             sub _open_w {
2101 0     0   0 my(undef,$file) = @_;
2102 0         0 $file =~ s#\A (\s) #./$1#oxms;
2103 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2104             open($_[0],"> $file\0");
2105             }
2106              
2107             #
2108             # open file in append mode
2109             #
2110             sub _open_a {
2111 0     0   0 my(undef,$file) = @_;
2112 0         0 $file =~ s#\A (\s) #./$1#oxms;
2113 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2114             open($_[0],">> $file\0");
2115             }
2116              
2117             #
2118             # safe system
2119             #
2120             sub _systemx {
2121              
2122             # P.707 29.2.33. exec
2123             # in Chapter 29: Functions
2124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2125             #
2126             # Be aware that in older releases of Perl, exec (and system) did not flush
2127             # your output buffer, so you needed to enable command buffering by setting $|
2128             # on one or more filehandles to avoid lost output in the case of exec, or
2129             # misordererd output in the case of system. This situation was largely remedied
2130             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2131              
2132             # P.855 exec
2133             # in Chapter 27: Functions
2134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2135             #
2136             # In very old release of Perl (before v5.6), exec (and system) did not flush
2137             # your output buffer, so you needed to enable command buffering by setting $|
2138             # on one or more filehandles to avoid lost output with exec or misordered
2139             # output with system.
2140              
2141 197     197   652 $| = 1;
2142              
2143             # P.565 23.1.2. Cleaning Up Your Environment
2144             # in Chapter 23: Security
2145             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2146              
2147             # P.656 Cleaning Up Your Environment
2148             # in Chapter 20: Security
2149             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2150              
2151             # local $ENV{'PATH'} = '.';
2152 197         1792 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2153              
2154             # P.707 29.2.33. exec
2155             # in Chapter 29: Functions
2156             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2157             #
2158             # As we mentioned earlier, exec treats a discrete list of arguments as an
2159             # indication that it should bypass shell processing. However, there is one
2160             # place where you might still get tripped up. The exec call (and system, too)
2161             # will not distinguish between a single scalar argument and an array containing
2162             # only one element.
2163             #
2164             # @args = ("echo surprise"); # just one element in list
2165             # exec @args # still subject to shell escapes
2166             # or die "exec: $!"; # because @args == 1
2167             #
2168             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2169             # first argument as the pathname, which forces the rest of the arguments to be
2170             # interpreted as a list, even if there is only one of them:
2171             #
2172             # exec { $args[0] } @args # safe even with one-argument list
2173             # or die "can't exec @args: $!";
2174              
2175             # P.855 exec
2176             # in Chapter 27: Functions
2177             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2178             #
2179             # As we mentioned earlier, exec treats a discrete list of arguments as a
2180             # directive to bypass shell processing. However, there is one place where
2181             # you might still get tripped up. The exec call (and system, too) cannot
2182             # distinguish between a single scalar argument and an array containing
2183             # only one element.
2184             #
2185             # @args = ("echo surprise"); # just one element in list
2186             # exec @args # still subject to shell escapes
2187             # || die "exec: $!"; # because @args == 1
2188             #
2189             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2190             # argument as the pathname, which forces the rest of the arguments to be
2191             # interpreted as a list, even if there is only one of them:
2192             #
2193             # exec { $args[0] } @args # safe even with one-argument list
2194             # || die "can't exec @args: $!";
2195              
2196 197         367 return CORE::system { $_[0] } @_; # safe even with one-argument list
  197         19839823  
2197             }
2198              
2199             #
2200             # Windows-1258 order to character (with parameter)
2201             #
2202             sub Char::Ewindows1258::chr(;$) {
2203              
2204 0 0   0 0   my $c = @_ ? $_[0] : $_;
2205              
2206 0 0         if ($c == 0x00) {
2207 0           return "\x00";
2208             }
2209             else {
2210 0           my @chr = ();
2211 0           while ($c > 0) {
2212 0           unshift @chr, ($c % 0x100);
2213 0           $c = int($c / 0x100);
2214             }
2215 0           return pack 'C*', @chr;
2216             }
2217             }
2218              
2219             #
2220             # Windows-1258 order to character (without parameter)
2221             #
2222             sub Char::Ewindows1258::chr_() {
2223              
2224 0     0 0   my $c = $_;
2225              
2226 0 0         if ($c == 0x00) {
2227 0           return "\x00";
2228             }
2229             else {
2230 0           my @chr = ();
2231 0           while ($c > 0) {
2232 0           unshift @chr, ($c % 0x100);
2233 0           $c = int($c / 0x100);
2234             }
2235 0           return pack 'C*', @chr;
2236             }
2237             }
2238              
2239             #
2240             # Windows-1258 path globbing (with parameter)
2241             #
2242             sub Char::Ewindows1258::glob($) {
2243              
2244 0 0   0 0   if (wantarray) {
2245 0           my @glob = _DOS_like_glob(@_);
2246 0           for my $glob (@glob) {
2247 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2248             }
2249 0           return @glob;
2250             }
2251             else {
2252 0           my $glob = _DOS_like_glob(@_);
2253 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2254 0           return $glob;
2255             }
2256             }
2257              
2258             #
2259             # Windows-1258 path globbing (without parameter)
2260             #
2261             sub Char::Ewindows1258::glob_() {
2262              
2263 0 0   0 0   if (wantarray) {
2264 0           my @glob = _DOS_like_glob();
2265 0           for my $glob (@glob) {
2266 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2267             }
2268 0           return @glob;
2269             }
2270             else {
2271 0           my $glob = _DOS_like_glob();
2272 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2273 0           return $glob;
2274             }
2275             }
2276              
2277             #
2278             # Windows-1258 path globbing via File::DosGlob 1.10
2279             #
2280             # Often I confuse "_dosglob" and "_doglob".
2281             # So, I renamed "_dosglob" to "_DOS_like_glob".
2282             #
2283             my %iter;
2284             my %entries;
2285             sub _DOS_like_glob {
2286              
2287             # context (keyed by second cxix argument provided by core)
2288 0     0     my($expr,$cxix) = @_;
2289              
2290             # glob without args defaults to $_
2291 0 0         $expr = $_ if not defined $expr;
2292              
2293             # represents the current user's home directory
2294             #
2295             # 7.3. Expanding Tildes in Filenames
2296             # in Chapter 7. File Access
2297             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2298             #
2299             # and File::HomeDir, File::HomeDir::Windows module
2300              
2301             # DOS-like system
2302 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2303 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2304 0           { my_home_MSWin32() }oxmse;
2305             }
2306              
2307             # UNIX-like system
2308             else {
2309 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2310 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2311             }
2312              
2313             # assume global context if not provided one
2314 0 0         $cxix = '_G_' if not defined $cxix;
2315 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2316              
2317             # if we're just beginning, do it all first
2318 0 0         if ($iter{$cxix} == 0) {
2319 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2320             }
2321              
2322             # chuck it all out, quick or slow
2323 0 0         if (wantarray) {
2324 0           delete $iter{$cxix};
2325 0           return @{delete $entries{$cxix}};
  0            
2326             }
2327             else {
2328 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2329 0           return shift @{$entries{$cxix}};
  0            
2330             }
2331             else {
2332             # return undef for EOL
2333 0           delete $iter{$cxix};
2334 0           delete $entries{$cxix};
2335 0           return undef;
2336             }
2337             }
2338             }
2339              
2340             #
2341             # Windows-1258 path globbing subroutine
2342             #
2343             sub _do_glob {
2344              
2345 0     0     my($cond,@expr) = @_;
2346 0           my @glob = ();
2347 0           my $fix_drive_relative_paths = 0;
2348              
2349             OUTER:
2350 0           for my $expr (@expr) {
2351 0 0         next OUTER if not defined $expr;
2352 0 0         next OUTER if $expr eq '';
2353              
2354 0           my @matched = ();
2355 0           my @globdir = ();
2356 0           my $head = '.';
2357 0           my $pathsep = '/';
2358 0           my $tail;
2359              
2360             # if argument is within quotes strip em and do no globbing
2361 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2362 0           $expr = $1;
2363 0 0         if ($cond eq 'd') {
2364 0 0         if (-d $expr) {
2365 0           push @glob, $expr;
2366             }
2367             }
2368             else {
2369 0 0         if (-e $expr) {
2370 0           push @glob, $expr;
2371             }
2372             }
2373 0           next OUTER;
2374             }
2375              
2376             # wildcards with a drive prefix such as h:*.pm must be changed
2377             # to h:./*.pm to expand correctly
2378 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2379 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2380 0           $fix_drive_relative_paths = 1;
2381             }
2382             }
2383              
2384 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2385 0 0         if ($tail eq '') {
2386 0           push @glob, $expr;
2387 0           next OUTER;
2388             }
2389 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2390 0 0         if (@globdir = _do_glob('d', $head)) {
2391 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2392 0           next OUTER;
2393             }
2394             }
2395 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2396 0           $head .= $pathsep;
2397             }
2398 0           $expr = $tail;
2399             }
2400              
2401             # If file component has no wildcards, we can avoid opendir
2402 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2403 0 0         if ($head eq '.') {
2404 0           $head = '';
2405             }
2406 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2407 0           $head .= $pathsep;
2408             }
2409 0           $head .= $expr;
2410 0 0         if ($cond eq 'd') {
2411 0 0         if (-d $head) {
2412 0           push @glob, $head;
2413             }
2414             }
2415             else {
2416 0 0         if (-e $head) {
2417 0           push @glob, $head;
2418             }
2419             }
2420 0           next OUTER;
2421             }
2422 0 0         opendir(*DIR, $head) or next OUTER;
2423 0           my @leaf = readdir DIR;
2424 0           closedir DIR;
2425              
2426 0 0         if ($head eq '.') {
2427 0           $head = '';
2428             }
2429 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2430 0           $head .= $pathsep;
2431             }
2432              
2433 0           my $pattern = '';
2434 0           while ($expr =~ / \G ($q_char) /oxgc) {
2435 0           my $char = $1;
2436              
2437             # 6.9. Matching Shell Globs as Regular Expressions
2438             # in Chapter 6. Pattern Matching
2439             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2440             # (and so on)
2441              
2442 0 0         if ($char eq '*') {
    0          
    0          
2443 0           $pattern .= "(?:$your_char)*",
2444             }
2445             elsif ($char eq '?') {
2446 0           $pattern .= "(?:$your_char)?", # DOS style
2447             # $pattern .= "(?:$your_char)", # UNIX style
2448             }
2449             elsif ((my $fc = Char::Ewindows1258::fc($char)) ne $char) {
2450 0           $pattern .= $fc;
2451             }
2452             else {
2453 0           $pattern .= quotemeta $char;
2454             }
2455             }
2456 0     0     my $matchsub = sub { Char::Ewindows1258::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2457              
2458             # if ($@) {
2459             # print STDERR "$0: $@\n";
2460             # next OUTER;
2461             # }
2462              
2463             INNER:
2464 0           for my $leaf (@leaf) {
2465 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2466 0           next INNER;
2467             }
2468 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2469 0           next INNER;
2470             }
2471              
2472 0 0         if (&$matchsub($leaf)) {
2473 0           push @matched, "$head$leaf";
2474 0           next INNER;
2475             }
2476              
2477             # [DOS compatibility special case]
2478             # Failed, add a trailing dot and try again, but only...
2479              
2480 0 0 0       if (Char::Ewindows1258::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2481             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2482             Char::Ewindows1258::index($pattern,'\\.') != -1 # pattern has a dot.
2483             ) {
2484 0 0         if (&$matchsub("$leaf.")) {
2485 0           push @matched, "$head$leaf";
2486 0           next INNER;
2487             }
2488             }
2489             }
2490 0 0         if (@matched) {
2491 0           push @glob, @matched;
2492             }
2493             }
2494 0 0         if ($fix_drive_relative_paths) {
2495 0           for my $glob (@glob) {
2496 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2497             }
2498             }
2499 0           return @glob;
2500             }
2501              
2502             #
2503             # Windows-1258 parse line
2504             #
2505             sub _parse_line {
2506              
2507 0     0     my($line) = @_;
2508              
2509 0           $line .= ' ';
2510 0           my @piece = ();
2511 0           while ($line =~ /
2512             " ( (?: [^"] )* ) " \s+ |
2513             ( (?: [^"\s] )* ) \s+
2514             /oxmsg
2515             ) {
2516 0 0         push @piece, defined($1) ? $1 : $2;
2517             }
2518 0           return @piece;
2519             }
2520              
2521             #
2522             # Windows-1258 parse path
2523             #
2524             sub _parse_path {
2525              
2526 0     0     my($path,$pathsep) = @_;
2527              
2528 0           $path .= '/';
2529 0           my @subpath = ();
2530 0           while ($path =~ /
2531             ((?: [^\/\\] )+?) [\/\\]
2532             /oxmsg
2533             ) {
2534 0           push @subpath, $1;
2535             }
2536              
2537 0           my $tail = pop @subpath;
2538 0           my $head = join $pathsep, @subpath;
2539 0           return $head, $tail;
2540             }
2541              
2542             #
2543             # via File::HomeDir::Windows 1.00
2544             #
2545             sub my_home_MSWin32 {
2546              
2547             # A lot of unix people and unix-derived tools rely on
2548             # the ability to overload HOME. We will support it too
2549             # so that they can replace raw HOME calls with File::HomeDir.
2550 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2551 0           return $ENV{'HOME'};
2552             }
2553              
2554             # Do we have a user profile?
2555             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2556 0           return $ENV{'USERPROFILE'};
2557             }
2558              
2559             # Some Windows use something like $ENV{'HOME'}
2560             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2561 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2562             }
2563              
2564 0           return undef;
2565             }
2566              
2567             #
2568             # via File::HomeDir::Unix 1.00
2569             #
2570             sub my_home {
2571 0     0 0   my $home;
2572              
2573 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2574 0           $home = $ENV{'HOME'};
2575             }
2576              
2577             # This is from the original code, but I'm guessing
2578             # it means "login directory" and exists on some Unixes.
2579             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2580 0           $home = $ENV{'LOGDIR'};
2581             }
2582              
2583             ### More-desperate methods
2584              
2585             # Light desperation on any (Unixish) platform
2586             else {
2587 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2588             }
2589              
2590             # On Unix in general, a non-existant home means "no home"
2591             # For example, "nobody"-like users might use /nonexistant
2592 0 0 0       if (defined $home and ! -d($home)) {
2593 0           $home = undef;
2594             }
2595 0           return $home;
2596             }
2597              
2598             #
2599             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2600             #
2601             sub Char::Ewindows1258::PREMATCH {
2602 0     0 0   return $`;
2603             }
2604              
2605             #
2606             # ${^MATCH}, $MATCH, $& the string that matched
2607             #
2608             sub Char::Ewindows1258::MATCH {
2609 0     0 0   return $&;
2610             }
2611              
2612             #
2613             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2614             #
2615             sub Char::Ewindows1258::POSTMATCH {
2616 0     0 0   return $';
2617             }
2618              
2619             #
2620             # Windows-1258 character to order (with parameter)
2621             #
2622             sub Char::Windows1258::ord(;$) {
2623              
2624 0 0   0 1   local $_ = shift if @_;
2625              
2626 0 0         if (/\A ($q_char) /oxms) {
2627 0           my @ord = unpack 'C*', $1;
2628 0           my $ord = 0;
2629 0           while (my $o = shift @ord) {
2630 0           $ord = $ord * 0x100 + $o;
2631             }
2632 0           return $ord;
2633             }
2634             else {
2635 0           return CORE::ord $_;
2636             }
2637             }
2638              
2639             #
2640             # Windows-1258 character to order (without parameter)
2641             #
2642             sub Char::Windows1258::ord_() {
2643              
2644 0 0   0 0   if (/\A ($q_char) /oxms) {
2645 0           my @ord = unpack 'C*', $1;
2646 0           my $ord = 0;
2647 0           while (my $o = shift @ord) {
2648 0           $ord = $ord * 0x100 + $o;
2649             }
2650 0           return $ord;
2651             }
2652             else {
2653 0           return CORE::ord $_;
2654             }
2655             }
2656              
2657             #
2658             # Windows-1258 reverse
2659             #
2660             sub Char::Windows1258::reverse(@) {
2661              
2662 0 0   0 0   if (wantarray) {
2663 0           return CORE::reverse @_;
2664             }
2665             else {
2666              
2667             # One of us once cornered Larry in an elevator and asked him what
2668             # problem he was solving with this, but he looked as far off into
2669             # the distance as he could in an elevator and said, "It seemed like
2670             # a good idea at the time."
2671              
2672 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2673             }
2674             }
2675              
2676             #
2677             # Windows-1258 getc (with parameter, without parameter)
2678             #
2679             sub Char::Windows1258::getc(;*@) {
2680              
2681 0     0 0   my($package) = caller;
2682 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2683 0 0 0       croak 'Too many arguments for Char::Windows1258::getc' if @_ and not wantarray;
2684              
2685 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2686 0           my $getc = '';
2687 0           for my $length ($length[0] .. $length[-1]) {
2688 0           $getc .= CORE::getc($fh);
2689 0 0         if (exists $range_tr{CORE::length($getc)}) {
2690 0 0         if ($getc =~ /\A ${Char::Ewindows1258::dot_s} \z/oxms) {
2691 0 0         return wantarray ? ($getc,@_) : $getc;
2692             }
2693             }
2694             }
2695 0 0         return wantarray ? ($getc,@_) : $getc;
2696             }
2697              
2698             #
2699             # Windows-1258 length by character
2700             #
2701             sub Char::Windows1258::length(;$) {
2702              
2703 0 0   0 1   local $_ = shift if @_;
2704              
2705 0           local @_ = /\G ($q_char) /oxmsg;
2706 0           return scalar @_;
2707             }
2708              
2709             #
2710             # Windows-1258 substr by character
2711             #
2712             BEGIN {
2713              
2714             # P.232 The lvalue Attribute
2715             # in Chapter 6: Subroutines
2716             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2717              
2718             # P.336 The lvalue Attribute
2719             # in Chapter 7: Subroutines
2720             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2721              
2722             # P.144 8.4 Lvalue subroutines
2723             # in Chapter 8: perlsub: Perl subroutines
2724             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2725              
2726 197 50 0 197 1 125427 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0      
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
2727             # vv----------------*******
2728             sub Char::Windows1258::substr($$;$$) %s {
2729              
2730             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2731              
2732             # If the substring is beyond either end of the string, substr() returns the undefined
2733             # value and produces a warning. When used as an lvalue, specifying a substring that
2734             # is entirely outside the string raises an exception.
2735             # http://perldoc.perl.org/functions/substr.html
2736              
2737             # A return with no argument returns the scalar value undef in scalar context,
2738             # an empty list () in list context, and (naturally) nothing at all in void
2739             # context.
2740              
2741             my $offset = $_[1];
2742             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2743             return;
2744             }
2745              
2746             # substr($string,$offset,$length,$replacement)
2747             if (@_ == 4) {
2748             my(undef,undef,$length,$replacement) = @_;
2749             my $substr = join '', splice(@char, $offset, $length, $replacement);
2750             $_[0] = join '', @char;
2751              
2752             # return $substr; this doesn't work, don't say "return"
2753             $substr;
2754             }
2755              
2756             # substr($string,$offset,$length)
2757             elsif (@_ == 3) {
2758             my(undef,undef,$length) = @_;
2759             my $octet_offset = 0;
2760             my $octet_length = 0;
2761             if ($offset == 0) {
2762             $octet_offset = 0;
2763             }
2764             elsif ($offset > 0) {
2765             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2766             }
2767             else {
2768             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2769             }
2770             if ($length == 0) {
2771             $octet_length = 0;
2772             }
2773             elsif ($length > 0) {
2774             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2775             }
2776             else {
2777             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2778             }
2779             CORE::substr($_[0], $octet_offset, $octet_length);
2780             }
2781              
2782             # substr($string,$offset)
2783             else {
2784             my $octet_offset = 0;
2785             if ($offset == 0) {
2786             $octet_offset = 0;
2787             }
2788             elsif ($offset > 0) {
2789             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2790             }
2791             else {
2792             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2793             }
2794             CORE::substr($_[0], $octet_offset);
2795             }
2796             }
2797             END
2798             }
2799              
2800             #
2801             # Windows-1258 index by character
2802             #
2803             sub Char::Windows1258::index($$;$) {
2804              
2805 0     0 1   my $index;
2806 0 0         if (@_ == 3) {
2807 0           $index = Char::Ewindows1258::index($_[0], $_[1], CORE::length(Char::Windows1258::substr($_[0], 0, $_[2])));
2808             }
2809             else {
2810 0           $index = Char::Ewindows1258::index($_[0], $_[1]);
2811             }
2812              
2813 0 0         if ($index == -1) {
2814 0           return -1;
2815             }
2816             else {
2817 0           return Char::Windows1258::length(CORE::substr $_[0], 0, $index);
2818             }
2819             }
2820              
2821             #
2822             # Windows-1258 rindex by character
2823             #
2824             sub Char::Windows1258::rindex($$;$) {
2825              
2826 0     0 1   my $rindex;
2827 0 0         if (@_ == 3) {
2828 0           $rindex = Char::Ewindows1258::rindex($_[0], $_[1], CORE::length(Char::Windows1258::substr($_[0], 0, $_[2])));
2829             }
2830             else {
2831 0           $rindex = Char::Ewindows1258::rindex($_[0], $_[1]);
2832             }
2833              
2834 0 0         if ($rindex == -1) {
2835 0           return -1;
2836             }
2837             else {
2838 0           return Char::Windows1258::length(CORE::substr $_[0], 0, $rindex);
2839             }
2840             }
2841              
2842             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2843             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2844 197     197   16144 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  197     197   1909  
  197         387  
  197         14959  
2845              
2846             # ord() to ord() or Char::Windows1258::ord()
2847 197     197   11237 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  197     197   1088  
  197         416  
  197         10976  
2848              
2849             # ord to ord or Char::Windows1258::ord_
2850 197     197   10621 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  197     197   1049  
  197         328  
  197         10905  
2851              
2852             # reverse to reverse or Char::Windows1258::reverse
2853 197     197   10740 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  197     197   964  
  197         490  
  197         12533  
2854              
2855             # getc to getc or Char::Windows1258::getc
2856 197     197   10384 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  197     197   1021  
  197         573  
  197         12070  
2857              
2858             # P.1023 Appendix W.9 Multibyte Anchoring
2859             # of ISBN 1-56592-224-7 CJKV Information Processing
2860              
2861             my $anchor = '';
2862              
2863 197     197   11054 BEGIN { CORE::eval q{ use vars qw($nest) } }
  197     197   978  
  197         333  
  197         10263771  
2864              
2865             # regexp of nested parens in qqXX
2866              
2867             # P.340 Matching Nested Constructs with Embedded Code
2868             # in Chapter 7: Perl
2869             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2870              
2871             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2872             \\c[\x40-\x5F] |
2873             \\ [\x00-\xFF] |
2874             [^()] |
2875             \( (?{$nest++}) |
2876             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2877             }xms;
2878             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2879             \\c[\x40-\x5F] |
2880             \\ [\x00-\xFF] |
2881             [^{}] |
2882             \{ (?{$nest++}) |
2883             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2884             }xms;
2885             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2886             \\c[\x40-\x5F] |
2887             \\ [\x00-\xFF] |
2888             [^[\]] |
2889             \[ (?{$nest++}) |
2890             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2891             }xms;
2892             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2893             \\c[\x40-\x5F] |
2894             \\ [\x00-\xFF] |
2895             [^<>] |
2896             \< (?{$nest++}) |
2897             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2898             }xms;
2899             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2900             (?: ::)? (?:
2901             [a-zA-Z_][a-zA-Z_0-9]*
2902             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2903             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2904             ))
2905             }xms;
2906             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2907             (?: ::)? (?:
2908             [0-9]+ |
2909             [^a-zA-Z_0-9\[\]] |
2910             ^[A-Z] |
2911             [a-zA-Z_][a-zA-Z_0-9]*
2912             (?: ::[a-zA-Z_][a-zA-Z_0-9]* )* (?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*
2913             (?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*
2914             ))
2915             }xms;
2916             my $qq_substr = qr{(?: Char::Windows1258::substr | CORE::substr | substr ) \( $qq_paren \)
2917             }xms;
2918              
2919             # regexp of nested parens in qXX
2920             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2921             [^()] |
2922             \( (?{$nest++}) |
2923             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2924             }xms;
2925             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2926             [^{}] |
2927             \{ (?{$nest++}) |
2928             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2929             }xms;
2930             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2931             [^[\]] |
2932             \[ (?{$nest++}) |
2933             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2934             }xms;
2935             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2936             [^<>] |
2937             \< (?{$nest++}) |
2938             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!))
2939             }xms;
2940              
2941             my $matched = '';
2942             my $s_matched = '';
2943              
2944             my $tr_variable = ''; # variable of tr///
2945             my $sub_variable = ''; # variable of s///
2946             my $bind_operator = ''; # =~ or !~
2947              
2948             my @heredoc = (); # here document
2949             my @heredoc_delimiter = ();
2950             my $here_script = ''; # here script
2951              
2952             #
2953             # escape Windows-1258 script
2954             #
2955             sub Char::Windows1258::escape(;$) {
2956 0 0   0 0   local($_) = $_[0] if @_;
2957              
2958             # P.359 The Study Function
2959             # in Chapter 7: Perl
2960             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2961              
2962 0           study $_; # Yes, I studied study yesterday.
2963              
2964             # while all script
2965              
2966             # 6.14. Matching from Where the Last Pattern Left Off
2967             # in Chapter 6. Pattern Matching
2968             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2969             # (and so on)
2970              
2971             # one member of Tag-team
2972             #
2973             # P.128 Start of match (or end of previous match): \G
2974             # P.130 Advanced Use of \G with Perl
2975             # in Chapter 3: Overview of Regular Expression Features and Flavors
2976             # P.255 Use leading anchors
2977             # P.256 Expose ^ and \G at the front expressions
2978             # in Chapter 6: Crafting an Efficient Expression
2979             # P.315 "Tag-team" matching with /gc
2980             # in Chapter 7: Perl
2981             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2982              
2983 0           my $e_script = '';
2984 0           while (not /\G \z/oxgc) { # member
2985 0           $e_script .= Char::Windows1258::escape_token();
2986             }
2987              
2988 0           return $e_script;
2989             }
2990              
2991             #
2992             # escape Windows-1258 token of script
2993             #
2994             sub Char::Windows1258::escape_token {
2995              
2996             # \n output here document
2997              
2998 0     0 0   my $ignore_modules = join('|', qw(
2999             utf8
3000             bytes
3001             charnames
3002             I18N::Japanese
3003             I18N::Collate
3004             I18N::JExt
3005             File::DosGlob
3006             Wild
3007             Wildcard
3008             Japanese
3009             ));
3010              
3011             # another member of Tag-team
3012             #
3013             # P.315 "Tag-team" matching with /gc
3014             # in Chapter 7: Perl
3015             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
3016              
3017 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3018 0           my $heredoc = '';
3019 0 0         if (scalar(@heredoc_delimiter) >= 1) {
3020 0           $slash = 'm//';
3021              
3022 0           $heredoc = join '', @heredoc;
3023 0           @heredoc = ();
3024              
3025             # skip here document
3026 0           for my $heredoc_delimiter (@heredoc_delimiter) {
3027 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
3028             }
3029 0           @heredoc_delimiter = ();
3030              
3031 0           $here_script = '';
3032             }
3033 0           return "\n" . $heredoc;
3034             }
3035              
3036             # ignore space, comment
3037 0           elsif (/\G (\s+|\#.*) /oxgc) { return $1; }
3038              
3039             # if (, elsif (, unless (, while (, until (, given (, and when (
3040              
3041             # given, when
3042              
3043             # P.225 The given Statement
3044             # in Chapter 15: Smart Matching and given-when
3045             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3046              
3047             # P.133 The given Statement
3048             # in Chapter 4: Statements and Declarations
3049             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3050              
3051             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) \s* \( ) /oxgc) {
3052 0           $slash = 'm//';
3053 0           return $1;
3054             }
3055              
3056             # scalar variable ($scalar = ...) =~ tr///;
3057             # scalar variable ($scalar = ...) =~ s///;
3058              
3059             # state
3060              
3061             # P.68 Persistent, Private Variables
3062             # in Chapter 4: Subroutines
3063             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
3064              
3065             # P.160 Persistent Lexically Scoped Variables: state
3066             # in Chapter 4: Statements and Declarations
3067             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3068              
3069             # (and so on)
3070              
3071             elsif (/\G ( \( \s* (?: local \b | my \b | our \b | state \b )? \s* \$ $qq_scalar ) /oxgc) {
3072 0           my $e_string = e_string($1);
3073              
3074 0 0         if (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3075 0           $tr_variable = $e_string . e_string($1);
3076 0           $bind_operator = $2;
3077 0           $slash = 'm//';
3078 0           return '';
3079             }
3080             elsif (/\G ( \s* = $qq_paren \) ) ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3081 0           $sub_variable = $e_string . e_string($1);
3082 0           $bind_operator = $2;
3083 0           $slash = 'm//';
3084 0           return '';
3085             }
3086             else {
3087 0           $slash = 'div';
3088 0           return $e_string;
3089             }
3090             }
3091              
3092             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Ewindows1258::PREMATCH()
3093             elsif (/\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
3094 0           $slash = 'div';
3095 0           return q{Char::Ewindows1258::PREMATCH()};
3096             }
3097              
3098             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Ewindows1258::MATCH()
3099             elsif (/\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
3100 0           $slash = 'div';
3101 0           return q{Char::Ewindows1258::MATCH()};
3102             }
3103              
3104             # $', ${'} --> $', ${'}
3105             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3106 0           $slash = 'div';
3107 0           return $1;
3108             }
3109              
3110             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Ewindows1258::POSTMATCH()
3111             elsif (/\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
3112 0           $slash = 'div';
3113 0           return q{Char::Ewindows1258::POSTMATCH()};
3114             }
3115              
3116             # scalar variable $scalar =~ tr///;
3117             # scalar variable $scalar =~ s///;
3118             # substr() =~ tr///;
3119             # substr() =~ s///;
3120             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3121 0           my $scalar = e_string($1);
3122              
3123 0 0         if (/\G ( \s* (?: =~ | !~ ) \s* ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3124 0           $tr_variable = $scalar;
3125 0           $bind_operator = $1;
3126 0           $slash = 'm//';
3127 0           return '';
3128             }
3129             elsif (/\G ( \s* (?: =~ | !~ ) \s* ) (?= s \b ) /oxgc) {
3130 0           $sub_variable = $scalar;
3131 0           $bind_operator = $1;
3132 0           $slash = 'm//';
3133 0           return '';
3134             }
3135             else {
3136 0           $slash = 'div';
3137 0           return $scalar;
3138             }
3139             }
3140              
3141             # end of statement
3142             elsif (/\G ( [,;] ) /oxgc) {
3143 0           $slash = 'm//';
3144              
3145             # clear tr/// variable
3146 0           $tr_variable = '';
3147              
3148             # clear s/// variable
3149 0           $sub_variable = '';
3150              
3151 0           $bind_operator = '';
3152              
3153 0           return $1;
3154             }
3155              
3156             # bareword
3157             elsif (/\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
3158 0           return $1;
3159             }
3160              
3161             # $0 --> $0
3162             elsif (/\G ( \$ 0 ) /oxmsgc) {
3163 0           $slash = 'div';
3164 0           return $1;
3165             }
3166             elsif (/\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
3167 0           $slash = 'div';
3168 0           return $1;
3169             }
3170              
3171             # $$ --> $$
3172             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3173 0           $slash = 'div';
3174 0           return $1;
3175             }
3176              
3177             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3178             # $1, $2, $3 --> $1, $2, $3 otherwise
3179             elsif (/\G \$ ([1-9][0-9]*) /oxmsgc) {
3180 0           $slash = 'div';
3181 0           return e_capture($1);
3182             }
3183             elsif (/\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
3184 0           $slash = 'div';
3185 0           return e_capture($1);
3186             }
3187              
3188             # $$foo[ ... ] --> $ $foo->[ ... ]
3189             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
3190 0           $slash = 'div';
3191 0           return e_capture($1.'->'.$2);
3192             }
3193              
3194             # $$foo{ ... } --> $ $foo->{ ... }
3195             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
3196 0           $slash = 'div';
3197 0           return e_capture($1.'->'.$2);
3198             }
3199              
3200             # $$foo
3201             elsif (/\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
3202 0           $slash = 'div';
3203 0           return e_capture($1);
3204             }
3205              
3206             # ${ foo }
3207             elsif (/\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
3208 0           $slash = 'div';
3209 0           return '${' . $1 . '}';
3210             }
3211              
3212             # ${ ... }
3213             elsif (/\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
3214 0           $slash = 'div';
3215 0           return e_capture($1);
3216             }
3217              
3218             # variable or function
3219             # $ @ % & * $ #
3220             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) {
3221 0           $slash = 'div';
3222 0           return $1;
3223             }
3224             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3225             # $ @ # \ ' " / ? ( ) [ ] < >
3226             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3227 0           $slash = 'div';
3228 0           return $1;
3229             }
3230              
3231             # while ()
3232             elsif (/\G \b (while \s* \( \s* <[\$]?[A-Za-z_][A-Za-z_0-9]*> \s* \)) \b /oxgc) {
3233 0           return $1;
3234             }
3235              
3236             # while () --- glob
3237              
3238             # avoid "Error: Runtime exception" of perl version 5.005_03
3239              
3240             elsif (/\G \b while \s* \( \s* < ((?:[^>\0\a\e\f\n\r\t])+?) > \s* \) \b /oxgc) {
3241 0           return 'while ($_ = Char::Ewindows1258::glob("' . $1 . '"))';
3242             }
3243              
3244             # while (glob)
3245             elsif (/\G \b while \s* \( \s* glob \s* \) /oxgc) {
3246 0           return 'while ($_ = Char::Ewindows1258::glob_)';
3247             }
3248              
3249             # while (glob(WILDCARD))
3250             elsif (/\G \b while \s* \( \s* glob \b /oxgc) {
3251 0           return 'while ($_ = Char::Ewindows1258::glob';
3252             }
3253              
3254             # doit if, doit unless, doit while, doit until, doit for, doit when
3255 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3256              
3257             # subroutines of package Char::Ewindows1258
3258 0           elsif (/\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3259 0           elsif (/\G \b Char::Windows1258::eval (?= \s* \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3260 0           elsif (/\G \b Char::Windows1258::eval \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'eval Char::Windows1258::escape'; }
  0            
3261 0           elsif (/\G \b bytes::substr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3262 0           elsif (/\G \b chop \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::chop'; }
  0            
3263 0           elsif (/\G \b bytes::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3264 0           elsif (/\G \b Char::Windows1258::index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Windows1258::index'; }
  0            
3265 0           elsif (/\G \b index \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::index'; }
  0            
3266 0           elsif (/\G \b bytes::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3267 0           elsif (/\G \b Char::Windows1258::rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Windows1258::rindex'; }
  0            
3268 0           elsif (/\G \b rindex \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::rindex'; }
  0            
3269 0           elsif (/\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::lc'; }
  0            
3270 0           elsif (/\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::lcfirst'; }
  0            
3271 0           elsif (/\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::uc'; }
  0            
3272 0           elsif (/\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::ucfirst'; }
  0            
3273 0           elsif (/\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::fc'; }
  0            
3274              
3275             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3276 0           elsif (/\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3277 0           elsif (/\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3278 0           elsif (/\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3279 0           elsif (/\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3280 0           elsif (/\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3281 0           elsif (/\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3282 0           elsif (/\G -s \s+ qq \s* (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3283              
3284 0           elsif (/\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3285 0           elsif (/\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3286 0           elsif (/\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3287 0           elsif (/\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3288 0           elsif (/\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3289 0           elsif (/\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3290 0           elsif (/\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3291              
3292             elsif (/\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3293 0           { $slash = 'm//'; return "-s $1"; }
  0            
3294 0           elsif (/\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3295 0           elsif (/\G -s (?= \s+ [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3296 0           elsif (/\G -s \s+ (\w+) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3297              
3298 0           elsif (/\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3299 0           elsif (/\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3300 0           elsif (/\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::chr'; }
  0            
3301 0           elsif (/\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3302 0           elsif (/\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3303 0           elsif (/\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::glob'; }
  0            
3304 0           elsif (/\G \b lc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::lc_'; }
  0            
3305 0           elsif (/\G \b lcfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::lcfirst_'; }
  0            
3306 0           elsif (/\G \b uc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::uc_'; }
  0            
3307 0           elsif (/\G \b ucfirst \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::ucfirst_'; }
  0            
3308 0           elsif (/\G \b fc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::fc_'; }
  0            
3309 0           elsif (/\G -s \b (?! \s* => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3310              
3311 0           elsif (/\G \b bytes::length \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3312 0           elsif (/\G \b bytes::chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3313 0           elsif (/\G \b chr \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::chr_'; }
  0            
3314 0           elsif (/\G \b bytes::ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3315 0           elsif (/\G \b ord \b (?! \s* => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3316 0           elsif (/\G \b glob \b (?! \s* => ) /oxgc) { $slash = 'm//'; return 'Char::Ewindows1258::glob_'; }
  0            
3317 0           elsif (/\G \b reverse \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3318 0           elsif (/\G \b getc \b (?! \s* => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3319             # split
3320             elsif (/\G \b (split) \b (?! \s* => ) /oxgc) {
3321 0           $slash = 'm//';
3322              
3323 0           my $e = '';
3324 0           while (/\G ( \s+ | \( | \#.* ) /oxgc) {
3325 0           $e .= $1;
3326             }
3327              
3328             # end of split
3329 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Ewindows1258::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3330              
3331             # split scalar value
3332 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Char::Ewindows1258::split' . $e . e_string($1); }
3333              
3334             # split literal space
3335 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {qq$1 $2}; }
3336 0           elsif (/\G \b qq (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3337 0           elsif (/\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3338 0           elsif (/\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3339 0           elsif (/\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3340 0           elsif (/\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; }
3341 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {q$1 $2}; }
3342 0           elsif (/\G \b q (\s*) (\() [ ] (\)) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3343 0           elsif (/\G \b q (\s*) (\{) [ ] (\}) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3344 0           elsif (/\G \b q (\s*) (\[) [ ] (\]) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3345 0           elsif (/\G \b q (\s*) (\<) [ ] (\>) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3346 0           elsif (/\G \b q (\s*) (\S) [ ] (\2) /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; }
3347 0           elsif (/\G ' [ ] ' /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {' '}; }
3348 0           elsif (/\G " [ ] " /oxgc) { return 'Char::Ewindows1258::split' . $e . qq {" "}; }
3349              
3350             # split qq//
3351             elsif (/\G \b (qq) \b /oxgc) {
3352 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3353             else {
3354 0           while (not /\G \z/oxgc) {
3355 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3356 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3357 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3358 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3359 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3360 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3361 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3362             }
3363 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3364             }
3365             }
3366              
3367             # split qr//
3368             elsif (/\G \b (qr) \b /oxgc) {
3369 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3370             else {
3371 0           while (not /\G \z/oxgc) {
3372 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3373 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3374 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3375 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3376 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3377 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3378 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3379 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3380             }
3381 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3382             }
3383             }
3384              
3385             # split q//
3386             elsif (/\G \b (q) \b /oxgc) {
3387 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3388             else {
3389 0           while (not /\G \z/oxgc) {
3390 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3391 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3392 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3393 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3394 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3395 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3396 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3397             }
3398 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3399             }
3400             }
3401              
3402             # split m//
3403             elsif (/\G \b (m) \b /oxgc) {
3404 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3405             else {
3406 0           while (not /\G \z/oxgc) {
3407 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3408 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3409 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3410 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3411 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3412 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3413 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3414 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3415             }
3416 0           die __FILE__, ": Search pattern not terminated";
3417             }
3418             }
3419              
3420             # split ''
3421             elsif (/\G (\') /oxgc) {
3422 0           my $q_string = '';
3423 0           while (not /\G \z/oxgc) {
3424 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3425 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3426 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3427 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3428             }
3429 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3430             }
3431              
3432             # split ""
3433             elsif (/\G (\") /oxgc) {
3434 0           my $qq_string = '';
3435 0           while (not /\G \z/oxgc) {
3436 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3437 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3438 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3439 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3440             }
3441 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3442             }
3443              
3444             # split //
3445             elsif (/\G (\/) /oxgc) {
3446 0           my $regexp = '';
3447 0           while (not /\G \z/oxgc) {
3448 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3449 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3450 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3451 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3452             }
3453 0           die __FILE__, ": Search pattern not terminated";
3454             }
3455             }
3456              
3457             # tr/// or y///
3458              
3459             # about [cdsrbB]* (/B modifier)
3460             #
3461             # P.559 appendix C
3462             # of ISBN 4-89052-384-7 Programming perl
3463             # (Japanese title is: Perl puroguramingu)
3464              
3465             elsif (/\G \b ( tr | y ) \b /oxgc) {
3466 0           my $ope = $1;
3467              
3468             # $1 $2 $3 $4 $5 $6
3469 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3470 0           my @tr = ($tr_variable,$2);
3471 0           return e_tr(@tr,'',$4,$6);
3472             }
3473             else {
3474 0           my $e = '';
3475 0           while (not /\G \z/oxgc) {
3476 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3477             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3478 0           my @tr = ($tr_variable,$2);
3479 0           while (not /\G \z/oxgc) {
3480 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3481 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3482 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3483 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3484 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3485 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3486             }
3487 0           die __FILE__, ": Transliteration replacement not terminated";
3488             }
3489             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3490 0           my @tr = ($tr_variable,$2);
3491 0           while (not /\G \z/oxgc) {
3492 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3493 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3494 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3495 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3496 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3497 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3498             }
3499 0           die __FILE__, ": Transliteration replacement not terminated";
3500             }
3501             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3502 0           my @tr = ($tr_variable,$2);
3503 0           while (not /\G \z/oxgc) {
3504 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3505 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3506 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3507 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3508 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3509 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3510             }
3511 0           die __FILE__, ": Transliteration replacement not terminated";
3512             }
3513             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3514 0           my @tr = ($tr_variable,$2);
3515 0           while (not /\G \z/oxgc) {
3516 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3517 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3518 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3519 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3520 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3521 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3522             }
3523 0           die __FILE__, ": Transliteration replacement not terminated";
3524             }
3525             # $1 $2 $3 $4 $5 $6
3526             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3527 0           my @tr = ($tr_variable,$2);
3528 0           return e_tr(@tr,'',$4,$6);
3529             }
3530             }
3531 0           die __FILE__, ": Transliteration pattern not terminated";
3532             }
3533             }
3534              
3535             # qq//
3536             elsif (/\G \b (qq) \b /oxgc) {
3537 0           my $ope = $1;
3538              
3539             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3540 0 0         if (/\G (\#) /oxgc) { # qq# #
3541 0           my $qq_string = '';
3542 0           while (not /\G \z/oxgc) {
3543 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3544 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3545 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3546 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3547             }
3548 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3549             }
3550              
3551             else {
3552 0           my $e = '';
3553 0           while (not /\G \z/oxgc) {
3554 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3555              
3556             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3557             elsif (/\G (\() /oxgc) { # qq ( )
3558 0           my $qq_string = '';
3559 0           local $nest = 1;
3560 0           while (not /\G \z/oxgc) {
3561 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3562 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3563 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3564             elsif (/\G (\)) /oxgc) {
3565 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3566 0           else { $qq_string .= $1; }
3567             }
3568 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3569             }
3570 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3571             }
3572              
3573             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3574             elsif (/\G (\{) /oxgc) { # qq { }
3575 0           my $qq_string = '';
3576 0           local $nest = 1;
3577 0           while (not /\G \z/oxgc) {
3578 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3579 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3580 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3581             elsif (/\G (\}) /oxgc) {
3582 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3583 0           else { $qq_string .= $1; }
3584             }
3585 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3586             }
3587 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3588             }
3589              
3590             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3591             elsif (/\G (\[) /oxgc) { # qq [ ]
3592 0           my $qq_string = '';
3593 0           local $nest = 1;
3594 0           while (not /\G \z/oxgc) {
3595 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3596 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3597 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3598             elsif (/\G (\]) /oxgc) {
3599 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3600 0           else { $qq_string .= $1; }
3601             }
3602 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3603             }
3604 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3605             }
3606              
3607             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3608             elsif (/\G (\<) /oxgc) { # qq < >
3609 0           my $qq_string = '';
3610 0           local $nest = 1;
3611 0           while (not /\G \z/oxgc) {
3612 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3613 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3614 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3615             elsif (/\G (\>) /oxgc) {
3616 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3617 0           else { $qq_string .= $1; }
3618             }
3619 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3620             }
3621 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3622             }
3623              
3624             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3625             elsif (/\G (\S) /oxgc) { # qq * *
3626 0           my $delimiter = $1;
3627 0           my $qq_string = '';
3628 0           while (not /\G \z/oxgc) {
3629 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3630 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3631 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3632 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3633             }
3634 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3635             }
3636             }
3637 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3638             }
3639             }
3640              
3641             # qr//
3642             elsif (/\G \b (qr) \b /oxgc) {
3643 0           my $ope = $1;
3644 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { # qr# # #
3645 0           return e_qr($ope,$1,$3,$2,$4);
3646             }
3647             else {
3648 0           my $e = '';
3649 0           while (not /\G \z/oxgc) {
3650 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3651 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3652 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3653 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3654 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3655 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3656 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3657 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3658             }
3659 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3660             }
3661             }
3662              
3663             # qw//
3664             elsif (/\G \b (qw) \b /oxgc) {
3665 0           my $ope = $1;
3666 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3667 0           return e_qw($ope,$1,$3,$2);
3668             }
3669             else {
3670 0           my $e = '';
3671 0           while (not /\G \z/oxgc) {
3672 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3673              
3674 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3675 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3676              
3677 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3678 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3679              
3680 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3681 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3682              
3683 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3684 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3685              
3686 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3687 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3688             }
3689 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3690             }
3691             }
3692              
3693             # qx//
3694             elsif (/\G \b (qx) \b /oxgc) {
3695 0           my $ope = $1;
3696 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3697 0           return e_qq($ope,$1,$3,$2);
3698             }
3699             else {
3700 0           my $e = '';
3701 0           while (not /\G \z/oxgc) {
3702 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3703 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3704 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3705 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3706 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3707 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3708 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3709             }
3710 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3711             }
3712             }
3713              
3714             # q//
3715             elsif (/\G \b (q) \b /oxgc) {
3716 0           my $ope = $1;
3717              
3718             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3719              
3720             # avoid "Error: Runtime exception" of perl version 5.005_03
3721             # (and so on)
3722              
3723 0 0         if (/\G (\#) /oxgc) { # q# #
3724 0           my $q_string = '';
3725 0           while (not /\G \z/oxgc) {
3726 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3727 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3728 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3729 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3730             }
3731 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3732             }
3733              
3734             else {
3735 0           my $e = '';
3736 0           while (not /\G \z/oxgc) {
3737 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3738              
3739             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3740             elsif (/\G (\() /oxgc) { # q ( )
3741 0           my $q_string = '';
3742 0           local $nest = 1;
3743 0           while (not /\G \z/oxgc) {
3744 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3745 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3746 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3747 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3748             elsif (/\G (\)) /oxgc) {
3749 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3750 0           else { $q_string .= $1; }
3751             }
3752 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3753             }
3754 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3755             }
3756              
3757             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3758             elsif (/\G (\{) /oxgc) { # q { }
3759 0           my $q_string = '';
3760 0           local $nest = 1;
3761 0           while (not /\G \z/oxgc) {
3762 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3763 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3764 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3765 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3766             elsif (/\G (\}) /oxgc) {
3767 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3768 0           else { $q_string .= $1; }
3769             }
3770 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3771             }
3772 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3773             }
3774              
3775             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3776             elsif (/\G (\[) /oxgc) { # q [ ]
3777 0           my $q_string = '';
3778 0           local $nest = 1;
3779 0           while (not /\G \z/oxgc) {
3780 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3781 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3782 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3783 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3784             elsif (/\G (\]) /oxgc) {
3785 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3786 0           else { $q_string .= $1; }
3787             }
3788 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3789             }
3790 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3791             }
3792              
3793             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3794             elsif (/\G (\<) /oxgc) { # q < >
3795 0           my $q_string = '';
3796 0           local $nest = 1;
3797 0           while (not /\G \z/oxgc) {
3798 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3799 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3800 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3801 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3802             elsif (/\G (\>) /oxgc) {
3803 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3804 0           else { $q_string .= $1; }
3805             }
3806 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3807             }
3808 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3809             }
3810              
3811             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3812             elsif (/\G (\S) /oxgc) { # q * *
3813 0           my $delimiter = $1;
3814 0           my $q_string = '';
3815 0           while (not /\G \z/oxgc) {
3816 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3817 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3818 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3819 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3820             }
3821 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3822             }
3823             }
3824 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
3825             }
3826             }
3827              
3828             # m//
3829             elsif (/\G \b (m) \b /oxgc) {
3830 0           my $ope = $1;
3831 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { # m# #
3832 0           return e_qr($ope,$1,$3,$2,$4);
3833             }
3834             else {
3835 0           my $e = '';
3836 0           while (not /\G \z/oxgc) {
3837 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3838 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3839 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3840 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3841 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3842 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3843 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3844 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3845 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3846             }
3847 0           die __FILE__, ": Search pattern not terminated";
3848             }
3849             }
3850              
3851             # s///
3852              
3853             # about [cegimosxpradlubB]* (/cg modifier)
3854             #
3855             # P.67 Pattern-Matching Operators
3856             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3857              
3858             elsif (/\G \b (s) \b /oxgc) {
3859 0           my $ope = $1;
3860              
3861             # $1 $2 $3 $4 $5 $6
3862 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlubB]*) /oxgc) { # s# # #
3863 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3864             }
3865             else {
3866 0           my $e = '';
3867 0           while (not /\G \z/oxgc) {
3868 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3869             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3870 0           my @s = ($1,$2,$3);
3871 0           while (not /\G \z/oxgc) {
3872 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3873             # $1 $2 $3 $4
3874 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3875 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3876 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3877 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3878 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3879 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3880 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3881 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3882 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3883             }
3884 0           die __FILE__, ": Substitution replacement not terminated";
3885             }
3886             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3887 0           my @s = ($1,$2,$3);
3888 0           while (not /\G \z/oxgc) {
3889 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3890             # $1 $2 $3 $4
3891 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3892 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3893 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3894 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3895 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3896 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3897 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3898 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3899 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3900             }
3901 0           die __FILE__, ": Substitution replacement not terminated";
3902             }
3903             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3904 0           my @s = ($1,$2,$3);
3905 0           while (not /\G \z/oxgc) {
3906 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3907             # $1 $2 $3 $4
3908 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3909 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3910 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3911 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3912 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3913 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3914 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3915             }
3916 0           die __FILE__, ": Substitution replacement not terminated";
3917             }
3918             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3919 0           my @s = ($1,$2,$3);
3920 0           while (not /\G \z/oxgc) {
3921 0 0         if (/\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3922             # $1 $2 $3 $4
3923 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3924 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3925 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3926 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3927 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3928 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3929 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3930 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3931 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3932             }
3933 0           die __FILE__, ": Substitution replacement not terminated";
3934             }
3935             # $1 $2 $3 $4 $5 $6
3936             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlubB]*) /oxgc) {
3937 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3938             }
3939             # $1 $2 $3 $4 $5 $6
3940             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3941 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3942             }
3943             # $1 $2 $3 $4 $5 $6
3944             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3945 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3946             }
3947             # $1 $2 $3 $4 $5 $6
3948             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlubB]*) /oxgc) {
3949 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3950             }
3951             }
3952 0           die __FILE__, ": Substitution pattern not terminated";
3953             }
3954             }
3955              
3956             # require ignore module
3957 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3958 0           elsif (/\G \b require (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3959 0           elsif (/\G \b require (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3960              
3961             # use strict; --> use strict; no strict qw(refs);
3962 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3963 0           elsif (/\G \b use (\s+ strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3964 0           elsif (/\G \b use (\s+ strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3965              
3966             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
3967             elsif (/\G \b use \s+ (([1-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3968 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
3969 0           return "use $1; no strict qw(refs);";
3970             }
3971             else {
3972 0           return "use $1;";
3973             }
3974             }
3975             elsif (/\G \b use \s+ (v([0-9][0-9_]*)(?:\.([0-9_]+))*) \s* ; /oxmsgc) {
3976 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
3977 0           return "use $1; no strict qw(refs);";
3978             }
3979             else {
3980 0           return "use $1;";
3981             }
3982             }
3983              
3984             # ignore use module
3985 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3986 0           elsif (/\G \b use (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3987 0           elsif (/\G \b use (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3988              
3989             # ignore no module
3990 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3991 0           elsif (/\G \b no (\s+ (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3992 0           elsif (/\G \b no (\s+ (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3993              
3994             # use else
3995 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
3996              
3997             # use else
3998 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
3999              
4000             # ''
4001             elsif (/\G (?
4002 0           my $q_string = '';
4003 0           while (not /\G \z/oxgc) {
4004 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4005 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
4006 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
4007 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
4008             }
4009 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4010             }
4011              
4012             # ""
4013             elsif (/\G (\") /oxgc) {
4014 0           my $qq_string = '';
4015 0           while (not /\G \z/oxgc) {
4016 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4017 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
4018 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
4019 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
4020             }
4021 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4022             }
4023              
4024             # ``
4025             elsif (/\G (\`) /oxgc) {
4026 0           my $qx_string = '';
4027 0           while (not /\G \z/oxgc) {
4028 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
4029 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
4030 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
4031 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
4032             }
4033 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4034             }
4035              
4036             # // --- not divide operator (num / num), not defined-or
4037             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
4038 0           my $regexp = '';
4039 0           while (not /\G \z/oxgc) {
4040 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4041 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
4042 0           elsif (/\G \/ ([cgimosxpadlubB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
4043 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4044             }
4045 0           die __FILE__, ": Search pattern not terminated";
4046             }
4047              
4048             # ?? --- not conditional operator (condition ? then : else)
4049             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
4050 0           my $regexp = '';
4051 0           while (not /\G \z/oxgc) {
4052 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4053 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
4054 0           elsif (/\G \? ([cgimosxpadlubB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
4055 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
4056             }
4057 0           die __FILE__, ": Search pattern not terminated";
4058             }
4059              
4060             # << (bit shift) --- not here document
4061 0           elsif (/\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4062              
4063             # <<'HEREDOC'
4064             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4065 0           $slash = 'm//';
4066 0           my $here_quote = $1;
4067 0           my $delimiter = $2;
4068              
4069             # get here document
4070 0 0         if ($here_script eq '') {
4071 0           $here_script = CORE::substr $_, pos $_;
4072 0           $here_script =~ s/.*?\n//oxm;
4073             }
4074 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4075 0           push @heredoc, $1 . qq{\n$delimiter\n};
4076 0           push @heredoc_delimiter, $delimiter;
4077             }
4078             else {
4079 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4080             }
4081 0           return $here_quote;
4082             }
4083              
4084             # <<\HEREDOC
4085              
4086             # P.66 2.6.6. "Here" Documents
4087             # in Chapter 2: Bits and Pieces
4088             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4089              
4090             # P.73 "Here" Documents
4091             # in Chapter 2: Bits and Pieces
4092             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4093              
4094             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4095 0           $slash = 'm//';
4096 0           my $here_quote = $1;
4097 0           my $delimiter = $2;
4098              
4099             # get here document
4100 0 0         if ($here_script eq '') {
4101 0           $here_script = CORE::substr $_, pos $_;
4102 0           $here_script =~ s/.*?\n//oxm;
4103             }
4104 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4105 0           push @heredoc, $1 . qq{\n$delimiter\n};
4106 0           push @heredoc_delimiter, $delimiter;
4107             }
4108             else {
4109 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4110             }
4111 0           return $here_quote;
4112             }
4113              
4114             # <<"HEREDOC"
4115             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4116 0           $slash = 'm//';
4117 0           my $here_quote = $1;
4118 0           my $delimiter = $2;
4119              
4120             # get here document
4121 0 0         if ($here_script eq '') {
4122 0           $here_script = CORE::substr $_, pos $_;
4123 0           $here_script =~ s/.*?\n//oxm;
4124             }
4125 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4126 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4127 0           push @heredoc_delimiter, $delimiter;
4128             }
4129             else {
4130 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4131             }
4132 0           return $here_quote;
4133             }
4134              
4135             # <
4136             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4137 0           $slash = 'm//';
4138 0           my $here_quote = $1;
4139 0           my $delimiter = $2;
4140              
4141             # get here document
4142 0 0         if ($here_script eq '') {
4143 0           $here_script = CORE::substr $_, pos $_;
4144 0           $here_script =~ s/.*?\n//oxm;
4145             }
4146 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4147 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4148 0           push @heredoc_delimiter, $delimiter;
4149             }
4150             else {
4151 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4152             }
4153 0           return $here_quote;
4154             }
4155              
4156             # <<`HEREDOC`
4157             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4158 0           $slash = 'm//';
4159 0           my $here_quote = $1;
4160 0           my $delimiter = $2;
4161              
4162             # get here document
4163 0 0         if ($here_script eq '') {
4164 0           $here_script = CORE::substr $_, pos $_;
4165 0           $here_script =~ s/.*?\n//oxm;
4166             }
4167 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4168 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4169 0           push @heredoc_delimiter, $delimiter;
4170             }
4171             else {
4172 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4173             }
4174 0           return $here_quote;
4175             }
4176              
4177             # <<= <=> <= < operator
4178             elsif (/\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4179 0           return $1;
4180             }
4181              
4182             #
4183             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4184 0           return $1;
4185             }
4186              
4187             # --- glob
4188              
4189             # avoid "Error: Runtime exception" of perl version 5.005_03
4190              
4191             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4192 0           return 'Char::Ewindows1258::glob("' . $1 . '")';
4193             }
4194              
4195             # __DATA__
4196 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4197              
4198             # __END__
4199 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4200              
4201             # \cD Control-D
4202              
4203             # P.68 2.6.8. Other Literal Tokens
4204             # in Chapter 2: Bits and Pieces
4205             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4206              
4207             # P.76 Other Literal Tokens
4208             # in Chapter 2: Bits and Pieces
4209             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4210              
4211 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4212              
4213             # \cZ Control-Z
4214 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4215              
4216             # any operator before div
4217             elsif (/\G (
4218             -- | \+\+ |
4219             [\)\}\]]
4220              
4221 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4222              
4223             # yada-yada or triple-dot operator
4224             elsif (/\G (
4225             \.\.\.
4226              
4227 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4228              
4229             # any operator before m//
4230              
4231             # //, //= (defined-or)
4232              
4233             # P.164 Logical Operators
4234             # in Chapter 10: More Control Structures
4235             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4236              
4237             # P.119 C-Style Logical (Short-Circuit) Operators
4238             # in Chapter 3: Unary and Binary Operators
4239             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4240              
4241             # (and so on)
4242              
4243             # ~~
4244              
4245             # P.221 The Smart Match Operator
4246             # in Chapter 15: Smart Matching and given-when
4247             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4248              
4249             # P.112 Smartmatch Operator
4250             # in Chapter 3: Unary and Binary Operators
4251             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4252              
4253             # (and so on)
4254              
4255             elsif (/\G (
4256              
4257             !~~ | !~ | != | ! |
4258             %= | % |
4259             &&= | && | &= | & |
4260             -= | -> | - |
4261             :\s*= |
4262             : |
4263             <<= | <=> | <= | < |
4264             == | => | =~ | = |
4265             >>= | >> | >= | > |
4266             \*\*= | \*\* | \*= | \* |
4267             \+= | \+ |
4268             \.\. | \.= | \. |
4269             \/\/= | \/\/ |
4270             \/= | \/ |
4271             \? |
4272             \\ |
4273             \^= | \^ |
4274             \b x= |
4275             \|\|= | \|\| | \|= | \| |
4276             ~~ | ~ |
4277             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4278             \b(?: print )\b |
4279              
4280             [,;\(\{\[]
4281              
4282 0           ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4283              
4284             # other any character
4285 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4286              
4287             # system error
4288             else {
4289 0           die __FILE__, ": Oops, this shouldn't happen!";
4290             }
4291             }
4292              
4293             # escape Windows-1258 string
4294             sub e_string {
4295 0     0 0   my($string) = @_;
4296 0           my $e_string = '';
4297              
4298 0           local $slash = 'm//';
4299              
4300             # P.1024 Appendix W.10 Multibyte Processing
4301             # of ISBN 1-56592-224-7 CJKV Information Processing
4302             # (and so on)
4303              
4304 0           my @char = $string =~ / \G (\\?(?:$q_char)) /oxmsg;
4305              
4306             # without { ... }
4307 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4308 0 0         if ($string !~ /<
4309 0           return $string;
4310             }
4311             }
4312              
4313             E_STRING_LOOP:
4314 0           while ($string !~ /\G \z/oxgc) {
4315 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4316             }
4317              
4318             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Char::Ewindows1258::PREMATCH()]}
4319 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ \s* PREMATCH \b | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) /oxmsgc) {
4320 0           $e_string .= q{Char::Ewindows1258::PREMATCH()};
4321 0           $slash = 'div';
4322             }
4323              
4324             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Char::Ewindows1258::MATCH()]}
4325             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ \s* MATCH \b | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) /oxmsgc) {
4326 0           $e_string .= q{Char::Ewindows1258::MATCH()};
4327 0           $slash = 'div';
4328             }
4329              
4330             # $', ${'} --> $', ${'}
4331             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4332 0           $e_string .= $1;
4333 0           $slash = 'div';
4334             }
4335              
4336             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Char::Ewindows1258::POSTMATCH()]}
4337             elsif ($string =~ /\G ( \$ \s* POSTMATCH \b | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) /oxmsgc) {
4338 0           $e_string .= q{Char::Ewindows1258::POSTMATCH()};
4339 0           $slash = 'div';
4340             }
4341              
4342             # bareword
4343             elsif ($string =~ /\G ( \{ \s* (?: tr | index | rindex | reverse ) \s* \} ) /oxmsgc) {
4344 0           $e_string .= $1;
4345 0           $slash = 'div';
4346             }
4347              
4348             # $0 --> $0
4349             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4350 0           $e_string .= $1;
4351 0           $slash = 'div';
4352             }
4353             elsif ($string =~ /\G ( \$ \{ \s* 0 \s* \} ) /oxmsgc) {
4354 0           $e_string .= $1;
4355 0           $slash = 'div';
4356             }
4357              
4358             # $$ --> $$
4359             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4360 0           $e_string .= $1;
4361 0           $slash = 'div';
4362             }
4363              
4364             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4365             # $1, $2, $3 --> $1, $2, $3 otherwise
4366             elsif ($string =~ /\G \$ ([1-9][0-9]*) /oxmsgc) {
4367 0           $e_string .= e_capture($1);
4368 0           $slash = 'div';
4369             }
4370             elsif ($string =~ /\G \$ \{ \s* ([1-9][0-9]*) \s* \} /oxmsgc) {
4371 0           $e_string .= e_capture($1);
4372 0           $slash = 'div';
4373             }
4374              
4375             # $$foo[ ... ] --> $ $foo->[ ... ]
4376             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ .+? \] ) /oxmsgc) {
4377 0           $e_string .= e_capture($1.'->'.$2);
4378 0           $slash = 'div';
4379             }
4380              
4381             # $$foo{ ... } --> $ $foo->{ ... }
4382             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ .+? \} ) /oxmsgc) {
4383 0           $e_string .= e_capture($1.'->'.$2);
4384 0           $slash = 'div';
4385             }
4386              
4387             # $$foo
4388             elsif ($string =~ /\G \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) /oxmsgc) {
4389 0           $e_string .= e_capture($1);
4390 0           $slash = 'div';
4391             }
4392              
4393             # ${ foo }
4394             elsif ($string =~ /\G \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} /oxmsgc) {
4395 0           $e_string .= '${' . $1 . '}';
4396 0           $slash = 'div';
4397             }
4398              
4399             # ${ ... }
4400             elsif ($string =~ /\G \$ \s* \{ \s* ( $qq_brace ) \s* \} /oxmsgc) {
4401 0           $e_string .= e_capture($1);
4402 0           $slash = 'div';
4403             }
4404              
4405             # variable or function
4406             # $ @ % & * $ #
4407             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) {
4408 0           $e_string .= $1;
4409 0           $slash = 'div';
4410             }
4411             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4412             # $ @ # \ ' " / ? ( ) [ ] < >
4413             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4414 0           $e_string .= $1;
4415 0           $slash = 'div';
4416             }
4417              
4418             # subroutines of package Char::Ewindows1258
4419 0           elsif ($string =~ /\G \b (CORE:: | ->[ ]* (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4420 0           elsif ($string =~ /\G \b Char::Windows1258::eval (?= \s* \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4421 0           elsif ($string =~ /\G \b Char::Windows1258::eval \b /oxgc) { $e_string .= 'eval Char::Windows1258::escape'; $slash = 'm//'; }
  0            
4422 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4423 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Char::Ewindows1258::chop'; $slash = 'm//'; }
  0            
4424 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4425 0           elsif ($string =~ /\G \b Char::Windows1258::index \b /oxgc) { $e_string .= 'Char::Windows1258::index'; $slash = 'm//'; }
  0            
4426 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Char::Ewindows1258::index'; $slash = 'm//'; }
  0            
4427 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4428 0           elsif ($string =~ /\G \b Char::Windows1258::rindex \b /oxgc) { $e_string .= 'Char::Windows1258::rindex'; $slash = 'm//'; }
  0            
4429 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Char::Ewindows1258::rindex'; $slash = 'm//'; }
  0            
4430 0           elsif ($string =~ /\G \b lc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::lc'; $slash = 'm//'; }
  0            
4431 0           elsif ($string =~ /\G \b lcfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::lcfirst'; $slash = 'm//'; }
  0            
4432 0           elsif ($string =~ /\G \b uc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::uc'; $slash = 'm//'; }
  0            
4433 0           elsif ($string =~ /\G \b ucfirst (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::ucfirst'; $slash = 'm//'; }
  0            
4434 0           elsif ($string =~ /\G \b fc (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::fc'; $slash = 'm//'; }
  0            
4435              
4436             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4437 0           elsif ($string =~ /\G -s \s+ \s* (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4438 0           elsif ($string =~ /\G -s \s+ qq \s* (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4439 0           elsif ($string =~ /\G -s \s+ qq \s* (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4440 0           elsif ($string =~ /\G -s \s+ qq \s* (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4441 0           elsif ($string =~ /\G -s \s+ qq \s* (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4442 0           elsif ($string =~ /\G -s \s+ qq \s* (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4443 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            
4444              
4445 0           elsif ($string =~ /\G -s \s+ \s* (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4446 0           elsif ($string =~ /\G -s \s+ q \s* (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4447 0           elsif ($string =~ /\G -s \s+ q \s* (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4448 0           elsif ($string =~ /\G -s \s+ q \s* (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4449 0           elsif ($string =~ /\G -s \s+ q \s* (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4450 0           elsif ($string =~ /\G -s \s+ q \s* (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4451 0           elsif ($string =~ /\G -s \s+ q \s* (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4452              
4453             elsif ($string =~ /\G -s \s* (\$ \w+(?: ::\w+)* (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
4454 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4455 0           elsif ($string =~ /\G -s \s* \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4456 0           elsif ($string =~ /\G -s (?= \s+ [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4457 0           elsif ($string =~ /\G -s \s+ (\w+) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4458              
4459 0           elsif ($string =~ /\G \b bytes::length (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4460 0           elsif ($string =~ /\G \b bytes::chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4461 0           elsif ($string =~ /\G \b chr (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::chr'; $slash = 'm//'; }
  0            
4462 0           elsif ($string =~ /\G \b bytes::ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4463 0           elsif ($string =~ /\G \b ord (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4464 0           elsif ($string =~ /\G \b glob (?= \s+[A-Za-z_]|\s*['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Char::Ewindows1258::glob'; $slash = 'm//'; }
  0            
4465 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Char::Ewindows1258::lc_'; $slash = 'm//'; }
  0            
4466 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Char::Ewindows1258::lcfirst_'; $slash = 'm//'; }
  0            
4467 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Char::Ewindows1258::uc_'; $slash = 'm//'; }
  0            
4468 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Char::Ewindows1258::ucfirst_'; $slash = 'm//'; }
  0            
4469 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Char::Ewindows1258::fc_'; $slash = 'm//'; }
  0            
4470 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4471              
4472 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4473 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4474 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Char::Ewindows1258::chr_'; $slash = 'm//'; }
  0            
4475 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4476 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4477 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Char::Ewindows1258::glob_'; $slash = 'm//'; }
  0            
4478 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4479 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4480             # split
4481             elsif ($string =~ /\G \b (split) \b (?! \s* => ) /oxgc) {
4482 0           $slash = 'm//';
4483              
4484 0           my $e = '';
4485 0           while ($string =~ /\G ( \s+ | \( | \#.* ) /oxgc) {
4486 0           $e .= $1;
4487             }
4488              
4489             # end of split
4490 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Char::Ewindows1258::split' . $e; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4491              
4492             # split scalar value
4493 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4494              
4495             # split literal space
4496 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4497 0           elsif ($string =~ /\G \b qq (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4498 0           elsif ($string =~ /\G \b qq (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4499 0           elsif ($string =~ /\G \b qq (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4500 0           elsif ($string =~ /\G \b qq (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4501 0           elsif ($string =~ /\G \b qq (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4502 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4503 0           elsif ($string =~ /\G \b q (\s*) (\() [ ] (\)) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4504 0           elsif ($string =~ /\G \b q (\s*) (\{) [ ] (\}) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4505 0           elsif ($string =~ /\G \b q (\s*) (\[) [ ] (\]) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4506 0           elsif ($string =~ /\G \b q (\s*) (\<) [ ] (\>) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4507 0           elsif ($string =~ /\G \b q (\s*) (\S) [ ] (\2) /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4508 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4509 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Char::Ewindows1258::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4510              
4511             # split qq//
4512             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4513 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0            
  0            
4514             else {
4515 0           while ($string !~ /\G \z/oxgc) {
4516 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4517 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4518 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4519 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4520 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4521 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4522 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0            
4523             }
4524 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4525             }
4526             }
4527              
4528             # split qr//
4529             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4530 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4531             else {
4532 0           while ($string !~ /\G \z/oxgc) {
4533 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4534 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4535 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4536 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4537 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4538 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlubB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0            
4539 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4540 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0            
4541             }
4542 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4543             }
4544             }
4545              
4546             # split q//
4547             elsif ($string =~ /\G \b (q) \b /oxgc) {
4548 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0            
  0            
4549             else {
4550 0           while ($string !~ /\G \z/oxgc) {
4551 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4552 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4553 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4554 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4555 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4556 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4557 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0            
4558             }
4559 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4560             }
4561             }
4562              
4563             # split m//
4564             elsif ($string =~ /\G \b (m) \b /oxgc) {
4565 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0            
  0            
4566             else {
4567 0           while ($string !~ /\G \z/oxgc) {
4568 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4569 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0            
4570 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0            
4571 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0            
4572 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0            
4573 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0            
4574 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4575 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0            
4576             }
4577 0           die __FILE__, ": Search pattern not terminated";
4578             }
4579             }
4580              
4581             # split ''
4582             elsif ($string =~ /\G (\') /oxgc) {
4583 0           my $q_string = '';
4584 0           while ($string !~ /\G \z/oxgc) {
4585 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4586 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4587 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4588 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4589             }
4590 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4591             }
4592              
4593             # split ""
4594             elsif ($string =~ /\G (\") /oxgc) {
4595 0           my $qq_string = '';
4596 0           while ($string !~ /\G \z/oxgc) {
4597 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4598 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4599 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4600 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4601             }
4602 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4603             }
4604              
4605             # split //
4606             elsif ($string =~ /\G (\/) /oxgc) {
4607 0           my $regexp = '';
4608 0           while ($string !~ /\G \z/oxgc) {
4609 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4610 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4611 0           elsif ($string =~ /\G \/ ([cgimosxpadlubB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4612 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4613             }
4614 0           die __FILE__, ": Search pattern not terminated";
4615             }
4616             }
4617              
4618             # qq//
4619             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4620 0           my $ope = $1;
4621 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4622 0           $e_string .= e_qq($ope,$1,$3,$2);
4623             }
4624             else {
4625 0           my $e = '';
4626 0           while ($string !~ /\G \z/oxgc) {
4627 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4628 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4629 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4630 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4631 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4632 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4633             }
4634 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4635             }
4636             }
4637              
4638             # qx//
4639             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4640 0           my $ope = $1;
4641 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4642 0           $e_string .= e_qq($ope,$1,$3,$2);
4643             }
4644             else {
4645 0           my $e = '';
4646 0           while ($string !~ /\G \z/oxgc) {
4647 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4648 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4649 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4650 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4651 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4652 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4653 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4654             }
4655 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4656             }
4657             }
4658              
4659             # q//
4660             elsif ($string =~ /\G \b (q) \b /oxgc) {
4661 0           my $ope = $1;
4662 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4663 0           $e_string .= e_q($ope,$1,$3,$2);
4664             }
4665             else {
4666 0           my $e = '';
4667 0           while ($string !~ /\G \z/oxgc) {
4668 0 0         if ($string =~ /\G (\s+|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4669 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4670 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4671 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4672 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4673 0           elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0            
4674             }
4675 0           die __FILE__, ": Can't find string terminator anywhere before EOF";
4676             }
4677             }
4678              
4679             # ''
4680 0           elsif ($string =~ /\G (?
4681              
4682             # ""
4683 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4684              
4685             # ``
4686 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4687              
4688             # <<= <=> <= < operator
4689             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= \s* [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc)
4690 0           { $e_string .= $1; }
4691              
4692             #
4693 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4694              
4695             # --- glob
4696             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4697 0           $e_string .= 'Char::Ewindows1258::glob("' . $1 . '")';
4698             }
4699              
4700             # << (bit shift) --- not here document
4701 0           elsif ($string =~ /\G ( << \s* ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4702              
4703             # <<'HEREDOC'
4704             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4705 0           $slash = 'm//';
4706 0           my $here_quote = $1;
4707 0           my $delimiter = $2;
4708              
4709             # get here document
4710 0 0         if ($here_script eq '') {
4711 0           $here_script = CORE::substr $_, pos $_;
4712 0           $here_script =~ s/.*?\n//oxm;
4713             }
4714 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4715 0           push @heredoc, $1 . qq{\n$delimiter\n};
4716 0           push @heredoc_delimiter, $delimiter;
4717             }
4718             else {
4719 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4720             }
4721 0           $e_string .= $here_quote;
4722             }
4723              
4724             # <<\HEREDOC
4725             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4726 0           $slash = 'm//';
4727 0           my $here_quote = $1;
4728 0           my $delimiter = $2;
4729              
4730             # get here document
4731 0 0         if ($here_script eq '') {
4732 0           $here_script = CORE::substr $_, pos $_;
4733 0           $here_script =~ s/.*?\n//oxm;
4734             }
4735 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4736 0           push @heredoc, $1 . qq{\n$delimiter\n};
4737 0           push @heredoc_delimiter, $delimiter;
4738             }
4739             else {
4740 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4741             }
4742 0           $e_string .= $here_quote;
4743             }
4744              
4745             # <<"HEREDOC"
4746             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4747 0           $slash = 'm//';
4748 0           my $here_quote = $1;
4749 0           my $delimiter = $2;
4750              
4751             # get here document
4752 0 0         if ($here_script eq '') {
4753 0           $here_script = CORE::substr $_, pos $_;
4754 0           $here_script =~ s/.*?\n//oxm;
4755             }
4756 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4757 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4758 0           push @heredoc_delimiter, $delimiter;
4759             }
4760             else {
4761 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4762             }
4763 0           $e_string .= $here_quote;
4764             }
4765              
4766             # <
4767             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4768 0           $slash = 'm//';
4769 0           my $here_quote = $1;
4770 0           my $delimiter = $2;
4771              
4772             # get here document
4773 0 0         if ($here_script eq '') {
4774 0           $here_script = CORE::substr $_, pos $_;
4775 0           $here_script =~ s/.*?\n//oxm;
4776             }
4777 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4778 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4779 0           push @heredoc_delimiter, $delimiter;
4780             }
4781             else {
4782 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4783             }
4784 0           $e_string .= $here_quote;
4785             }
4786              
4787             # <<`HEREDOC`
4788             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4789 0           $slash = 'm//';
4790 0           my $here_quote = $1;
4791 0           my $delimiter = $2;
4792              
4793             # get here document
4794 0 0         if ($here_script eq '') {
4795 0           $here_script = CORE::substr $_, pos $_;
4796 0           $here_script =~ s/.*?\n//oxm;
4797             }
4798 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4799 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4800 0           push @heredoc_delimiter, $delimiter;
4801             }
4802             else {
4803 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF";
4804             }
4805 0           $e_string .= $here_quote;
4806             }
4807              
4808             # any operator before div
4809             elsif ($string =~ /\G (
4810             -- | \+\+ |
4811             [\)\}\]]
4812              
4813 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4814              
4815             # yada-yada or triple-dot operator
4816             elsif ($string =~ /\G (
4817             \.\.\.
4818              
4819 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4820              
4821             # any operator before m//
4822             elsif ($string =~ /\G (
4823              
4824             !~~ | !~ | != | ! |
4825             %= | % |
4826             &&= | && | &= | & |
4827             -= | -> | - |
4828             :\s*= |
4829             : |
4830             <<= | <=> | <= | < |
4831             == | => | =~ | = |
4832             >>= | >> | >= | > |
4833             \*\*= | \*\* | \*= | \* |
4834             \+= | \+ |
4835             \.\. | \.= | \. |
4836             \/\/= | \/\/ |
4837             \/= | \/ |
4838             \? |
4839             \\ |
4840             \^= | \^ |
4841             \b x= |
4842             \|\|= | \|\| | \|= | \| |
4843             ~~ | ~ |
4844             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4845             \b(?: print )\b |
4846              
4847             [,;\(\{\[]
4848              
4849 0           ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4850              
4851             # other any character
4852 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4853              
4854             # system error
4855             else {
4856 0           die __FILE__, ": Oops, this shouldn't happen!";
4857             }
4858             }
4859              
4860 0           return $e_string;
4861             }
4862              
4863             #
4864             # character class
4865             #
4866             sub character_class {
4867 0     0 0   my($char,$modifier) = @_;
4868              
4869 0 0         if ($char eq '.') {
4870 0 0         if ($modifier =~ /s/) {
4871 0           return '${Char::Ewindows1258::dot_s}';
4872             }
4873             else {
4874 0           return '${Char::Ewindows1258::dot}';
4875             }
4876             }
4877             else {
4878 0           return Char::Ewindows1258::classic_character_class($char);
4879             }
4880             }
4881              
4882             #
4883             # escape capture ($1, $2, $3, ...)
4884             #
4885             sub e_capture {
4886              
4887 0     0 0   return join '', '${', $_[0], '}';
4888             }
4889              
4890             #
4891             # escape transliteration (tr/// or y///)
4892             #
4893             sub e_tr {
4894 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4895 0           my $e_tr = '';
4896 0   0       $modifier ||= '';
4897              
4898 0           $slash = 'div';
4899              
4900             # quote character class 1
4901 0           $charclass = q_tr($charclass);
4902              
4903             # quote character class 2
4904 0           $charclass2 = q_tr($charclass2);
4905              
4906             # /b /B modifier
4907 0 0         if ($modifier =~ tr/bB//d) {
4908 0 0         if ($variable eq '') {
4909 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4910             }
4911             else {
4912 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4913             }
4914             }
4915             else {
4916 0 0         if ($variable eq '') {
4917 0           $e_tr = qq{Char::Ewindows1258::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4918             }
4919             else {
4920 0           $e_tr = qq{Char::Ewindows1258::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4921             }
4922             }
4923              
4924             # clear tr/// variable
4925 0           $tr_variable = '';
4926 0           $bind_operator = '';
4927              
4928 0           return $e_tr;
4929             }
4930              
4931             #
4932             # quote for escape transliteration (tr/// or y///)
4933             #
4934             sub q_tr {
4935 0     0 0   my($charclass) = @_;
4936              
4937             # quote character class
4938 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4939 0           return e_q('', "'", "'", $charclass); # --> q' '
4940             }
4941             elsif ($charclass !~ /\//oxms) {
4942 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4943             }
4944             elsif ($charclass !~ /\#/oxms) {
4945 0           return e_q('q', '#', '#', $charclass); # --> q# #
4946             }
4947             elsif ($charclass !~ /[\<\>]/oxms) {
4948 0           return e_q('q', '<', '>', $charclass); # --> q< >
4949             }
4950             elsif ($charclass !~ /[\(\)]/oxms) {
4951 0           return e_q('q', '(', ')', $charclass); # --> q( )
4952             }
4953             elsif ($charclass !~ /[\{\}]/oxms) {
4954 0           return e_q('q', '{', '}', $charclass); # --> q{ }
4955             }
4956             else {
4957 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4958 0 0         if ($charclass !~ /\Q$char\E/xms) {
4959 0           return e_q('q', $char, $char, $charclass);
4960             }
4961             }
4962             }
4963              
4964 0           return e_q('q', '{', '}', $charclass);
4965             }
4966              
4967             #
4968             # escape q string (q//, '')
4969             #
4970             sub e_q {
4971 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4972              
4973 0           $slash = 'div';
4974              
4975 0           return join '', $ope, $delimiter, $string, $end_delimiter;
4976             }
4977              
4978             #
4979             # escape qq string (qq//, "", qx//, ``)
4980             #
4981             sub e_qq {
4982 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4983              
4984 0           $slash = 'div';
4985              
4986 0           my $left_e = 0;
4987 0           my $right_e = 0;
4988 0           my @char = $string =~ /\G(
4989             \\o\{ [0-7]+ \} |
4990             \\x\{ [0-9A-Fa-f]+ \} |
4991             \\N\{ [^0-9\}][^\}]* \} |
4992             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
4993             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
4994             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
4995             \$ \s* \d+ |
4996             \$ \s* \{ \s* \d+ \s* \} |
4997             \$ \$ (?![\w\{]) |
4998             \$ \s* \$ \s* $qq_variable |
4999             \\?(?:$q_char)
5000             )/oxmsg;
5001              
5002 0           for (my $i=0; $i <= $#char; $i++) {
5003              
5004             # "\L\u" --> "\u\L"
5005 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5006 0           @char[$i,$i+1] = @char[$i+1,$i];
5007             }
5008              
5009             # "\U\l" --> "\l\U"
5010             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5011 0           @char[$i,$i+1] = @char[$i+1,$i];
5012             }
5013              
5014             # octal escape sequence
5015             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5016 0           $char[$i] = Char::Ewindows1258::octchr($1);
5017             }
5018              
5019             # hexadecimal escape sequence
5020             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5021 0           $char[$i] = Char::Ewindows1258::hexchr($1);
5022             }
5023              
5024             # \N{CHARNAME} --> N{CHARNAME}
5025             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5026 0           $char[$i] = $1;
5027             }
5028              
5029 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5030             }
5031              
5032             # \F
5033             #
5034             # P.69 Table 2-6. Translation escapes
5035             # in Chapter 2: Bits and Pieces
5036             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5037             # (and so on)
5038              
5039             # \u \l \U \L \F \Q \E
5040 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5041 0 0         if ($right_e < $left_e) {
5042 0           $char[$i] = '\\' . $char[$i];
5043             }
5044             }
5045             elsif ($char[$i] eq '\u') {
5046              
5047             # "STRING @{[ LIST EXPR ]} MORE STRING"
5048              
5049             # P.257 Other Tricks You Can Do with Hard References
5050             # in Chapter 8: References
5051             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5052              
5053             # P.353 Other Tricks You Can Do with Hard References
5054             # in Chapter 8: References
5055             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5056              
5057             # (and so on)
5058              
5059 0           $char[$i] = '@{[Char::Ewindows1258::ucfirst qq<';
5060 0           $left_e++;
5061             }
5062             elsif ($char[$i] eq '\l') {
5063 0           $char[$i] = '@{[Char::Ewindows1258::lcfirst qq<';
5064 0           $left_e++;
5065             }
5066             elsif ($char[$i] eq '\U') {
5067 0           $char[$i] = '@{[Char::Ewindows1258::uc qq<';
5068 0           $left_e++;
5069             }
5070             elsif ($char[$i] eq '\L') {
5071 0           $char[$i] = '@{[Char::Ewindows1258::lc qq<';
5072 0           $left_e++;
5073             }
5074             elsif ($char[$i] eq '\F') {
5075 0           $char[$i] = '@{[Char::Ewindows1258::fc qq<';
5076 0           $left_e++;
5077             }
5078             elsif ($char[$i] eq '\Q') {
5079 0           $char[$i] = '@{[CORE::quotemeta qq<';
5080 0           $left_e++;
5081             }
5082             elsif ($char[$i] eq '\E') {
5083 0 0         if ($right_e < $left_e) {
5084 0           $char[$i] = '>]}';
5085 0           $right_e++;
5086             }
5087             else {
5088 0           $char[$i] = '';
5089             }
5090             }
5091             elsif ($char[$i] eq '\Q') {
5092 0           while (1) {
5093 0 0         if (++$i > $#char) {
5094 0           last;
5095             }
5096 0 0         if ($char[$i] eq '\E') {
5097 0           last;
5098             }
5099             }
5100             }
5101             elsif ($char[$i] eq '\E') {
5102             }
5103              
5104             # $0 --> $0
5105             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5106             }
5107             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5108             }
5109              
5110             # $$ --> $$
5111             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5112             }
5113              
5114             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5115             # $1, $2, $3 --> $1, $2, $3 otherwise
5116             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5117 0           $char[$i] = e_capture($1);
5118             }
5119             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5120 0           $char[$i] = e_capture($1);
5121             }
5122              
5123             # $$foo[ ... ] --> $ $foo->[ ... ]
5124             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5125 0           $char[$i] = e_capture($1.'->'.$2);
5126             }
5127              
5128             # $$foo{ ... } --> $ $foo->{ ... }
5129             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5130 0           $char[$i] = e_capture($1.'->'.$2);
5131             }
5132              
5133             # $$foo
5134             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5135 0           $char[$i] = e_capture($1);
5136             }
5137              
5138             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Ewindows1258::PREMATCH()
5139             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5140 0           $char[$i] = '@{[Char::Ewindows1258::PREMATCH()]}';
5141             }
5142              
5143             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Ewindows1258::MATCH()
5144             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5145 0           $char[$i] = '@{[Char::Ewindows1258::MATCH()]}';
5146             }
5147              
5148             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Ewindows1258::POSTMATCH()
5149             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5150 0           $char[$i] = '@{[Char::Ewindows1258::POSTMATCH()]}';
5151             }
5152              
5153             # ${ foo } --> ${ foo }
5154             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5155             }
5156              
5157             # ${ ... }
5158             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5159 0           $char[$i] = e_capture($1);
5160             }
5161             }
5162              
5163             # return string
5164 0 0         if ($left_e > $right_e) {
5165 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5166             }
5167 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5168             }
5169              
5170             #
5171             # escape qw string (qw//)
5172             #
5173             sub e_qw {
5174 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5175              
5176 0           $slash = 'div';
5177              
5178             # choice again delimiter
5179 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5180 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5181 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5182             }
5183             elsif (not $octet{')'}) {
5184 0           return join '', $ope, '(', $string, ')';
5185             }
5186             elsif (not $octet{'}'}) {
5187 0           return join '', $ope, '{', $string, '}';
5188             }
5189             elsif (not $octet{']'}) {
5190 0           return join '', $ope, '[', $string, ']';
5191             }
5192             elsif (not $octet{'>'}) {
5193 0           return join '', $ope, '<', $string, '>';
5194             }
5195             else {
5196 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5197 0 0         if (not $octet{$char}) {
5198 0           return join '', $ope, $char, $string, $char;
5199             }
5200             }
5201             }
5202              
5203             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5204 0           my @string = CORE::split(/\s+/, $string);
5205 0           for my $string (@string) {
5206 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5207 0           for my $octet (@octet) {
5208 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5209 0           $octet = '\\' . $1;
5210             }
5211             }
5212 0           $string = join '', @octet;
5213             }
5214 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5215             }
5216              
5217             #
5218             # escape here document (<<"HEREDOC", <
5219             #
5220             sub e_heredoc {
5221 0     0 0   my($string) = @_;
5222              
5223 0           $slash = 'm//';
5224              
5225 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5226              
5227 0           my $left_e = 0;
5228 0           my $right_e = 0;
5229 0           my @char = $string =~ /\G(
5230             \\o\{ [0-7]+ \} |
5231             \\x\{ [0-9A-Fa-f]+ \} |
5232             \\N\{ [^0-9\}][^\}]* \} |
5233             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5234             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5235             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5236             \$ \s* \d+ |
5237             \$ \s* \{ \s* \d+ \s* \} |
5238             \$ \$ (?![\w\{]) |
5239             \$ \s* \$ \s* $qq_variable |
5240             \\?(?:$q_char)
5241             )/oxmsg;
5242              
5243 0           for (my $i=0; $i <= $#char; $i++) {
5244              
5245             # "\L\u" --> "\u\L"
5246 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5247 0           @char[$i,$i+1] = @char[$i+1,$i];
5248             }
5249              
5250             # "\U\l" --> "\l\U"
5251             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5252 0           @char[$i,$i+1] = @char[$i+1,$i];
5253             }
5254              
5255             # octal escape sequence
5256             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5257 0           $char[$i] = Char::Ewindows1258::octchr($1);
5258             }
5259              
5260             # hexadecimal escape sequence
5261             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5262 0           $char[$i] = Char::Ewindows1258::hexchr($1);
5263             }
5264              
5265             # \N{CHARNAME} --> N{CHARNAME}
5266             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5267 0           $char[$i] = $1;
5268             }
5269              
5270 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5271             }
5272              
5273             # \u \l \U \L \F \Q \E
5274 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5275 0 0         if ($right_e < $left_e) {
5276 0           $char[$i] = '\\' . $char[$i];
5277             }
5278             }
5279             elsif ($char[$i] eq '\u') {
5280 0           $char[$i] = '@{[Char::Ewindows1258::ucfirst qq<';
5281 0           $left_e++;
5282             }
5283             elsif ($char[$i] eq '\l') {
5284 0           $char[$i] = '@{[Char::Ewindows1258::lcfirst qq<';
5285 0           $left_e++;
5286             }
5287             elsif ($char[$i] eq '\U') {
5288 0           $char[$i] = '@{[Char::Ewindows1258::uc qq<';
5289 0           $left_e++;
5290             }
5291             elsif ($char[$i] eq '\L') {
5292 0           $char[$i] = '@{[Char::Ewindows1258::lc qq<';
5293 0           $left_e++;
5294             }
5295             elsif ($char[$i] eq '\F') {
5296 0           $char[$i] = '@{[Char::Ewindows1258::fc qq<';
5297 0           $left_e++;
5298             }
5299             elsif ($char[$i] eq '\Q') {
5300 0           $char[$i] = '@{[CORE::quotemeta qq<';
5301 0           $left_e++;
5302             }
5303             elsif ($char[$i] eq '\E') {
5304 0 0         if ($right_e < $left_e) {
5305 0           $char[$i] = '>]}';
5306 0           $right_e++;
5307             }
5308             else {
5309 0           $char[$i] = '';
5310             }
5311             }
5312             elsif ($char[$i] eq '\Q') {
5313 0           while (1) {
5314 0 0         if (++$i > $#char) {
5315 0           last;
5316             }
5317 0 0         if ($char[$i] eq '\E') {
5318 0           last;
5319             }
5320             }
5321             }
5322             elsif ($char[$i] eq '\E') {
5323             }
5324              
5325             # $0 --> $0
5326             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5327             }
5328             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5329             }
5330              
5331             # $$ --> $$
5332             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5333             }
5334              
5335             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5336             # $1, $2, $3 --> $1, $2, $3 otherwise
5337             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5338 0           $char[$i] = e_capture($1);
5339             }
5340             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5341 0           $char[$i] = e_capture($1);
5342             }
5343              
5344             # $$foo[ ... ] --> $ $foo->[ ... ]
5345             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5346 0           $char[$i] = e_capture($1.'->'.$2);
5347             }
5348              
5349             # $$foo{ ... } --> $ $foo->{ ... }
5350             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5351 0           $char[$i] = e_capture($1.'->'.$2);
5352             }
5353              
5354             # $$foo
5355             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5356 0           $char[$i] = e_capture($1);
5357             }
5358              
5359             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Ewindows1258::PREMATCH()
5360             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5361 0           $char[$i] = '@{[Char::Ewindows1258::PREMATCH()]}';
5362             }
5363              
5364             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Ewindows1258::MATCH()
5365             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5366 0           $char[$i] = '@{[Char::Ewindows1258::MATCH()]}';
5367             }
5368              
5369             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Ewindows1258::POSTMATCH()
5370             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5371 0           $char[$i] = '@{[Char::Ewindows1258::POSTMATCH()]}';
5372             }
5373              
5374             # ${ foo } --> ${ foo }
5375             elsif ($char[$i] =~ /\A \$ \s* \{ \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* \} \z/oxms) {
5376             }
5377              
5378             # ${ ... }
5379             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5380 0           $char[$i] = e_capture($1);
5381             }
5382             }
5383              
5384             # return string
5385 0 0         if ($left_e > $right_e) {
5386 0           return join '', @char, '>]}' x ($left_e - $right_e);
5387             }
5388 0           return join '', @char;
5389             }
5390              
5391             #
5392             # escape regexp (m//, qr//)
5393             #
5394             sub e_qr {
5395 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5396 0   0       $modifier ||= '';
5397              
5398 0           $modifier =~ tr/p//d;
5399 0 0         if ($modifier =~ /([adlu])/oxms) {
5400 0           my $line = 0;
5401 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5402 0 0         if ($filename ne __FILE__) {
5403 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5404 0           last;
5405             }
5406             }
5407 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5408             }
5409              
5410 0           $slash = 'div';
5411              
5412             # literal null string pattern
5413 0 0         if ($string eq '') {
    0          
5414 0           $modifier =~ tr/bB//d;
5415 0           $modifier =~ tr/i//d;
5416 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5417             }
5418              
5419             # /b /B modifier
5420             elsif ($modifier =~ tr/bB//d) {
5421              
5422             # choice again delimiter
5423 0 0         if ($delimiter =~ / [\@:] /oxms) {
5424 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
5425 0           my %octet = map {$_ => 1} @char;
  0            
5426 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5427 0           $delimiter = '(';
5428 0           $end_delimiter = ')';
5429             }
5430             elsif (not $octet{'}'}) {
5431 0           $delimiter = '{';
5432 0           $end_delimiter = '}';
5433             }
5434             elsif (not $octet{']'}) {
5435 0           $delimiter = '[';
5436 0           $end_delimiter = ']';
5437             }
5438             elsif (not $octet{'>'}) {
5439 0           $delimiter = '<';
5440 0           $end_delimiter = '>';
5441             }
5442             else {
5443 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5444 0 0         if (not $octet{$char}) {
5445 0           $delimiter = $char;
5446 0           $end_delimiter = $char;
5447 0           last;
5448             }
5449             }
5450             }
5451             }
5452              
5453 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5454 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5455             }
5456             else {
5457 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5458             }
5459             }
5460              
5461 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5462 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5463              
5464             # split regexp
5465 0           my @char = $string =~ /\G(
5466             \\o\{ [0-7]+ \} |
5467             \\ [0-7]{2,3} |
5468             \\x\{ [0-9A-Fa-f]+ \} |
5469             \\x [0-9A-Fa-f]{1,2} |
5470             \\c [\x40-\x5F] |
5471             \\N\{ [^0-9\}][^\}]* \} |
5472             \\p\{ [^0-9\}][^\}]* \} |
5473             \\P\{ [^0-9\}][^\}]* \} |
5474             \\ (?:$q_char) |
5475             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
5476             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
5477             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
5478             [\$\@] $qq_variable |
5479             \$ \s* \d+ |
5480             \$ \s* \{ \s* \d+ \s* \} |
5481             \$ \$ (?![\w\{]) |
5482             \$ \s* \$ \s* $qq_variable |
5483             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5484             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
5485             \[\^ |
5486             \(\? |
5487             (?:$q_char)
5488             )/oxmsg;
5489              
5490             # choice again delimiter
5491 0 0         if ($delimiter =~ / [\@:] /oxms) {
5492 0           my %octet = map {$_ => 1} @char;
  0            
5493 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5494 0           $delimiter = '(';
5495 0           $end_delimiter = ')';
5496             }
5497             elsif (not $octet{'}'}) {
5498 0           $delimiter = '{';
5499 0           $end_delimiter = '}';
5500             }
5501             elsif (not $octet{']'}) {
5502 0           $delimiter = '[';
5503 0           $end_delimiter = ']';
5504             }
5505             elsif (not $octet{'>'}) {
5506 0           $delimiter = '<';
5507 0           $end_delimiter = '>';
5508             }
5509             else {
5510 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5511 0 0         if (not $octet{$char}) {
5512 0           $delimiter = $char;
5513 0           $end_delimiter = $char;
5514 0           last;
5515             }
5516             }
5517             }
5518             }
5519              
5520 0           my $left_e = 0;
5521 0           my $right_e = 0;
5522 0           for (my $i=0; $i <= $#char; $i++) {
5523              
5524             # "\L\u" --> "\u\L"
5525 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
5526 0           @char[$i,$i+1] = @char[$i+1,$i];
5527             }
5528              
5529             # "\U\l" --> "\l\U"
5530             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5531 0           @char[$i,$i+1] = @char[$i+1,$i];
5532             }
5533              
5534             # octal escape sequence
5535             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5536 0           $char[$i] = Char::Ewindows1258::octchr($1);
5537             }
5538              
5539             # hexadecimal escape sequence
5540             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5541 0           $char[$i] = Char::Ewindows1258::hexchr($1);
5542             }
5543              
5544             # \N{CHARNAME} --> N\{CHARNAME}
5545             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5546 0           $char[$i] = $1 . '\\' . $2;
5547             }
5548              
5549             # \p{PROPERTY} --> p\{PROPERTY}
5550             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5551 0           $char[$i] = $1 . '\\' . $2;
5552             }
5553              
5554             # \P{PROPERTY} --> P\{PROPERTY}
5555             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5556 0           $char[$i] = $1 . '\\' . $2;
5557             }
5558              
5559             # \p, \P, \X --> p, P, X
5560             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5561 0           $char[$i] = $1;
5562             }
5563              
5564 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
5565             }
5566              
5567             # join separated multiple-octet
5568 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5569 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
5570 0           $char[$i] .= join '', splice @char, $i+1, 3;
5571             }
5572             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)) {
5573 0           $char[$i] .= join '', splice @char, $i+1, 2;
5574             }
5575             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)) {
5576 0           $char[$i] .= join '', splice @char, $i+1, 1;
5577             }
5578             }
5579              
5580             # open character class [...]
5581             elsif ($char[$i] eq '[') {
5582 0           my $left = $i;
5583              
5584             # [] make die "Unmatched [] in regexp ..."
5585             # (and so on)
5586              
5587 0 0         if ($char[$i+1] eq ']') {
5588 0           $i++;
5589             }
5590              
5591 0           while (1) {
5592 0 0         if (++$i > $#char) {
5593 0           die __FILE__, ": Unmatched [] in regexp";
5594             }
5595 0 0         if ($char[$i] eq ']') {
5596 0           my $right = $i;
5597              
5598             # [...]
5599 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5600 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Ewindows1258::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5601             }
5602             else {
5603 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
5604             }
5605              
5606 0           $i = $left;
5607 0           last;
5608             }
5609             }
5610             }
5611              
5612             # open character class [^...]
5613             elsif ($char[$i] eq '[^') {
5614 0           my $left = $i;
5615              
5616             # [^] make die "Unmatched [] in regexp ..."
5617             # (and so on)
5618              
5619 0 0         if ($char[$i+1] eq ']') {
5620 0           $i++;
5621             }
5622              
5623 0           while (1) {
5624 0 0         if (++$i > $#char) {
5625 0           die __FILE__, ": Unmatched [] in regexp";
5626             }
5627 0 0         if ($char[$i] eq ']') {
5628 0           my $right = $i;
5629              
5630             # [^...]
5631 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5632 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Ewindows1258::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5633             }
5634             else {
5635 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5636             }
5637              
5638 0           $i = $left;
5639 0           last;
5640             }
5641             }
5642             }
5643              
5644             # rewrite character class or escape character
5645             elsif (my $char = character_class($char[$i],$modifier)) {
5646 0           $char[$i] = $char;
5647             }
5648              
5649             # /i modifier
5650             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Ewindows1258::uc($char[$i]) ne Char::Ewindows1258::fc($char[$i]))) {
5651 0 0         if (CORE::length(Char::Ewindows1258::fc($char[$i])) == 1) {
5652 0           $char[$i] = '[' . Char::Ewindows1258::uc($char[$i]) . Char::Ewindows1258::fc($char[$i]) . ']';
5653             }
5654             else {
5655 0           $char[$i] = '(?:' . Char::Ewindows1258::uc($char[$i]) . '|' . Char::Ewindows1258::fc($char[$i]) . ')';
5656             }
5657             }
5658              
5659             # \u \l \U \L \F \Q \E
5660             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5661 0 0         if ($right_e < $left_e) {
5662 0           $char[$i] = '\\' . $char[$i];
5663             }
5664             }
5665             elsif ($char[$i] eq '\u') {
5666 0           $char[$i] = '@{[Char::Ewindows1258::ucfirst qq<';
5667 0           $left_e++;
5668             }
5669             elsif ($char[$i] eq '\l') {
5670 0           $char[$i] = '@{[Char::Ewindows1258::lcfirst qq<';
5671 0           $left_e++;
5672             }
5673             elsif ($char[$i] eq '\U') {
5674 0           $char[$i] = '@{[Char::Ewindows1258::uc qq<';
5675 0           $left_e++;
5676             }
5677             elsif ($char[$i] eq '\L') {
5678 0           $char[$i] = '@{[Char::Ewindows1258::lc qq<';
5679 0           $left_e++;
5680             }
5681             elsif ($char[$i] eq '\F') {
5682 0           $char[$i] = '@{[Char::Ewindows1258::fc qq<';
5683 0           $left_e++;
5684             }
5685             elsif ($char[$i] eq '\Q') {
5686 0           $char[$i] = '@{[CORE::quotemeta qq<';
5687 0           $left_e++;
5688             }
5689             elsif ($char[$i] eq '\E') {
5690 0 0         if ($right_e < $left_e) {
5691 0           $char[$i] = '>]}';
5692 0           $right_e++;
5693             }
5694             else {
5695 0           $char[$i] = '';
5696             }
5697             }
5698             elsif ($char[$i] eq '\Q') {
5699 0           while (1) {
5700 0 0         if (++$i > $#char) {
5701 0           last;
5702             }
5703 0 0         if ($char[$i] eq '\E') {
5704 0           last;
5705             }
5706             }
5707             }
5708             elsif ($char[$i] eq '\E') {
5709             }
5710              
5711             # $0 --> $0
5712             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5713 0 0         if ($ignorecase) {
5714 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5715             }
5716             }
5717             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
5718 0 0         if ($ignorecase) {
5719 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5720             }
5721             }
5722              
5723             # $$ --> $$
5724             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5725             }
5726              
5727             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5728             # $1, $2, $3 --> $1, $2, $3 otherwise
5729             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
5730 0           $char[$i] = e_capture($1);
5731 0 0         if ($ignorecase) {
5732 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5733             }
5734             }
5735             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
5736 0           $char[$i] = e_capture($1);
5737 0 0         if ($ignorecase) {
5738 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5739             }
5740             }
5741              
5742             # $$foo[ ... ] --> $ $foo->[ ... ]
5743             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5744 0           $char[$i] = e_capture($1.'->'.$2);
5745 0 0         if ($ignorecase) {
5746 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5747             }
5748             }
5749              
5750             # $$foo{ ... } --> $ $foo->{ ... }
5751             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5752 0           $char[$i] = e_capture($1.'->'.$2);
5753 0 0         if ($ignorecase) {
5754 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5755             }
5756             }
5757              
5758             # $$foo
5759             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
5760 0           $char[$i] = e_capture($1);
5761 0 0         if ($ignorecase) {
5762 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5763             }
5764             }
5765              
5766             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Ewindows1258::PREMATCH()
5767             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
5768 0 0         if ($ignorecase) {
5769 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::PREMATCH())]}';
5770             }
5771             else {
5772 0           $char[$i] = '@{[Char::Ewindows1258::PREMATCH()]}';
5773             }
5774             }
5775              
5776             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Ewindows1258::MATCH()
5777             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
5778 0 0         if ($ignorecase) {
5779 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::MATCH())]}';
5780             }
5781             else {
5782 0           $char[$i] = '@{[Char::Ewindows1258::MATCH()]}';
5783             }
5784             }
5785              
5786             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Ewindows1258::POSTMATCH()
5787             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
5788 0 0         if ($ignorecase) {
5789 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::POSTMATCH())]}';
5790             }
5791             else {
5792 0           $char[$i] = '@{[Char::Ewindows1258::POSTMATCH()]}';
5793             }
5794             }
5795              
5796             # ${ foo }
5797             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5798 0 0         if ($ignorecase) {
5799 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5800             }
5801             }
5802              
5803             # ${ ... }
5804             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
5805 0           $char[$i] = e_capture($1);
5806 0 0         if ($ignorecase) {
5807 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5808             }
5809             }
5810              
5811             # $scalar or @array
5812             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5813 0           $char[$i] = e_string($char[$i]);
5814 0 0         if ($ignorecase) {
5815 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
5816             }
5817             }
5818              
5819             # quote character before ? + * {
5820             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5821 0 0 0       if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5822             }
5823             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5824 0           my $char = $char[$i-1];
5825 0 0         if ($char[$i] eq '{') {
5826 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}};
5827             }
5828             else {
5829 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]};
5830             }
5831             }
5832             else {
5833 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5834             }
5835             }
5836             }
5837              
5838             # make regexp string
5839 0           $modifier =~ tr/i//d;
5840 0 0         if ($left_e > $right_e) {
5841 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5842 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5843             }
5844             else {
5845 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5846             }
5847             }
5848 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5849 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5850             }
5851             else {
5852 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5853             }
5854             }
5855              
5856             #
5857             # double quote stuff
5858             #
5859             sub qq_stuff {
5860 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5861              
5862             # scalar variable or array variable
5863 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5864 0           return $stuff;
5865             }
5866              
5867             # quote by delimiter
5868 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5869 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5870 0 0         next if $char eq $delimiter;
5871 0 0         next if $char eq $end_delimiter;
5872 0 0         if (not $octet{$char}) {
5873 0           return join '', 'qq', $char, $stuff, $char;
5874             }
5875             }
5876 0           return join '', 'qq', '<', $stuff, '>';
5877             }
5878              
5879             #
5880             # escape regexp (m'', qr'', and m''b, qr''b)
5881             #
5882             sub e_qr_q {
5883 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5884 0   0       $modifier ||= '';
5885              
5886 0           $modifier =~ tr/p//d;
5887 0 0         if ($modifier =~ /([adlu])/oxms) {
5888 0           my $line = 0;
5889 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5890 0 0         if ($filename ne __FILE__) {
5891 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5892 0           last;
5893             }
5894             }
5895 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5896             }
5897              
5898 0           $slash = 'div';
5899              
5900             # literal null string pattern
5901 0 0         if ($string eq '') {
    0          
5902 0           $modifier =~ tr/bB//d;
5903 0           $modifier =~ tr/i//d;
5904 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5905             }
5906              
5907             # with /b /B modifier
5908             elsif ($modifier =~ tr/bB//d) {
5909 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5910             }
5911              
5912             # without /b /B modifier
5913             else {
5914 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5915             }
5916             }
5917              
5918             #
5919             # escape regexp (m'', qr'')
5920             #
5921             sub e_qr_qt {
5922 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5923              
5924 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5925              
5926             # split regexp
5927 0           my @char = $string =~ /\G(
5928             \[\:\^ [a-z]+ \:\] |
5929             \[\: [a-z]+ \:\] |
5930             \[\^ |
5931             [\$\@\/\\] |
5932             \\? (?:$q_char)
5933             )/oxmsg;
5934              
5935             # unescape character
5936 0           for (my $i=0; $i <= $#char; $i++) {
5937 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5938             }
5939              
5940             # open character class [...]
5941 0           elsif ($char[$i] eq '[') {
5942 0           my $left = $i;
5943 0 0         if ($char[$i+1] eq ']') {
5944 0           $i++;
5945             }
5946 0           while (1) {
5947 0 0         if (++$i > $#char) {
5948 0           die __FILE__, ": Unmatched [] in regexp";
5949             }
5950 0 0         if ($char[$i] eq ']') {
5951 0           my $right = $i;
5952              
5953             # [...]
5954 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
5955              
5956 0           $i = $left;
5957 0           last;
5958             }
5959             }
5960             }
5961              
5962             # open character class [^...]
5963             elsif ($char[$i] eq '[^') {
5964 0           my $left = $i;
5965 0 0         if ($char[$i+1] eq ']') {
5966 0           $i++;
5967             }
5968 0           while (1) {
5969 0 0         if (++$i > $#char) {
5970 0           die __FILE__, ": Unmatched [] in regexp";
5971             }
5972 0 0         if ($char[$i] eq ']') {
5973 0           my $right = $i;
5974              
5975             # [^...]
5976 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5977              
5978 0           $i = $left;
5979 0           last;
5980             }
5981             }
5982             }
5983              
5984             # escape $ @ / and \
5985             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5986 0           $char[$i] = '\\' . $char[$i];
5987             }
5988              
5989             # rewrite character class or escape character
5990             elsif (my $char = character_class($char[$i],$modifier)) {
5991 0           $char[$i] = $char;
5992             }
5993              
5994             # /i modifier
5995             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Ewindows1258::uc($char[$i]) ne Char::Ewindows1258::fc($char[$i]))) {
5996 0 0         if (CORE::length(Char::Ewindows1258::fc($char[$i])) == 1) {
5997 0           $char[$i] = '[' . Char::Ewindows1258::uc($char[$i]) . Char::Ewindows1258::fc($char[$i]) . ']';
5998             }
5999             else {
6000 0           $char[$i] = '(?:' . Char::Ewindows1258::uc($char[$i]) . '|' . Char::Ewindows1258::fc($char[$i]) . ')';
6001             }
6002             }
6003              
6004             # quote character before ? + * {
6005             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6006 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6007             }
6008             else {
6009 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6010             }
6011             }
6012             }
6013              
6014 0           $delimiter = '/';
6015 0           $end_delimiter = '/';
6016              
6017 0           $modifier =~ tr/i//d;
6018 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6019             }
6020              
6021             #
6022             # escape regexp (m''b, qr''b)
6023             #
6024             sub e_qr_qb {
6025 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6026              
6027             # split regexp
6028 0           my @char = $string =~ /\G(
6029             \\\\ |
6030             [\$\@\/\\] |
6031             [\x00-\xFF]
6032             )/oxmsg;
6033              
6034             # unescape character
6035 0           for (my $i=0; $i <= $#char; $i++) {
6036 0 0         if (0) {
    0          
6037             }
6038              
6039             # remain \\
6040 0           elsif ($char[$i] eq '\\\\') {
6041             }
6042              
6043             # escape $ @ / and \
6044             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6045 0           $char[$i] = '\\' . $char[$i];
6046             }
6047             }
6048              
6049 0           $delimiter = '/';
6050 0           $end_delimiter = '/';
6051 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6052             }
6053              
6054             #
6055             # escape regexp (s/here//)
6056             #
6057             sub e_s1 {
6058 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6059 0   0       $modifier ||= '';
6060              
6061 0           $modifier =~ tr/p//d;
6062 0 0         if ($modifier =~ /([adlu])/oxms) {
6063 0           my $line = 0;
6064 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6065 0 0         if ($filename ne __FILE__) {
6066 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6067 0           last;
6068             }
6069             }
6070 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6071             }
6072              
6073 0           $slash = 'div';
6074              
6075             # literal null string pattern
6076 0 0         if ($string eq '') {
    0          
6077 0           $modifier =~ tr/bB//d;
6078 0           $modifier =~ tr/i//d;
6079 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6080             }
6081              
6082             # /b /B modifier
6083             elsif ($modifier =~ tr/bB//d) {
6084              
6085             # choice again delimiter
6086 0 0         if ($delimiter =~ / [\@:] /oxms) {
6087 0           my @char = $string =~ /\G([\x00-\xFF])/oxmsg;
6088 0           my %octet = map {$_ => 1} @char;
  0            
6089 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6090 0           $delimiter = '(';
6091 0           $end_delimiter = ')';
6092             }
6093             elsif (not $octet{'}'}) {
6094 0           $delimiter = '{';
6095 0           $end_delimiter = '}';
6096             }
6097             elsif (not $octet{']'}) {
6098 0           $delimiter = '[';
6099 0           $end_delimiter = ']';
6100             }
6101             elsif (not $octet{'>'}) {
6102 0           $delimiter = '<';
6103 0           $end_delimiter = '>';
6104             }
6105             else {
6106 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6107 0 0         if (not $octet{$char}) {
6108 0           $delimiter = $char;
6109 0           $end_delimiter = $char;
6110 0           last;
6111             }
6112             }
6113             }
6114             }
6115              
6116 0           my $prematch = '';
6117 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6118             }
6119              
6120 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6121 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6122              
6123             # split regexp
6124 0           my @char = $string =~ /\G(
6125             \\g \s* \{ \s* - \s* [1-9][0-9]* \s* \} |
6126             \\g \s* \{ \s* [1-9][0-9]* \s* \} |
6127             \\g \s* [1-9][0-9]* |
6128             \\o\{ [0-7]+ \} |
6129             \\ [1-9][0-9]* |
6130             \\ [0-7]{2,3} |
6131             \\x\{ [0-9A-Fa-f]+ \} |
6132             \\x [0-9A-Fa-f]{1,2} |
6133             \\c [\x40-\x5F] |
6134             \\N\{ [^0-9\}][^\}]* \} |
6135             \\p\{ [^0-9\}][^\}]* \} |
6136             \\P\{ [^0-9\}][^\}]* \} |
6137             \\ (?:$q_char) |
6138             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6139             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6140             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6141             [\$\@] $qq_variable |
6142             \$ \s* \d+ |
6143             \$ \s* \{ \s* \d+ \s* \} |
6144             \$ \$ (?![\w\{]) |
6145             \$ \s* \$ \s* $qq_variable |
6146             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6147             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6148             \[\^ |
6149             \(\? |
6150             (?:$q_char)
6151             )/oxmsg;
6152              
6153             # choice again delimiter
6154 0 0         if ($delimiter =~ / [\@:] /oxms) {
6155 0           my %octet = map {$_ => 1} @char;
  0            
6156 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6157 0           $delimiter = '(';
6158 0           $end_delimiter = ')';
6159             }
6160             elsif (not $octet{'}'}) {
6161 0           $delimiter = '{';
6162 0           $end_delimiter = '}';
6163             }
6164             elsif (not $octet{']'}) {
6165 0           $delimiter = '[';
6166 0           $end_delimiter = ']';
6167             }
6168             elsif (not $octet{'>'}) {
6169 0           $delimiter = '<';
6170 0           $end_delimiter = '>';
6171             }
6172             else {
6173 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6174 0 0         if (not $octet{$char}) {
6175 0           $delimiter = $char;
6176 0           $end_delimiter = $char;
6177 0           last;
6178             }
6179             }
6180             }
6181             }
6182              
6183             # count '('
6184 0           my $parens = grep { $_ eq '(' } @char;
  0            
6185              
6186 0           my $left_e = 0;
6187 0           my $right_e = 0;
6188 0           for (my $i=0; $i <= $#char; $i++) {
6189              
6190             # "\L\u" --> "\u\L"
6191 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6192 0           @char[$i,$i+1] = @char[$i+1,$i];
6193             }
6194              
6195             # "\U\l" --> "\l\U"
6196             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6197 0           @char[$i,$i+1] = @char[$i+1,$i];
6198             }
6199              
6200             # octal escape sequence
6201             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6202 0           $char[$i] = Char::Ewindows1258::octchr($1);
6203             }
6204              
6205             # hexadecimal escape sequence
6206             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6207 0           $char[$i] = Char::Ewindows1258::hexchr($1);
6208             }
6209              
6210             # \N{CHARNAME} --> N\{CHARNAME}
6211             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6212 0           $char[$i] = $1 . '\\' . $2;
6213             }
6214              
6215             # \p{PROPERTY} --> p\{PROPERTY}
6216             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6217 0           $char[$i] = $1 . '\\' . $2;
6218             }
6219              
6220             # \P{PROPERTY} --> P\{PROPERTY}
6221             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6222 0           $char[$i] = $1 . '\\' . $2;
6223             }
6224              
6225             # \p, \P, \X --> p, P, X
6226             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6227 0           $char[$i] = $1;
6228             }
6229              
6230 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6231             }
6232              
6233             # join separated multiple-octet
6234 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6235 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6236 0           $char[$i] .= join '', splice @char, $i+1, 3;
6237             }
6238             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)) {
6239 0           $char[$i] .= join '', splice @char, $i+1, 2;
6240             }
6241             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)) {
6242 0           $char[$i] .= join '', splice @char, $i+1, 1;
6243             }
6244             }
6245              
6246             # open character class [...]
6247             elsif ($char[$i] eq '[') {
6248 0           my $left = $i;
6249 0 0         if ($char[$i+1] eq ']') {
6250 0           $i++;
6251             }
6252 0           while (1) {
6253 0 0         if (++$i > $#char) {
6254 0           die __FILE__, ": Unmatched [] in regexp";
6255             }
6256 0 0         if ($char[$i] eq ']') {
6257 0           my $right = $i;
6258              
6259             # [...]
6260 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6261 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Ewindows1258::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6262             }
6263             else {
6264 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
6265             }
6266              
6267 0           $i = $left;
6268 0           last;
6269             }
6270             }
6271             }
6272              
6273             # open character class [^...]
6274             elsif ($char[$i] eq '[^') {
6275 0           my $left = $i;
6276 0 0         if ($char[$i+1] eq ']') {
6277 0           $i++;
6278             }
6279 0           while (1) {
6280 0 0         if (++$i > $#char) {
6281 0           die __FILE__, ": Unmatched [] in regexp";
6282             }
6283 0 0         if ($char[$i] eq ']') {
6284 0           my $right = $i;
6285              
6286             # [^...]
6287 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6288 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Ewindows1258::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6289             }
6290             else {
6291 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6292             }
6293              
6294 0           $i = $left;
6295 0           last;
6296             }
6297             }
6298             }
6299              
6300             # rewrite character class or escape character
6301             elsif (my $char = character_class($char[$i],$modifier)) {
6302 0           $char[$i] = $char;
6303             }
6304              
6305             # /i modifier
6306             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Ewindows1258::uc($char[$i]) ne Char::Ewindows1258::fc($char[$i]))) {
6307 0 0         if (CORE::length(Char::Ewindows1258::fc($char[$i])) == 1) {
6308 0           $char[$i] = '[' . Char::Ewindows1258::uc($char[$i]) . Char::Ewindows1258::fc($char[$i]) . ']';
6309             }
6310             else {
6311 0           $char[$i] = '(?:' . Char::Ewindows1258::uc($char[$i]) . '|' . Char::Ewindows1258::fc($char[$i]) . ')';
6312             }
6313             }
6314              
6315             # \u \l \U \L \F \Q \E
6316             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6317 0 0         if ($right_e < $left_e) {
6318 0           $char[$i] = '\\' . $char[$i];
6319             }
6320             }
6321             elsif ($char[$i] eq '\u') {
6322 0           $char[$i] = '@{[Char::Ewindows1258::ucfirst qq<';
6323 0           $left_e++;
6324             }
6325             elsif ($char[$i] eq '\l') {
6326 0           $char[$i] = '@{[Char::Ewindows1258::lcfirst qq<';
6327 0           $left_e++;
6328             }
6329             elsif ($char[$i] eq '\U') {
6330 0           $char[$i] = '@{[Char::Ewindows1258::uc qq<';
6331 0           $left_e++;
6332             }
6333             elsif ($char[$i] eq '\L') {
6334 0           $char[$i] = '@{[Char::Ewindows1258::lc qq<';
6335 0           $left_e++;
6336             }
6337             elsif ($char[$i] eq '\F') {
6338 0           $char[$i] = '@{[Char::Ewindows1258::fc qq<';
6339 0           $left_e++;
6340             }
6341             elsif ($char[$i] eq '\Q') {
6342 0           $char[$i] = '@{[CORE::quotemeta qq<';
6343 0           $left_e++;
6344             }
6345             elsif ($char[$i] eq '\E') {
6346 0 0         if ($right_e < $left_e) {
6347 0           $char[$i] = '>]}';
6348 0           $right_e++;
6349             }
6350             else {
6351 0           $char[$i] = '';
6352             }
6353             }
6354             elsif ($char[$i] eq '\Q') {
6355 0           while (1) {
6356 0 0         if (++$i > $#char) {
6357 0           last;
6358             }
6359 0 0         if ($char[$i] eq '\E') {
6360 0           last;
6361             }
6362             }
6363             }
6364             elsif ($char[$i] eq '\E') {
6365             }
6366              
6367             # \0 --> \0
6368             elsif ($char[$i] =~ /\A \\ \s* 0 \z/oxms) {
6369             }
6370              
6371             # \g{N}, \g{-N}
6372              
6373             # P.108 Using Simple Patterns
6374             # in Chapter 7: In the World of Regular Expressions
6375             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6376              
6377             # P.221 Capturing
6378             # in Chapter 5: Pattern Matching
6379             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6380              
6381             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6382             elsif ($char[$i] =~ /\A \\g \s* \{ \s* - \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6383             }
6384              
6385             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6386             elsif ($char[$i] =~ /\A \\g \s* \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6387             }
6388              
6389             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6390             elsif ($char[$i] =~ /\A \\g \s* ([1-9][0-9]*) \z/oxms) {
6391             }
6392              
6393             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6394             elsif ($char[$i] =~ /\A \\ \s* ([1-9][0-9]*) \z/oxms) {
6395             }
6396              
6397             # $0 --> $0
6398             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6399 0 0         if ($ignorecase) {
6400 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6401             }
6402             }
6403             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
6404 0 0         if ($ignorecase) {
6405 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6406             }
6407             }
6408              
6409             # $$ --> $$
6410             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6411             }
6412              
6413             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6414             # $1, $2, $3 --> $1, $2, $3 otherwise
6415             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
6416 0           $char[$i] = e_capture($1);
6417 0 0         if ($ignorecase) {
6418 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6419             }
6420             }
6421             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
6422 0           $char[$i] = e_capture($1);
6423 0 0         if ($ignorecase) {
6424 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6425             }
6426             }
6427              
6428             # $$foo[ ... ] --> $ $foo->[ ... ]
6429             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6430 0           $char[$i] = e_capture($1.'->'.$2);
6431 0 0         if ($ignorecase) {
6432 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6433             }
6434             }
6435              
6436             # $$foo{ ... } --> $ $foo->{ ... }
6437             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6438 0           $char[$i] = e_capture($1.'->'.$2);
6439 0 0         if ($ignorecase) {
6440 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6441             }
6442             }
6443              
6444             # $$foo
6445             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
6446 0           $char[$i] = e_capture($1);
6447 0 0         if ($ignorecase) {
6448 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6449             }
6450             }
6451              
6452             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Ewindows1258::PREMATCH()
6453             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
6454 0 0         if ($ignorecase) {
6455 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::PREMATCH())]}';
6456             }
6457             else {
6458 0           $char[$i] = '@{[Char::Ewindows1258::PREMATCH()]}';
6459             }
6460             }
6461              
6462             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Ewindows1258::MATCH()
6463             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
6464 0 0         if ($ignorecase) {
6465 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::MATCH())]}';
6466             }
6467             else {
6468 0           $char[$i] = '@{[Char::Ewindows1258::MATCH()]}';
6469             }
6470             }
6471              
6472             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Ewindows1258::POSTMATCH()
6473             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
6474 0 0         if ($ignorecase) {
6475 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::POSTMATCH())]}';
6476             }
6477             else {
6478 0           $char[$i] = '@{[Char::Ewindows1258::POSTMATCH()]}';
6479             }
6480             }
6481              
6482             # ${ foo }
6483             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
6484 0 0         if ($ignorecase) {
6485 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6486             }
6487             }
6488              
6489             # ${ ... }
6490             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
6491 0           $char[$i] = e_capture($1);
6492 0 0         if ($ignorecase) {
6493 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6494             }
6495             }
6496              
6497             # $scalar or @array
6498             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6499 0           $char[$i] = e_string($char[$i]);
6500 0 0         if ($ignorecase) {
6501 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
6502             }
6503             }
6504              
6505             # quote character before ? + * {
6506             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6507 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6508             }
6509             else {
6510 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6511             }
6512             }
6513             }
6514              
6515             # make regexp string
6516 0           my $prematch = '';
6517 0           $modifier =~ tr/i//d;
6518 0 0         if ($left_e > $right_e) {
6519 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6520             }
6521 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6522             }
6523              
6524             #
6525             # escape regexp (s'here'' or s'here''b)
6526             #
6527             sub e_s1_q {
6528 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6529 0   0       $modifier ||= '';
6530              
6531 0           $modifier =~ tr/p//d;
6532 0 0         if ($modifier =~ /([adlu])/oxms) {
6533 0           my $line = 0;
6534 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6535 0 0         if ($filename ne __FILE__) {
6536 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6537 0           last;
6538             }
6539             }
6540 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6541             }
6542              
6543 0           $slash = 'div';
6544              
6545             # literal null string pattern
6546 0 0         if ($string eq '') {
    0          
6547 0           $modifier =~ tr/bB//d;
6548 0           $modifier =~ tr/i//d;
6549 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6550             }
6551              
6552             # with /b /B modifier
6553             elsif ($modifier =~ tr/bB//d) {
6554 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6555             }
6556              
6557             # without /b /B modifier
6558             else {
6559 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6560             }
6561             }
6562              
6563             #
6564             # escape regexp (s'here'')
6565             #
6566             sub e_s1_qt {
6567 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6568              
6569 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6570              
6571             # split regexp
6572 0           my @char = $string =~ /\G(
6573             \[\:\^ [a-z]+ \:\] |
6574             \[\: [a-z]+ \:\] |
6575             \[\^ |
6576             [\$\@\/\\] |
6577             \\? (?:$q_char)
6578             )/oxmsg;
6579              
6580             # unescape character
6581 0           for (my $i=0; $i <= $#char; $i++) {
6582 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6583             }
6584              
6585             # open character class [...]
6586 0           elsif ($char[$i] eq '[') {
6587 0           my $left = $i;
6588 0 0         if ($char[$i+1] eq ']') {
6589 0           $i++;
6590             }
6591 0           while (1) {
6592 0 0         if (++$i > $#char) {
6593 0           die __FILE__, ": Unmatched [] in regexp";
6594             }
6595 0 0         if ($char[$i] eq ']') {
6596 0           my $right = $i;
6597              
6598             # [...]
6599 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
6600              
6601 0           $i = $left;
6602 0           last;
6603             }
6604             }
6605             }
6606              
6607             # open character class [^...]
6608             elsif ($char[$i] eq '[^') {
6609 0           my $left = $i;
6610 0 0         if ($char[$i+1] eq ']') {
6611 0           $i++;
6612             }
6613 0           while (1) {
6614 0 0         if (++$i > $#char) {
6615 0           die __FILE__, ": Unmatched [] in regexp";
6616             }
6617 0 0         if ($char[$i] eq ']') {
6618 0           my $right = $i;
6619              
6620             # [^...]
6621 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6622              
6623 0           $i = $left;
6624 0           last;
6625             }
6626             }
6627             }
6628              
6629             # escape $ @ / and \
6630             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6631 0           $char[$i] = '\\' . $char[$i];
6632             }
6633              
6634             # rewrite character class or escape character
6635             elsif (my $char = character_class($char[$i],$modifier)) {
6636 0           $char[$i] = $char;
6637             }
6638              
6639             # /i modifier
6640             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Ewindows1258::uc($char[$i]) ne Char::Ewindows1258::fc($char[$i]))) {
6641 0 0         if (CORE::length(Char::Ewindows1258::fc($char[$i])) == 1) {
6642 0           $char[$i] = '[' . Char::Ewindows1258::uc($char[$i]) . Char::Ewindows1258::fc($char[$i]) . ']';
6643             }
6644             else {
6645 0           $char[$i] = '(?:' . Char::Ewindows1258::uc($char[$i]) . '|' . Char::Ewindows1258::fc($char[$i]) . ')';
6646             }
6647             }
6648              
6649             # quote character before ? + * {
6650             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6651 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6652             }
6653             else {
6654 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6655             }
6656             }
6657             }
6658              
6659 0           $modifier =~ tr/i//d;
6660 0           $delimiter = '/';
6661 0           $end_delimiter = '/';
6662 0           my $prematch = '';
6663 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6664             }
6665              
6666             #
6667             # escape regexp (s'here''b)
6668             #
6669             sub e_s1_qb {
6670 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6671              
6672             # split regexp
6673 0           my @char = $string =~ /\G(
6674             \\\\ |
6675             [\$\@\/\\] |
6676             [\x00-\xFF]
6677             )/oxmsg;
6678              
6679             # unescape character
6680 0           for (my $i=0; $i <= $#char; $i++) {
6681 0 0         if (0) {
    0          
6682             }
6683              
6684             # remain \\
6685 0           elsif ($char[$i] eq '\\\\') {
6686             }
6687              
6688             # escape $ @ / and \
6689             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6690 0           $char[$i] = '\\' . $char[$i];
6691             }
6692             }
6693              
6694 0           $delimiter = '/';
6695 0           $end_delimiter = '/';
6696 0           my $prematch = '';
6697 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6698             }
6699              
6700             #
6701             # escape regexp (s''here')
6702             #
6703             sub e_s2_q {
6704 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6705              
6706 0           $slash = 'div';
6707              
6708 0           my @char = $string =~ / \G (\\\\|[\$\@\/\\]|$q_char) /oxmsg;
6709 0           for (my $i=0; $i <= $#char; $i++) {
6710 0 0         if (0) {
    0          
6711             }
6712              
6713             # not escape \\
6714 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6715             }
6716              
6717             # escape $ @ / and \
6718             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6719 0           $char[$i] = '\\' . $char[$i];
6720             }
6721             }
6722              
6723 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6724             }
6725              
6726             #
6727             # escape regexp (s/here/and here/modifier)
6728             #
6729             sub e_sub {
6730 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6731 0   0       $modifier ||= '';
6732              
6733 0           $modifier =~ tr/p//d;
6734 0 0         if ($modifier =~ /([adlu])/oxms) {
6735 0           my $line = 0;
6736 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6737 0 0         if ($filename ne __FILE__) {
6738 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6739 0           last;
6740             }
6741             }
6742 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6743             }
6744              
6745 0 0         if ($variable eq '') {
6746 0           $variable = '$_';
6747 0           $bind_operator = ' =~ ';
6748             }
6749              
6750 0           $slash = 'div';
6751              
6752             # P.128 Start of match (or end of previous match): \G
6753             # P.130 Advanced Use of \G with Perl
6754             # in Chapter 3: Overview of Regular Expression Features and Flavors
6755             # P.312 Iterative Matching: Scalar Context, with /g
6756             # in Chapter 7: Perl
6757             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6758              
6759             # P.181 Where You Left Off: The \G Assertion
6760             # in Chapter 5: Pattern Matching
6761             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6762              
6763             # P.220 Where You Left Off: The \G Assertion
6764             # in Chapter 5: Pattern Matching
6765             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6766              
6767 0           my $e_modifier = $modifier =~ tr/e//d;
6768 0           my $r_modifier = $modifier =~ tr/r//d;
6769              
6770 0           my $my = '';
6771 0 0         if ($variable =~ s/\A \( \s* ( (?: local \b | my \b | our \b | state \b )? .+ ) \) \z/$1/oxms) {
6772 0           $my = $variable;
6773 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) \s* //oxms;
6774 0           $variable =~ s/ = .+ \z//oxms;
6775             }
6776              
6777 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6778 0           $variable_basename =~ s/ \s+ \z//oxms;
6779              
6780             # quote replacement string
6781 0           my $e_replacement = '';
6782 0 0         if ($e_modifier >= 1) {
6783 0           $e_replacement = e_qq('', '', '', $replacement);
6784 0           $e_modifier--;
6785             }
6786             else {
6787 0 0         if ($delimiter2 eq "'") {
6788 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6789             }
6790             else {
6791 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6792             }
6793             }
6794              
6795 0           my $sub = '';
6796              
6797             # with /r
6798 0 0         if ($r_modifier) {
6799 0 0         if (0) {
6800             }
6801              
6802             # s///gr without multibyte anchoring
6803 0           elsif ($modifier =~ /g/oxms) {
6804 0 0         $sub = sprintf(
6805             # 1 2 3 4 5
6806             q,
6807              
6808             $variable, # 1
6809             ($delimiter1 eq "'") ? # 2
6810             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6811             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6812             $s_matched, # 3
6813             $e_replacement, # 4
6814             '$Char::Windows1258::re_r=CORE::eval $Char::Windows1258::re_r; ' x $e_modifier, # 5
6815             );
6816             }
6817              
6818             # s///r
6819             else {
6820              
6821 0           my $prematch = q{$`};
6822              
6823 0 0         $sub = sprintf(
6824             # 1 2 3 4 5 6 7
6825             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Char::Windows1258::re_r=%s; %s"%s$Char::Windows1258::re_r$'" } : %s>,
6826              
6827             $variable, # 1
6828             ($delimiter1 eq "'") ? # 2
6829             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6830             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6831             $s_matched, # 3
6832             $e_replacement, # 4
6833             '$Char::Windows1258::re_r=CORE::eval $Char::Windows1258::re_r; ' x $e_modifier, # 5
6834             $prematch, # 6
6835             $variable, # 7
6836             );
6837             }
6838              
6839             # $var !~ s///r doesn't make sense
6840 0 0         if ($bind_operator =~ / !~ /oxms) {
6841 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6842             }
6843             }
6844              
6845             # without /r
6846             else {
6847 0 0         if (0) {
6848             }
6849              
6850             # s///g without multibyte anchoring
6851 0           elsif ($modifier =~ /g/oxms) {
6852 0 0         $sub = sprintf(
    0          
6853             # 1 2 3 4 5 6 7 8
6854             q,
6855              
6856             $variable, # 1
6857             ($delimiter1 eq "'") ? # 2
6858             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6859             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6860             $s_matched, # 3
6861             $e_replacement, # 4
6862             '$Char::Windows1258::re_r=CORE::eval $Char::Windows1258::re_r; ' x $e_modifier, # 5
6863             $variable, # 6
6864             $variable, # 7
6865             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6866             );
6867             }
6868              
6869             # s///
6870             else {
6871              
6872 0           my $prematch = q{$`};
6873              
6874 0 0         $sub = sprintf(
    0          
6875              
6876             ($bind_operator =~ / =~ /oxms) ?
6877              
6878             # 1 2 3 4 5 6 7 8
6879             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Char::Windows1258::re_r=%s; %s%s="%s$Char::Windows1258::re_r$'"; 1 } : undef> :
6880              
6881             # 1 2 3 4 5 6 7 8
6882             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Char::Windows1258::re_r=%s; %s%s="%s$Char::Windows1258::re_r$'"; undef }>,
6883              
6884             $variable, # 1
6885             $bind_operator, # 2
6886             ($delimiter1 eq "'") ? # 3
6887             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6888             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6889             $s_matched, # 4
6890             $e_replacement, # 5
6891             '$Char::Windows1258::re_r=CORE::eval $Char::Windows1258::re_r; ' x $e_modifier, # 6
6892             $variable, # 7
6893             $prematch, # 8
6894             );
6895             }
6896             }
6897              
6898             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6899 0 0         if ($my ne '') {
6900 0           $sub = "($my, $sub)[1]";
6901             }
6902              
6903             # clear s/// variable
6904 0           $sub_variable = '';
6905 0           $bind_operator = '';
6906              
6907 0           return $sub;
6908             }
6909              
6910             #
6911             # escape regexp of split qr//
6912             #
6913             sub e_split {
6914 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6915 0   0       $modifier ||= '';
6916              
6917 0           $modifier =~ tr/p//d;
6918 0 0         if ($modifier =~ /([adlu])/oxms) {
6919 0           my $line = 0;
6920 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6921 0 0         if ($filename ne __FILE__) {
6922 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6923 0           last;
6924             }
6925             }
6926 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6927             }
6928              
6929 0           $slash = 'div';
6930              
6931             # /b /B modifier
6932 0 0         if ($modifier =~ tr/bB//d) {
6933 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6934             }
6935              
6936 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6937 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6938              
6939             # split regexp
6940 0           my @char = $string =~ /\G(
6941             \\o\{ [0-7]+ \} |
6942             \\ [0-7]{2,3} |
6943             \\x\{ [0-9A-Fa-f]+ \} |
6944             \\x [0-9A-Fa-f]{1,2} |
6945             \\c [\x40-\x5F] |
6946             \\N\{ [^0-9\}][^\}]* \} |
6947             \\p\{ [^0-9\}][^\}]* \} |
6948             \\P\{ [^0-9\}][^\}]* \} |
6949             \\ (?:$q_char) |
6950             \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} |
6951             \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} |
6952             \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} |
6953             [\$\@] $qq_variable |
6954             \$ \s* \d+ |
6955             \$ \s* \{ \s* \d+ \s* \} |
6956             \$ \$ (?![\w\{]) |
6957             \$ \s* \$ \s* $qq_variable |
6958             \[\:\^ (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6959             \[\: (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] |
6960             \[\^ |
6961             \(\? |
6962             (?:$q_char)
6963             )/oxmsg;
6964              
6965 0           my $left_e = 0;
6966 0           my $right_e = 0;
6967 0           for (my $i=0; $i <= $#char; $i++) {
6968              
6969             # "\L\u" --> "\u\L"
6970 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
6971 0           @char[$i,$i+1] = @char[$i+1,$i];
6972             }
6973              
6974             # "\U\l" --> "\l\U"
6975             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6976 0           @char[$i,$i+1] = @char[$i+1,$i];
6977             }
6978              
6979             # octal escape sequence
6980             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6981 0           $char[$i] = Char::Ewindows1258::octchr($1);
6982             }
6983              
6984             # hexadecimal escape sequence
6985             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6986 0           $char[$i] = Char::Ewindows1258::hexchr($1);
6987             }
6988              
6989             # \N{CHARNAME} --> N\{CHARNAME}
6990             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6991 0           $char[$i] = $1 . '\\' . $2;
6992             }
6993              
6994             # \p{PROPERTY} --> p\{PROPERTY}
6995             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6996 0           $char[$i] = $1 . '\\' . $2;
6997             }
6998              
6999             # \P{PROPERTY} --> P\{PROPERTY}
7000             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7001 0           $char[$i] = $1 . '\\' . $2;
7002             }
7003              
7004             # \p, \P, \X --> p, P, X
7005             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7006 0           $char[$i] = $1;
7007             }
7008              
7009 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7010             }
7011              
7012             # join separated multiple-octet
7013 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7014 0 0 0       if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
7015 0           $char[$i] .= join '', splice @char, $i+1, 3;
7016             }
7017             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)) {
7018 0           $char[$i] .= join '', splice @char, $i+1, 2;
7019             }
7020             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)) {
7021 0           $char[$i] .= join '', splice @char, $i+1, 1;
7022             }
7023             }
7024              
7025             # open character class [...]
7026             elsif ($char[$i] eq '[') {
7027 0           my $left = $i;
7028 0 0         if ($char[$i+1] eq ']') {
7029 0           $i++;
7030             }
7031 0           while (1) {
7032 0 0         if (++$i > $#char) {
7033 0           die __FILE__, ": Unmatched [] in regexp";
7034             }
7035 0 0         if ($char[$i] eq ']') {
7036 0           my $right = $i;
7037              
7038             # [...]
7039 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7040 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Ewindows1258::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7041             }
7042             else {
7043 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
7044             }
7045              
7046 0           $i = $left;
7047 0           last;
7048             }
7049             }
7050             }
7051              
7052             # open character class [^...]
7053             elsif ($char[$i] eq '[^') {
7054 0           my $left = $i;
7055 0 0         if ($char[$i+1] eq ']') {
7056 0           $i++;
7057             }
7058 0           while (1) {
7059 0 0         if (++$i > $#char) {
7060 0           die __FILE__, ": Unmatched [] in regexp";
7061             }
7062 0 0         if ($char[$i] eq ']') {
7063 0           my $right = $i;
7064              
7065             # [^...]
7066 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7067 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Char::Ewindows1258::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7068             }
7069             else {
7070 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7071             }
7072              
7073 0           $i = $left;
7074 0           last;
7075             }
7076             }
7077             }
7078              
7079             # rewrite character class or escape character
7080             elsif (my $char = character_class($char[$i],$modifier)) {
7081 0           $char[$i] = $char;
7082             }
7083              
7084             # P.794 29.2.161. split
7085             # in Chapter 29: Functions
7086             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7087              
7088             # P.951 split
7089             # in Chapter 27: Functions
7090             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7091              
7092             # said "The //m modifier is assumed when you split on the pattern /^/",
7093             # but perl5.008 is not so. Therefore, this software adds //m.
7094             # (and so on)
7095              
7096             # split(m/^/) --> split(m/^/m)
7097             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7098 0           $modifier .= 'm';
7099             }
7100              
7101             # /i modifier
7102             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Ewindows1258::uc($char[$i]) ne Char::Ewindows1258::fc($char[$i]))) {
7103 0 0         if (CORE::length(Char::Ewindows1258::fc($char[$i])) == 1) {
7104 0           $char[$i] = '[' . Char::Ewindows1258::uc($char[$i]) . Char::Ewindows1258::fc($char[$i]) . ']';
7105             }
7106             else {
7107 0           $char[$i] = '(?:' . Char::Ewindows1258::uc($char[$i]) . '|' . Char::Ewindows1258::fc($char[$i]) . ')';
7108             }
7109             }
7110              
7111             # \u \l \U \L \F \Q \E
7112             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7113 0 0         if ($right_e < $left_e) {
7114 0           $char[$i] = '\\' . $char[$i];
7115             }
7116             }
7117             elsif ($char[$i] eq '\u') {
7118 0           $char[$i] = '@{[Char::Ewindows1258::ucfirst qq<';
7119 0           $left_e++;
7120             }
7121             elsif ($char[$i] eq '\l') {
7122 0           $char[$i] = '@{[Char::Ewindows1258::lcfirst qq<';
7123 0           $left_e++;
7124             }
7125             elsif ($char[$i] eq '\U') {
7126 0           $char[$i] = '@{[Char::Ewindows1258::uc qq<';
7127 0           $left_e++;
7128             }
7129             elsif ($char[$i] eq '\L') {
7130 0           $char[$i] = '@{[Char::Ewindows1258::lc qq<';
7131 0           $left_e++;
7132             }
7133             elsif ($char[$i] eq '\F') {
7134 0           $char[$i] = '@{[Char::Ewindows1258::fc qq<';
7135 0           $left_e++;
7136             }
7137             elsif ($char[$i] eq '\Q') {
7138 0           $char[$i] = '@{[CORE::quotemeta qq<';
7139 0           $left_e++;
7140             }
7141             elsif ($char[$i] eq '\E') {
7142 0 0         if ($right_e < $left_e) {
7143 0           $char[$i] = '>]}';
7144 0           $right_e++;
7145             }
7146             else {
7147 0           $char[$i] = '';
7148             }
7149             }
7150             elsif ($char[$i] eq '\Q') {
7151 0           while (1) {
7152 0 0         if (++$i > $#char) {
7153 0           last;
7154             }
7155 0 0         if ($char[$i] eq '\E') {
7156 0           last;
7157             }
7158             }
7159             }
7160             elsif ($char[$i] eq '\E') {
7161             }
7162              
7163             # $0 --> $0
7164             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7165 0 0         if ($ignorecase) {
7166 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7167             }
7168             }
7169             elsif ($char[$i] =~ /\A \$ \{ \s* 0 \s* \} \z/oxms) {
7170 0 0         if ($ignorecase) {
7171 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7172             }
7173             }
7174              
7175             # $$ --> $$
7176             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7177             }
7178              
7179             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7180             # $1, $2, $3 --> $1, $2, $3 otherwise
7181             elsif ($char[$i] =~ /\A \$ ([1-9][0-9]*) \z/oxms) {
7182 0           $char[$i] = e_capture($1);
7183 0 0         if ($ignorecase) {
7184 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7185             }
7186             }
7187             elsif ($char[$i] =~ /\A \$ \{ \s* ([1-9][0-9]*) \s* \} \z/oxms) {
7188 0           $char[$i] = e_capture($1);
7189 0 0         if ($ignorecase) {
7190 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7191             }
7192             }
7193              
7194             # $$foo[ ... ] --> $ $foo->[ ... ]
7195             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7196 0           $char[$i] = e_capture($1.'->'.$2);
7197 0 0         if ($ignorecase) {
7198 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7199             }
7200             }
7201              
7202             # $$foo{ ... } --> $ $foo->{ ... }
7203             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7204 0           $char[$i] = e_capture($1.'->'.$2);
7205 0 0         if ($ignorecase) {
7206 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7207             }
7208             }
7209              
7210             # $$foo
7211             elsif ($char[$i] =~ /\A \$ ( \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) \z/oxms) {
7212 0           $char[$i] = e_capture($1);
7213 0 0         if ($ignorecase) {
7214 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7215             }
7216             }
7217              
7218             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Char::Ewindows1258::PREMATCH()
7219             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ \s* PREMATCH | \$ \s* \{ \s* PREMATCH \s* \} | \$ \s* \{\^PREMATCH\} ) \z/oxmsgc) {
7220 0 0         if ($ignorecase) {
7221 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::PREMATCH())]}';
7222             }
7223             else {
7224 0           $char[$i] = '@{[Char::Ewindows1258::PREMATCH()]}';
7225             }
7226             }
7227              
7228             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Char::Ewindows1258::MATCH()
7229             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ \s* MATCH | \$ \s* \{ \s* MATCH \s* \} | \$ \s* \{\^MATCH\} ) \z/oxmsgc) {
7230 0 0         if ($ignorecase) {
7231 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::MATCH())]}';
7232             }
7233             else {
7234 0           $char[$i] = '@{[Char::Ewindows1258::MATCH()]}';
7235             }
7236             }
7237              
7238             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Char::Ewindows1258::POSTMATCH()
7239             elsif ($char[$i] =~ /\A ( \$ \s* POSTMATCH | \$ \s* \{ \s* POSTMATCH \s* \} | \$ \s* \{\^POSTMATCH\} ) \z/oxmsgc) {
7240 0 0         if ($ignorecase) {
7241 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(Char::Ewindows1258::POSTMATCH())]}';
7242             }
7243             else {
7244 0           $char[$i] = '@{[Char::Ewindows1258::POSTMATCH()]}';
7245             }
7246             }
7247              
7248             # ${ foo }
7249             elsif ($char[$i] =~ /\A \$ \s* \{ ( \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
7250 0 0         if ($ignorecase) {
7251 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $1 . ')]}';
7252             }
7253             }
7254              
7255             # ${ ... }
7256             elsif ($char[$i] =~ /\A \$ \s* \{ \s* ( .+ ) \s* \} \z/oxms) {
7257 0           $char[$i] = e_capture($1);
7258 0 0         if ($ignorecase) {
7259 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7260             }
7261             }
7262              
7263             # $scalar or @array
7264             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7265 0           $char[$i] = e_string($char[$i]);
7266 0 0         if ($ignorecase) {
7267 0           $char[$i] = '@{[Char::Ewindows1258::ignorecase(' . $char[$i] . ')]}';
7268             }
7269             }
7270              
7271             # quote character before ? + * {
7272             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7273 0 0         if ($char[$i-1] =~ /\A (?:\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7274             }
7275             else {
7276 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7277             }
7278             }
7279             }
7280              
7281             # make regexp string
7282 0           $modifier =~ tr/i//d;
7283 0 0         if ($left_e > $right_e) {
7284 0           return join '', 'Char::Ewindows1258::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7285             }
7286 0           return join '', 'Char::Ewindows1258::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7287             }
7288              
7289             #
7290             # escape regexp of split qr''
7291             #
7292             sub e_split_q {
7293 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7294 0   0       $modifier ||= '';
7295              
7296 0           $modifier =~ tr/p//d;
7297 0 0         if ($modifier =~ /([adlu])/oxms) {
7298 0           my $line = 0;
7299 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7300 0 0         if ($filename ne __FILE__) {
7301 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7302 0           last;
7303             }
7304             }
7305 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7306             }
7307              
7308 0           $slash = 'div';
7309              
7310             # /b /B modifier
7311 0 0         if ($modifier =~ tr/bB//d) {
7312 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7313             }
7314              
7315 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7316              
7317             # split regexp
7318 0           my @char = $string =~ /\G(
7319             \[\:\^ [a-z]+ \:\] |
7320             \[\: [a-z]+ \:\] |
7321             \[\^ |
7322             \\? (?:$q_char)
7323             )/oxmsg;
7324              
7325             # unescape character
7326 0           for (my $i=0; $i <= $#char; $i++) {
7327 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7328             }
7329              
7330             # open character class [...]
7331 0           elsif ($char[$i] eq '[') {
7332 0           my $left = $i;
7333 0 0         if ($char[$i+1] eq ']') {
7334 0           $i++;
7335             }
7336 0           while (1) {
7337 0 0         if (++$i > $#char) {
7338 0           die __FILE__, ": Unmatched [] in regexp";
7339             }
7340 0 0         if ($char[$i] eq ']') {
7341 0           my $right = $i;
7342              
7343             # [...]
7344 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_qr(@char[$left+1..$right-1], $modifier);
7345              
7346 0           $i = $left;
7347 0           last;
7348             }
7349             }
7350             }
7351              
7352             # open character class [^...]
7353             elsif ($char[$i] eq '[^') {
7354 0           my $left = $i;
7355 0 0         if ($char[$i+1] eq ']') {
7356 0           $i++;
7357             }
7358 0           while (1) {
7359 0 0         if (++$i > $#char) {
7360 0           die __FILE__, ": Unmatched [] in regexp";
7361             }
7362 0 0         if ($char[$i] eq ']') {
7363 0           my $right = $i;
7364              
7365             # [^...]
7366 0           splice @char, $left, $right-$left+1, Char::Ewindows1258::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7367              
7368 0           $i = $left;
7369 0           last;
7370             }
7371             }
7372             }
7373              
7374             # rewrite character class or escape character
7375             elsif (my $char = character_class($char[$i],$modifier)) {
7376 0           $char[$i] = $char;
7377             }
7378              
7379             # split(m/^/) --> split(m/^/m)
7380             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7381 0           $modifier .= 'm';
7382             }
7383              
7384             # /i modifier
7385             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Char::Ewindows1258::uc($char[$i]) ne Char::Ewindows1258::fc($char[$i]))) {
7386 0 0         if (CORE::length(Char::Ewindows1258::fc($char[$i])) == 1) {
7387 0           $char[$i] = '[' . Char::Ewindows1258::uc($char[$i]) . Char::Ewindows1258::fc($char[$i]) . ']';
7388             }
7389             else {
7390 0           $char[$i] = '(?:' . Char::Ewindows1258::uc($char[$i]) . '|' . Char::Ewindows1258::fc($char[$i]) . ')';
7391             }
7392             }
7393              
7394             # quote character before ? + * {
7395             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7396 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7397             }
7398             else {
7399 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7400             }
7401             }
7402             }
7403              
7404 0           $modifier =~ tr/i//d;
7405 0           return join '', 'Char::Ewindows1258::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7406             }
7407              
7408             #
7409             # instead of Carp::carp
7410             #
7411             sub carp {
7412 0     0 0   my($package,$filename,$line) = caller(1);
7413 0           print STDERR "@_ at $filename line $line.\n";
7414             }
7415              
7416             #
7417             # instead of Carp::croak
7418             #
7419             sub croak {
7420 0     0 0   my($package,$filename,$line) = caller(1);
7421 0           print STDERR "@_ at $filename line $line.\n";
7422 0           die "\n";
7423             }
7424              
7425             #
7426             # instead of Carp::cluck
7427             #
7428             sub cluck {
7429 0     0 0   my $i = 0;
7430 0           my @cluck = ();
7431 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7432 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7433 0           $i++;
7434             }
7435 0           print STDERR CORE::reverse @cluck;
7436 0           print STDERR "\n";
7437 0           carp @_;
7438             }
7439              
7440             #
7441             # instead of Carp::confess
7442             #
7443             sub confess {
7444 0     0 0   my $i = 0;
7445 0           my @confess = ();
7446 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7447 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7448 0           $i++;
7449             }
7450 0           print STDERR CORE::reverse @confess;
7451 0           print STDERR "\n";
7452 0           croak @_;
7453             }
7454              
7455             1;
7456              
7457             __END__