File Coverage

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


line stmt bran cond sub pod time code
1             package Earabic;
2             ######################################################################
3             #
4             # Earabic - Run-time routines for Arabic.pm
5             #
6             # http://search.cpan.org/dist/Char-Arabic/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 INABA Hitoshi
9             ######################################################################
10              
11 200     200   11797 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         662  
  200         13150  
12             # use 5.008001; # Lancaster Consensus 2013 for toolchains
13              
14             # 12.3. Delaying use Until Runtime
15             # in Chapter 12. Packages, Libraries, and Modules
16             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
17             # (and so on)
18              
19             # Version numbers should be boring
20             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
21             # For the impatient, the disinterested or those who just want to follow
22             # a recipe, my advice for all modules is this:
23             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
24             # $VERSION = eval $VERSION;
25              
26 200     200   16493 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   1335  
  200         390  
  200         37702  
27             $VERSION = '1.05';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1476 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         579 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         34019 if (CORE::ord('A') != 0x41) {
38             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
39             }
40             }
41              
42             BEGIN {
43              
44             # instead of utf8.pm
45 200     200   16106 CORE::eval q{
  200     200   1456  
  200     62   358  
  200         31522  
  62         15601  
  78         13996  
  63         12071  
  50         11255  
  70         14818  
  77         15063  
46             no warnings qw(redefine);
47             *utf8::upgrade = sub { CORE::length $_[0] };
48             *utf8::downgrade = sub { 1 };
49             *utf8::encode = sub { };
50             *utf8::decode = sub { 1 };
51             *utf8::is_utf8 = sub { };
52             *utf8::valid = sub { 1 };
53             };
54 200 50       134431 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
  0         0  
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
  0         0  
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65             BEGIN {
66 200     200   560 my $genpkg = "Symbol::";
67 200         10967 my $genseq = 0;
68              
69             sub gensym () {
70 0     0 0 0 my $name = "GEN" . $genseq++;
71              
72             # here, no strict qw(refs); if strict.pm exists
73              
74 0         0 my $ref = \*{$genpkg . $name};
  0         0  
75 0         0 delete $$genpkg{$name};
76 0         0 return $ref;
77             }
78              
79             sub qualify ($;$) {
80 0     0 0 0 my ($name) = @_;
81 0 0 0     0 if (!ref($name) && (Earabic::index($name, '::') == -1) && (Earabic::index($name, "'") == -1)) {
      0        
82 0         0 my $pkg;
83 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
84              
85             # Global names: special character, "^xyz", or other.
86 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
89 0         0 $pkg = "main";
90             }
91             else {
92 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
93             }
94 0         0 $name = $pkg . "::" . $name;
95             }
96 0         0 return $name;
97             }
98              
99             sub qualify_to_ref ($;$) {
100              
101             # here, no strict qw(refs); if strict.pm exists
102              
103 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
104             }
105             }
106              
107             # Column: local $@
108             # in Chapter 9. Osaete okitai Perl no kiso
109             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
110             # (and so on)
111              
112             # use strict; if strict.pm exists
113             BEGIN {
114 200 50   200   448 if (CORE::eval { local $@; CORE::require strict }) {
  200         369  
  200         2211  
115 200         30518 strict::->import;
116             }
117             }
118              
119             # P.714 29.2.39. flock
120             # in Chapter 29: Functions
121             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
122              
123             # P.863 flock
124             # in Chapter 27: Functions
125             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
126              
127             sub LOCK_SH() {1}
128             sub LOCK_EX() {2}
129             sub LOCK_UN() {8}
130             sub LOCK_NB() {4}
131              
132             # instead of Carp.pm
133             sub carp;
134             sub croak;
135             sub cluck;
136             sub confess;
137              
138             # 6.18. Matching Multiple-Byte Characters
139             # in Chapter 6. Pattern Matching
140             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
141             # (and so on)
142              
143             # regexp of character
144 200     200   17547 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   1305  
  200         345  
  200         35694  
145 200     200   14644 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   1261  
  200         361  
  200         15039  
146 200     200   13685 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   1194  
  200         347  
  200         17351  
147              
148             #
149             # Arabic character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   14952 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   1363  
  200         314  
  200         223392  
157              
158             #
159             # Arabic case conversion
160             #
161             my %lc = ();
162             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
163             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
164             my %uc = ();
165             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
166             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
167             my %fc = ();
168             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
169             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
170              
171             if (0) {
172             }
173              
174             elsif (__PACKAGE__ =~ / \b Earabic \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-6 | iec[- ]?8859-6 | arabic ) \b /oxmsi;
180             }
181              
182             else {
183             croak "Don't know my package name '@{[__PACKAGE__]}'";
184             }
185              
186             #
187             # @ARGV wildcard globbing
188             #
189             sub import {
190              
191 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
192 0         0 my @argv = ();
193 0         0 for (@ARGV) {
194              
195             # has space
196 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
197 0 0       0 if (my @glob = Earabic::glob(qq{"$_"})) {
198 0         0 push @argv, @glob;
199             }
200             else {
201 0         0 push @argv, $_;
202             }
203             }
204              
205             # has wildcard metachar
206             elsif (/\A (?:$q_char)*? [*?] /oxms) {
207 0 0       0 if (my @glob = Earabic::glob($_)) {
208 0         0 push @argv, @glob;
209             }
210             else {
211 0         0 push @argv, $_;
212             }
213             }
214              
215             # no wildcard globbing
216             else {
217 0         0 push @argv, $_;
218             }
219             }
220 0         0 @ARGV = @argv;
221             }
222              
223 0         0 *Char::ord = \&Arabic::ord;
224 0         0 *Char::ord_ = \&Arabic::ord_;
225 0         0 *Char::reverse = \&Arabic::reverse;
226 0         0 *Char::getc = \&Arabic::getc;
227 0         0 *Char::length = \&Arabic::length;
228 0         0 *Char::substr = \&Arabic::substr;
229 0         0 *Char::index = \&Arabic::index;
230 0         0 *Char::rindex = \&Arabic::rindex;
231 0         0 *Char::eval = \&Arabic::eval;
232 0         0 *Char::escape = \&Arabic::escape;
233 0         0 *Char::escape_token = \&Arabic::escape_token;
234 0         0 *Char::escape_script = \&Arabic::escape_script;
235             }
236              
237             # P.230 Care with Prototypes
238             # in Chapter 6: Subroutines
239             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
240             #
241             # If you aren't careful, you can get yourself into trouble with prototypes.
242             # But if you are careful, you can do a lot of neat things with them. This is
243             # all very powerful, of course, and should only be used in moderation to make
244             # the world a better place.
245              
246             # P.332 Care with Prototypes
247             # in Chapter 7: Subroutines
248             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
249             #
250             # If you aren't careful, you can get yourself into trouble with prototypes.
251             # But if you are careful, you can do a lot of neat things with them. This is
252             # all very powerful, of course, and should only be used in moderation to make
253             # the world a better place.
254              
255             #
256             # Prototypes of subroutines
257             #
258 0     0   0 sub unimport {}
259             sub Earabic::split(;$$$);
260             sub Earabic::tr($$$$;$);
261             sub Earabic::chop(@);
262             sub Earabic::index($$;$);
263             sub Earabic::rindex($$;$);
264             sub Earabic::lcfirst(@);
265             sub Earabic::lcfirst_();
266             sub Earabic::lc(@);
267             sub Earabic::lc_();
268             sub Earabic::ucfirst(@);
269             sub Earabic::ucfirst_();
270             sub Earabic::uc(@);
271             sub Earabic::uc_();
272             sub Earabic::fc(@);
273             sub Earabic::fc_();
274             sub Earabic::ignorecase;
275             sub Earabic::classic_character_class;
276             sub Earabic::capture;
277             sub Earabic::chr(;$);
278             sub Earabic::chr_();
279             sub Earabic::glob($);
280             sub Earabic::glob_();
281              
282             sub Arabic::ord(;$);
283             sub Arabic::ord_();
284             sub Arabic::reverse(@);
285             sub Arabic::getc(;*@);
286             sub Arabic::length(;$);
287             sub Arabic::substr($$;$$);
288             sub Arabic::index($$;$);
289             sub Arabic::rindex($$;$);
290             sub Arabic::escape(;$);
291              
292             #
293             # Regexp work
294             #
295 200     200   31240 BEGIN { CORE::eval q{ use vars qw(
  200     200   1415  
  200         420  
  200         103166  
296             $Arabic::re_a
297             $Arabic::re_t
298             $Arabic::re_n
299             $Arabic::re_r
300             ) } }
301              
302             #
303             # Character class
304             #
305 200     200   18623 BEGIN { CORE::eval q{ use vars qw(
  200     200   1529  
  200         344  
  200         3344066  
306             $dot
307             $dot_s
308             $eD
309             $eS
310             $eW
311             $eH
312             $eV
313             $eR
314             $eN
315             $not_alnum
316             $not_alpha
317             $not_ascii
318             $not_blank
319             $not_cntrl
320             $not_digit
321             $not_graph
322             $not_lower
323             $not_lower_i
324             $not_print
325             $not_punct
326             $not_space
327             $not_upper
328             $not_upper_i
329             $not_word
330             $not_xdigit
331             $eb
332             $eB
333             ) } }
334              
335             ${Earabic::dot} = qr{(?>[^\x0A])};
336             ${Earabic::dot_s} = qr{(?>[\x00-\xFF])};
337             ${Earabic::eD} = qr{(?>[^0-9])};
338              
339             # Vertical tabs are now whitespace
340             # \s in a regex now matches a vertical tab in all circumstances.
341             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
342             # ${Earabic::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
343             # ${Earabic::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
344             ${Earabic::eS} = qr{(?>[^\s])};
345              
346             ${Earabic::eW} = qr{(?>[^0-9A-Z_a-z])};
347             ${Earabic::eH} = qr{(?>[^\x09\x20])};
348             ${Earabic::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
349             ${Earabic::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
350             ${Earabic::eN} = qr{(?>[^\x0A])};
351             ${Earabic::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
352             ${Earabic::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
353             ${Earabic::not_ascii} = qr{(?>[^\x00-\x7F])};
354             ${Earabic::not_blank} = qr{(?>[^\x09\x20])};
355             ${Earabic::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
356             ${Earabic::not_digit} = qr{(?>[^\x30-\x39])};
357             ${Earabic::not_graph} = qr{(?>[^\x21-\x7F])};
358             ${Earabic::not_lower} = qr{(?>[^\x61-\x7A])};
359             ${Earabic::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
360             # ${Earabic::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
361             ${Earabic::not_print} = qr{(?>[^\x20-\x7F])};
362             ${Earabic::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
363             ${Earabic::not_space} = qr{(?>[^\s\x0B])};
364             ${Earabic::not_upper} = qr{(?>[^\x41-\x5A])};
365             ${Earabic::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
366             # ${Earabic::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
367             ${Earabic::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
368             ${Earabic::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
369             ${Earabic::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))};
370             ${Earabic::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]))};
371              
372             # avoid: Name "Earabic::foo" used only once: possible typo at here.
373             ${Earabic::dot} = ${Earabic::dot};
374             ${Earabic::dot_s} = ${Earabic::dot_s};
375             ${Earabic::eD} = ${Earabic::eD};
376             ${Earabic::eS} = ${Earabic::eS};
377             ${Earabic::eW} = ${Earabic::eW};
378             ${Earabic::eH} = ${Earabic::eH};
379             ${Earabic::eV} = ${Earabic::eV};
380             ${Earabic::eR} = ${Earabic::eR};
381             ${Earabic::eN} = ${Earabic::eN};
382             ${Earabic::not_alnum} = ${Earabic::not_alnum};
383             ${Earabic::not_alpha} = ${Earabic::not_alpha};
384             ${Earabic::not_ascii} = ${Earabic::not_ascii};
385             ${Earabic::not_blank} = ${Earabic::not_blank};
386             ${Earabic::not_cntrl} = ${Earabic::not_cntrl};
387             ${Earabic::not_digit} = ${Earabic::not_digit};
388             ${Earabic::not_graph} = ${Earabic::not_graph};
389             ${Earabic::not_lower} = ${Earabic::not_lower};
390             ${Earabic::not_lower_i} = ${Earabic::not_lower_i};
391             ${Earabic::not_print} = ${Earabic::not_print};
392             ${Earabic::not_punct} = ${Earabic::not_punct};
393             ${Earabic::not_space} = ${Earabic::not_space};
394             ${Earabic::not_upper} = ${Earabic::not_upper};
395             ${Earabic::not_upper_i} = ${Earabic::not_upper_i};
396             ${Earabic::not_word} = ${Earabic::not_word};
397             ${Earabic::not_xdigit} = ${Earabic::not_xdigit};
398             ${Earabic::eb} = ${Earabic::eb};
399             ${Earabic::eB} = ${Earabic::eB};
400              
401             #
402             # Arabic split
403             #
404             sub Earabic::split(;$$$) {
405              
406             # P.794 29.2.161. split
407             # in Chapter 29: Functions
408             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
409              
410             # P.951 split
411             # in Chapter 27: Functions
412             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
413              
414 0     0 0 0 my $pattern = $_[0];
415 0         0 my $string = $_[1];
416 0         0 my $limit = $_[2];
417              
418             # if $pattern is also omitted or is the literal space, " "
419 0 0       0 if (not defined $pattern) {
420 0         0 $pattern = ' ';
421             }
422              
423             # if $string is omitted, the function splits the $_ string
424 0 0       0 if (not defined $string) {
425 0 0       0 if (defined $_) {
426 0         0 $string = $_;
427             }
428             else {
429 0         0 $string = '';
430             }
431             }
432              
433 0         0 my @split = ();
434              
435             # when string is empty
436 0 0       0 if ($string eq '') {
    0          
437              
438             # resulting list value in list context
439 0 0       0 if (wantarray) {
440 0         0 return @split;
441             }
442              
443             # count of substrings in scalar context
444             else {
445 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
446 0         0 @_ = @split;
447 0         0 return scalar @_;
448             }
449             }
450              
451             # split's first argument is more consistently interpreted
452             #
453             # After some changes earlier in v5.17, split's behavior has been simplified:
454             # if the PATTERN argument evaluates to a string containing one space, it is
455             # treated the way that a literal string containing one space once was.
456             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
457              
458             # if $pattern is also omitted or is the literal space, " ", the function splits
459             # on whitespace, /\s+/, after skipping any leading whitespace
460             # (and so on)
461              
462             elsif ($pattern eq ' ') {
463 0 0       0 if (not defined $limit) {
464 0         0 return CORE::split(' ', $string);
465             }
466             else {
467 0         0 return CORE::split(' ', $string, $limit);
468             }
469             }
470              
471             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
472 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
473              
474             # a pattern capable of matching either the null string or something longer than the
475             # null string will split the value of $string into separate characters wherever it
476             # matches the null string between characters
477             # (and so on)
478              
479 0 0       0 if ('' =~ / \A $pattern \z /xms) {
480 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
481 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
482              
483             # P.1024 Appendix W.10 Multibyte Processing
484             # of ISBN 1-56592-224-7 CJKV Information Processing
485             # (and so on)
486              
487             # the //m modifier is assumed when you split on the pattern /^/
488             # (and so on)
489              
490             # V
491 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
492              
493             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
494             # is included in the resulting list, interspersed with the fields that are ordinarily returned
495             # (and so on)
496              
497 0         0 local $@;
498 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
499 0         0 push @split, CORE::eval('$' . $digit);
500             }
501             }
502             }
503              
504             else {
505 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
506              
507             # V
508 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
509 0         0 local $@;
510 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
511 0         0 push @split, CORE::eval('$' . $digit);
512             }
513             }
514             }
515             }
516              
517             elsif ($limit > 0) {
518 0 0       0 if ('' =~ / \A $pattern \z /xms) {
519 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
520 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
521              
522             # V
523 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
524 0         0 local $@;
525 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
526 0         0 push @split, CORE::eval('$' . $digit);
527             }
528             }
529             }
530             }
531             else {
532 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
533 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
534              
535             # V
536 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
537 0         0 local $@;
538 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
539 0         0 push @split, CORE::eval('$' . $digit);
540             }
541             }
542             }
543             }
544             }
545              
546 0 0       0 if (CORE::length($string) > 0) {
547 0         0 push @split, $string;
548             }
549              
550             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
551 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
552 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
553 0         0 pop @split;
554             }
555             }
556              
557             # resulting list value in list context
558 0 0       0 if (wantarray) {
559 0         0 return @split;
560             }
561              
562             # count of substrings in scalar context
563             else {
564 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
565 0         0 @_ = @split;
566 0         0 return scalar @_;
567             }
568             }
569              
570             #
571             # get last subexpression offsets
572             #
573             sub _last_subexpression_offsets {
574 0     0   0 my $pattern = $_[0];
575              
576             # remove comment
577 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
578              
579 0         0 my $modifier = '';
580 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
581 0         0 $modifier = $1;
582 0         0 $modifier =~ s/-[A-Za-z]*//;
583             }
584              
585             # with /x modifier
586 0         0 my @char = ();
587 0 0       0 if ($modifier =~ /x/oxms) {
588 0         0 @char = $pattern =~ /\G((?>
589             [^\\\#\[\(] |
590             \\ $q_char |
591             \# (?>[^\n]*) $ |
592             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
593             \(\? |
594             $q_char
595             ))/oxmsg;
596             }
597              
598             # without /x modifier
599             else {
600 0         0 @char = $pattern =~ /\G((?>
601             [^\\\[\(] |
602             \\ $q_char |
603             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
604             \(\? |
605             $q_char
606             ))/oxmsg;
607             }
608              
609 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
610             }
611              
612             #
613             # Arabic transliteration (tr///)
614             #
615             sub Earabic::tr($$$$;$) {
616              
617 0     0 0 0 my $bind_operator = $_[1];
618 0         0 my $searchlist = $_[2];
619 0         0 my $replacementlist = $_[3];
620 0   0     0 my $modifier = $_[4] || '';
621              
622 0 0       0 if ($modifier =~ /r/oxms) {
623 0 0       0 if ($bind_operator =~ / !~ /oxms) {
624 0         0 croak "Using !~ with tr///r doesn't make sense";
625             }
626             }
627              
628 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
629 0         0 my @searchlist = _charlist_tr($searchlist);
630 0         0 my @replacementlist = _charlist_tr($replacementlist);
631              
632 0         0 my %tr = ();
633 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
634 0 0       0 if (not exists $tr{$searchlist[$i]}) {
635 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
636 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
637             }
638             elsif ($modifier =~ /d/oxms) {
639 0         0 $tr{$searchlist[$i]} = '';
640             }
641             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
642 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
643             }
644             else {
645 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
646             }
647             }
648             }
649              
650 0         0 my $tr = 0;
651 0         0 my $replaced = '';
652 0 0       0 if ($modifier =~ /c/oxms) {
653 0         0 while (defined(my $char = shift @char)) {
654 0 0       0 if (not exists $tr{$char}) {
655 0 0       0 if (defined $replacementlist[0]) {
656 0         0 $replaced .= $replacementlist[0];
657             }
658 0         0 $tr++;
659 0 0       0 if ($modifier =~ /s/oxms) {
660 0   0     0 while (@char and (not exists $tr{$char[0]})) {
661 0         0 shift @char;
662 0         0 $tr++;
663             }
664             }
665             }
666             else {
667 0         0 $replaced .= $char;
668             }
669             }
670             }
671             else {
672 0         0 while (defined(my $char = shift @char)) {
673 0 0       0 if (exists $tr{$char}) {
674 0         0 $replaced .= $tr{$char};
675 0         0 $tr++;
676 0 0       0 if ($modifier =~ /s/oxms) {
677 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
678 0         0 shift @char;
679 0         0 $tr++;
680             }
681             }
682             }
683             else {
684 0         0 $replaced .= $char;
685             }
686             }
687             }
688              
689 0 0       0 if ($modifier =~ /r/oxms) {
690 0         0 return $replaced;
691             }
692             else {
693 0         0 $_[0] = $replaced;
694 0 0       0 if ($bind_operator =~ / !~ /oxms) {
695 0         0 return not $tr;
696             }
697             else {
698 0         0 return $tr;
699             }
700             }
701             }
702              
703             #
704             # Arabic chop
705             #
706             sub Earabic::chop(@) {
707              
708 0     0 0 0 my $chop;
709 0 0       0 if (@_ == 0) {
710 0         0 my @char = /\G (?>$q_char) /oxmsg;
711 0         0 $chop = pop @char;
712 0         0 $_ = join '', @char;
713             }
714             else {
715 0         0 for (@_) {
716 0         0 my @char = /\G (?>$q_char) /oxmsg;
717 0         0 $chop = pop @char;
718 0         0 $_ = join '', @char;
719             }
720             }
721 0         0 return $chop;
722             }
723              
724             #
725             # Arabic index by octet
726             #
727             sub Earabic::index($$;$) {
728              
729 0     0 1 0 my($str,$substr,$position) = @_;
730 0   0     0 $position ||= 0;
731 0         0 my $pos = 0;
732              
733 0         0 while ($pos < CORE::length($str)) {
734 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
735 0 0       0 if ($pos >= $position) {
736 0         0 return $pos;
737             }
738             }
739 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
740 0         0 $pos += CORE::length($1);
741             }
742             else {
743 0         0 $pos += 1;
744             }
745             }
746 0         0 return -1;
747             }
748              
749             #
750             # Arabic reverse index
751             #
752             sub Earabic::rindex($$;$) {
753              
754 0     0 0 0 my($str,$substr,$position) = @_;
755 0   0     0 $position ||= CORE::length($str) - 1;
756 0         0 my $pos = 0;
757 0         0 my $rindex = -1;
758              
759 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
760 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
761 0         0 $rindex = $pos;
762             }
763 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
764 0         0 $pos += CORE::length($1);
765             }
766             else {
767 0         0 $pos += 1;
768             }
769             }
770 0         0 return $rindex;
771             }
772              
773             #
774             # Arabic lower case first with parameter
775             #
776             sub Earabic::lcfirst(@) {
777 0 0   0 0 0 if (@_) {
778 0         0 my $s = shift @_;
779 0 0 0     0 if (@_ and wantarray) {
780 0         0 return Earabic::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
781             }
782             else {
783 0         0 return Earabic::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
784             }
785             }
786             else {
787 0         0 return Earabic::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
788             }
789             }
790              
791             #
792             # Arabic lower case first without parameter
793             #
794             sub Earabic::lcfirst_() {
795 0     0 0 0 return Earabic::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
796             }
797              
798             #
799             # Arabic lower case with parameter
800             #
801             sub Earabic::lc(@) {
802 0 0   0 0 0 if (@_) {
803 0         0 my $s = shift @_;
804 0 0 0     0 if (@_ and wantarray) {
805 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
806             }
807             else {
808 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
809             }
810             }
811             else {
812 0         0 return Earabic::lc_();
813             }
814             }
815              
816             #
817             # Arabic lower case without parameter
818             #
819             sub Earabic::lc_() {
820 0     0 0 0 my $s = $_;
821 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
822             }
823              
824             #
825             # Arabic upper case first with parameter
826             #
827             sub Earabic::ucfirst(@) {
828 0 0   0 0 0 if (@_) {
829 0         0 my $s = shift @_;
830 0 0 0     0 if (@_ and wantarray) {
831 0         0 return Earabic::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
832             }
833             else {
834 0         0 return Earabic::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
835             }
836             }
837             else {
838 0         0 return Earabic::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
839             }
840             }
841              
842             #
843             # Arabic upper case first without parameter
844             #
845             sub Earabic::ucfirst_() {
846 0     0 0 0 return Earabic::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
847             }
848              
849             #
850             # Arabic upper case with parameter
851             #
852             sub Earabic::uc(@) {
853 0 0   0 0 0 if (@_) {
854 0         0 my $s = shift @_;
855 0 0 0     0 if (@_ and wantarray) {
856 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
857             }
858             else {
859 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
860             }
861             }
862             else {
863 0         0 return Earabic::uc_();
864             }
865             }
866              
867             #
868             # Arabic upper case without parameter
869             #
870             sub Earabic::uc_() {
871 0     0 0 0 my $s = $_;
872 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
873             }
874              
875             #
876             # Arabic fold case with parameter
877             #
878             sub Earabic::fc(@) {
879 0 0   0 0 0 if (@_) {
880 0         0 my $s = shift @_;
881 0 0 0     0 if (@_ and wantarray) {
882 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
883             }
884             else {
885 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
886             }
887             }
888             else {
889 0         0 return Earabic::fc_();
890             }
891             }
892              
893             #
894             # Arabic fold case without parameter
895             #
896             sub Earabic::fc_() {
897 0     0 0 0 my $s = $_;
898 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
899             }
900              
901             #
902             # Arabic regexp capture
903             #
904             {
905             sub Earabic::capture {
906 0     0 1 0 return $_[0];
907             }
908             }
909              
910             #
911             # Arabic regexp ignore case modifier
912             #
913             sub Earabic::ignorecase {
914              
915 0     0 0 0 my @string = @_;
916 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
917              
918             # ignore case of $scalar or @array
919 0         0 for my $string (@string) {
920              
921             # split regexp
922 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
923              
924             # unescape character
925 0         0 for (my $i=0; $i <= $#char; $i++) {
926 0 0       0 next if not defined $char[$i];
927              
928             # open character class [...]
929 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
930 0         0 my $left = $i;
931              
932             # [] make die "unmatched [] in regexp ...\n"
933              
934 0 0       0 if ($char[$i+1] eq ']') {
935 0         0 $i++;
936             }
937              
938 0         0 while (1) {
939 0 0       0 if (++$i > $#char) {
940 0         0 croak "Unmatched [] in regexp";
941             }
942 0 0       0 if ($char[$i] eq ']') {
943 0         0 my $right = $i;
944 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
945              
946             # escape character
947 0         0 for my $char (@charlist) {
948 0 0       0 if (0) {
949             }
950              
951 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
952 0         0 $char = '\\' . $char;
953             }
954             }
955              
956             # [...]
957 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
958              
959 0         0 $i = $left;
960 0         0 last;
961             }
962             }
963             }
964              
965             # open character class [^...]
966             elsif ($char[$i] eq '[^') {
967 0         0 my $left = $i;
968              
969             # [^] make die "unmatched [] in regexp ...\n"
970              
971 0 0       0 if ($char[$i+1] eq ']') {
972 0         0 $i++;
973             }
974              
975 0         0 while (1) {
976 0 0       0 if (++$i > $#char) {
977 0         0 croak "Unmatched [] in regexp";
978             }
979 0 0       0 if ($char[$i] eq ']') {
980 0         0 my $right = $i;
981 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
982              
983             # escape character
984 0         0 for my $char (@charlist) {
985 0 0       0 if (0) {
986             }
987              
988 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
989 0         0 $char = '\\' . $char;
990             }
991             }
992              
993             # [^...]
994 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
995              
996 0         0 $i = $left;
997 0         0 last;
998             }
999             }
1000             }
1001              
1002             # rewrite classic character class or escape character
1003             elsif (my $char = classic_character_class($char[$i])) {
1004 0         0 $char[$i] = $char;
1005             }
1006              
1007             # with /i modifier
1008             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1009 0         0 my $uc = Earabic::uc($char[$i]);
1010 0         0 my $fc = Earabic::fc($char[$i]);
1011 0 0       0 if ($uc ne $fc) {
1012 0 0       0 if (CORE::length($fc) == 1) {
1013 0         0 $char[$i] = '[' . $uc . $fc . ']';
1014             }
1015             else {
1016 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1017             }
1018             }
1019             }
1020             }
1021              
1022             # characterize
1023 0         0 for (my $i=0; $i <= $#char; $i++) {
1024 0 0       0 next if not defined $char[$i];
1025              
1026 0 0       0 if (0) {
1027             }
1028              
1029             # quote character before ? + * {
1030 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1031 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1032 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1033             }
1034             }
1035             }
1036              
1037 0         0 $string = join '', @char;
1038             }
1039              
1040             # make regexp string
1041 0         0 return @string;
1042             }
1043              
1044             #
1045             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1046             #
1047             sub Earabic::classic_character_class {
1048 0     0 0 0 my($char) = @_;
1049              
1050             return {
1051 0   0     0 '\D' => '${Earabic::eD}',
1052             '\S' => '${Earabic::eS}',
1053             '\W' => '${Earabic::eW}',
1054             '\d' => '[0-9]',
1055              
1056             # Before Perl 5.6, \s only matched the five whitespace characters
1057             # tab, newline, form-feed, carriage return, and the space character
1058             # itself, which, taken together, is the character class [\t\n\f\r ].
1059              
1060             # Vertical tabs are now whitespace
1061             # \s in a regex now matches a vertical tab in all circumstances.
1062             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1063             # \t \n \v \f \r space
1064             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1065             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1066             '\s' => '\s',
1067              
1068             '\w' => '[0-9A-Z_a-z]',
1069             '\C' => '[\x00-\xFF]',
1070             '\X' => 'X',
1071              
1072             # \h \v \H \V
1073              
1074             # P.114 Character Class Shortcuts
1075             # in Chapter 7: In the World of Regular Expressions
1076             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1077              
1078             # P.357 13.2.3 Whitespace
1079             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1080             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1081             #
1082             # 0x00009 CHARACTER TABULATION h s
1083             # 0x0000a LINE FEED (LF) vs
1084             # 0x0000b LINE TABULATION v
1085             # 0x0000c FORM FEED (FF) vs
1086             # 0x0000d CARRIAGE RETURN (CR) vs
1087             # 0x00020 SPACE h s
1088              
1089             # P.196 Table 5-9. Alphanumeric regex metasymbols
1090             # in Chapter 5. Pattern Matching
1091             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1092              
1093             # (and so on)
1094              
1095             '\H' => '${Earabic::eH}',
1096             '\V' => '${Earabic::eV}',
1097             '\h' => '[\x09\x20]',
1098             '\v' => '[\x0A\x0B\x0C\x0D]',
1099             '\R' => '${Earabic::eR}',
1100              
1101             # \N
1102             #
1103             # http://perldoc.perl.org/perlre.html
1104             # Character Classes and other Special Escapes
1105             # Any character but \n (experimental). Not affected by /s modifier
1106              
1107             '\N' => '${Earabic::eN}',
1108              
1109             # \b \B
1110              
1111             # P.180 Boundaries: The \b and \B Assertions
1112             # in Chapter 5: Pattern Matching
1113             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1114              
1115             # P.219 Boundaries: The \b and \B Assertions
1116             # in Chapter 5: Pattern Matching
1117             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1118              
1119             # \b really means (?:(?<=\w)(?!\w)|(?
1120             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1121             '\b' => '${Earabic::eb}',
1122              
1123             # \B really means (?:(?<=\w)(?=\w)|(?
1124             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1125             '\B' => '${Earabic::eB}',
1126              
1127             }->{$char} || '';
1128             }
1129              
1130             #
1131             # prepare Arabic characters per length
1132             #
1133              
1134             # 1 octet characters
1135             my @chars1 = ();
1136             sub chars1 {
1137 0 0   0 0 0 if (@chars1) {
1138 0         0 return @chars1;
1139             }
1140 0 0       0 if (exists $range_tr{1}) {
1141 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1142 0         0 while (my @range = splice(@ranges,0,1)) {
1143 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1144 0         0 push @chars1, pack 'C', $oct0;
1145             }
1146             }
1147             }
1148 0         0 return @chars1;
1149             }
1150              
1151             # 2 octets characters
1152             my @chars2 = ();
1153             sub chars2 {
1154 0 0   0 0 0 if (@chars2) {
1155 0         0 return @chars2;
1156             }
1157 0 0       0 if (exists $range_tr{2}) {
1158 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1159 0         0 while (my @range = splice(@ranges,0,2)) {
1160 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1161 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1162 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1163             }
1164             }
1165             }
1166             }
1167 0         0 return @chars2;
1168             }
1169              
1170             # 3 octets characters
1171             my @chars3 = ();
1172             sub chars3 {
1173 0 0   0 0 0 if (@chars3) {
1174 0         0 return @chars3;
1175             }
1176 0 0       0 if (exists $range_tr{3}) {
1177 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1178 0         0 while (my @range = splice(@ranges,0,3)) {
1179 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1180 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1181 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1182 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1183             }
1184             }
1185             }
1186             }
1187             }
1188 0         0 return @chars3;
1189             }
1190              
1191             # 4 octets characters
1192             my @chars4 = ();
1193             sub chars4 {
1194 0 0   0 0 0 if (@chars4) {
1195 0         0 return @chars4;
1196             }
1197 0 0       0 if (exists $range_tr{4}) {
1198 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1199 0         0 while (my @range = splice(@ranges,0,4)) {
1200 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1201 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1202 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1203 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1204 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1205             }
1206             }
1207             }
1208             }
1209             }
1210             }
1211 0         0 return @chars4;
1212             }
1213              
1214             #
1215             # Arabic open character list for tr
1216             #
1217             sub _charlist_tr {
1218              
1219 0     0   0 local $_ = shift @_;
1220              
1221             # unescape character
1222 0         0 my @char = ();
1223 0         0 while (not /\G \z/oxmsgc) {
1224 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1225 0         0 push @char, '\-';
1226             }
1227             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1228 0         0 push @char, CORE::chr(oct $1);
1229             }
1230             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1231 0         0 push @char, CORE::chr(hex $1);
1232             }
1233             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1234 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1235             }
1236             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1237 0         0 push @char, {
1238             '\0' => "\0",
1239             '\n' => "\n",
1240             '\r' => "\r",
1241             '\t' => "\t",
1242             '\f' => "\f",
1243             '\b' => "\x08", # \b means backspace in character class
1244             '\a' => "\a",
1245             '\e' => "\e",
1246             }->{$1};
1247             }
1248             elsif (/\G \\ ($q_char) /oxmsgc) {
1249 0         0 push @char, $1;
1250             }
1251             elsif (/\G ($q_char) /oxmsgc) {
1252 0         0 push @char, $1;
1253             }
1254             }
1255              
1256             # join separated multiple-octet
1257 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1258              
1259             # unescape '-'
1260 0         0 my @i = ();
1261 0         0 for my $i (0 .. $#char) {
1262 0 0       0 if ($char[$i] eq '\-') {
    0          
1263 0         0 $char[$i] = '-';
1264             }
1265             elsif ($char[$i] eq '-') {
1266 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1267 0         0 push @i, $i;
1268             }
1269             }
1270             }
1271              
1272             # open character list (reverse for splice)
1273 0         0 for my $i (CORE::reverse @i) {
1274 0         0 my @range = ();
1275              
1276             # range error
1277 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1278 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1279             }
1280              
1281             # range of multiple-octet code
1282 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1283 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1284 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1285             }
1286             elsif (CORE::length($char[$i+1]) == 2) {
1287 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1288 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1289             }
1290             elsif (CORE::length($char[$i+1]) == 3) {
1291 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1292 0         0 push @range, chars2();
1293 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1294             }
1295             elsif (CORE::length($char[$i+1]) == 4) {
1296 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1297 0         0 push @range, chars2();
1298 0         0 push @range, chars3();
1299 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1300             }
1301             else {
1302 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1303             }
1304             }
1305             elsif (CORE::length($char[$i-1]) == 2) {
1306 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1307 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1308             }
1309             elsif (CORE::length($char[$i+1]) == 3) {
1310 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1311 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1312             }
1313             elsif (CORE::length($char[$i+1]) == 4) {
1314 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1315 0         0 push @range, chars3();
1316 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1317             }
1318             else {
1319 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1320             }
1321             }
1322             elsif (CORE::length($char[$i-1]) == 3) {
1323 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1324 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1325             }
1326             elsif (CORE::length($char[$i+1]) == 4) {
1327 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1328 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1329             }
1330             else {
1331 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1332             }
1333             }
1334             elsif (CORE::length($char[$i-1]) == 4) {
1335 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1336 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1337             }
1338             else {
1339 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1340             }
1341             }
1342             else {
1343 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1344             }
1345              
1346 0         0 splice @char, $i-1, 3, @range;
1347             }
1348              
1349 0         0 return @char;
1350             }
1351              
1352             #
1353             # Arabic open character class
1354             #
1355             sub _cc {
1356 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1357 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1358             }
1359             elsif (scalar(@_) == 1) {
1360 0         0 return sprintf('\x%02X',$_[0]);
1361             }
1362             elsif (scalar(@_) == 2) {
1363 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1364 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1365             }
1366             elsif ($_[0] == $_[1]) {
1367 0         0 return sprintf('\x%02X',$_[0]);
1368             }
1369             elsif (($_[0]+1) == $_[1]) {
1370 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1371             }
1372             else {
1373 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1374             }
1375             }
1376             else {
1377 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1378             }
1379             }
1380              
1381             #
1382             # Arabic octet range
1383             #
1384             sub _octets {
1385 0     0   0 my $length = shift @_;
1386              
1387 0 0       0 if ($length == 1) {
1388 0         0 my($a1) = unpack 'C', $_[0];
1389 0         0 my($z1) = unpack 'C', $_[1];
1390              
1391 0 0       0 if ($a1 > $z1) {
1392 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1393             }
1394              
1395 0 0       0 if ($a1 == $z1) {
    0          
1396 0         0 return sprintf('\x%02X',$a1);
1397             }
1398             elsif (($a1+1) == $z1) {
1399 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1400             }
1401             else {
1402 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1403             }
1404             }
1405             else {
1406 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1407             }
1408             }
1409              
1410             #
1411             # Arabic range regexp
1412             #
1413             sub _range_regexp {
1414 0     0   0 my($length,$first,$last) = @_;
1415              
1416 0         0 my @range_regexp = ();
1417 0 0       0 if (not exists $range_tr{$length}) {
1418 0         0 return @range_regexp;
1419             }
1420              
1421 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1422 0         0 while (my @range = splice(@ranges,0,$length)) {
1423 0         0 my $min = '';
1424 0         0 my $max = '';
1425 0         0 for (my $i=0; $i < $length; $i++) {
1426 0         0 $min .= pack 'C', $range[$i][0];
1427 0         0 $max .= pack 'C', $range[$i][-1];
1428             }
1429              
1430             # min___max
1431             # FIRST_____________LAST
1432             # (nothing)
1433              
1434 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1435             }
1436              
1437             # **********
1438             # min_________max
1439             # FIRST_____________LAST
1440             # **********
1441              
1442             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1443 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1444             }
1445              
1446             # **********************
1447             # min________________max
1448             # FIRST_____________LAST
1449             # **********************
1450              
1451             elsif (($min eq $first) and ($max eq $last)) {
1452 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1453             }
1454              
1455             # *********
1456             # min___max
1457             # FIRST_____________LAST
1458             # *********
1459              
1460             elsif (($first le $min) and ($max le $last)) {
1461 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1462             }
1463              
1464             # **********************
1465             # min__________________________max
1466             # FIRST_____________LAST
1467             # **********************
1468              
1469             elsif (($min le $first) and ($last le $max)) {
1470 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1471             }
1472              
1473             # *********
1474             # min________max
1475             # FIRST_____________LAST
1476             # *********
1477              
1478             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1479 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1480             }
1481              
1482             # min___max
1483             # FIRST_____________LAST
1484             # (nothing)
1485              
1486             elsif ($last lt $min) {
1487             }
1488              
1489             else {
1490 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1491             }
1492             }
1493              
1494 0         0 return @range_regexp;
1495             }
1496              
1497             #
1498             # Arabic open character list for qr and not qr
1499             #
1500             sub _charlist {
1501              
1502 0     0   0 my $modifier = pop @_;
1503 0         0 my @char = @_;
1504              
1505 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1506              
1507             # unescape character
1508 0         0 for (my $i=0; $i <= $#char; $i++) {
1509              
1510             # escape - to ...
1511 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1512 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1513 0         0 $char[$i] = '...';
1514             }
1515             }
1516              
1517             # octal escape sequence
1518             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1519 0         0 $char[$i] = octchr($1);
1520             }
1521              
1522             # hexadecimal escape sequence
1523             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1524 0         0 $char[$i] = hexchr($1);
1525             }
1526              
1527             # \b{...} --> b\{...}
1528             # \B{...} --> B\{...}
1529             # \N{CHARNAME} --> N\{CHARNAME}
1530             # \p{PROPERTY} --> p\{PROPERTY}
1531             # \P{PROPERTY} --> P\{PROPERTY}
1532             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1533 0         0 $char[$i] = $1 . '\\' . $2;
1534             }
1535              
1536             # \p, \P, \X --> p, P, X
1537             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1538 0         0 $char[$i] = $1;
1539             }
1540              
1541             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1542 0         0 $char[$i] = CORE::chr oct $1;
1543             }
1544             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1545 0         0 $char[$i] = CORE::chr hex $1;
1546             }
1547             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1548 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1549             }
1550             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1551 0         0 $char[$i] = {
1552             '\0' => "\0",
1553             '\n' => "\n",
1554             '\r' => "\r",
1555             '\t' => "\t",
1556             '\f' => "\f",
1557             '\b' => "\x08", # \b means backspace in character class
1558             '\a' => "\a",
1559             '\e' => "\e",
1560             '\d' => '[0-9]',
1561              
1562             # Vertical tabs are now whitespace
1563             # \s in a regex now matches a vertical tab in all circumstances.
1564             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1565             # \t \n \v \f \r space
1566             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1567             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1568             '\s' => '\s',
1569              
1570             '\w' => '[0-9A-Z_a-z]',
1571             '\D' => '${Earabic::eD}',
1572             '\S' => '${Earabic::eS}',
1573             '\W' => '${Earabic::eW}',
1574              
1575             '\H' => '${Earabic::eH}',
1576             '\V' => '${Earabic::eV}',
1577             '\h' => '[\x09\x20]',
1578             '\v' => '[\x0A\x0B\x0C\x0D]',
1579             '\R' => '${Earabic::eR}',
1580              
1581             }->{$1};
1582             }
1583              
1584             # POSIX-style character classes
1585             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1586 0         0 $char[$i] = {
1587              
1588             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1589             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1590             '[:^lower:]' => '${Earabic::not_lower_i}',
1591             '[:^upper:]' => '${Earabic::not_upper_i}',
1592              
1593             }->{$1};
1594             }
1595             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1596 0         0 $char[$i] = {
1597              
1598             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1599             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1600             '[:ascii:]' => '[\x00-\x7F]',
1601             '[:blank:]' => '[\x09\x20]',
1602             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1603             '[:digit:]' => '[\x30-\x39]',
1604             '[:graph:]' => '[\x21-\x7F]',
1605             '[:lower:]' => '[\x61-\x7A]',
1606             '[:print:]' => '[\x20-\x7F]',
1607             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1608              
1609             # P.174 POSIX-Style Character Classes
1610             # in Chapter 5: Pattern Matching
1611             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1612              
1613             # P.311 11.2.4 Character Classes and other Special Escapes
1614             # in Chapter 11: perlre: Perl regular expressions
1615             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1616              
1617             # P.210 POSIX-Style Character Classes
1618             # in Chapter 5: Pattern Matching
1619             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1620              
1621             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1622              
1623             '[:upper:]' => '[\x41-\x5A]',
1624             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1625             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1626             '[:^alnum:]' => '${Earabic::not_alnum}',
1627             '[:^alpha:]' => '${Earabic::not_alpha}',
1628             '[:^ascii:]' => '${Earabic::not_ascii}',
1629             '[:^blank:]' => '${Earabic::not_blank}',
1630             '[:^cntrl:]' => '${Earabic::not_cntrl}',
1631             '[:^digit:]' => '${Earabic::not_digit}',
1632             '[:^graph:]' => '${Earabic::not_graph}',
1633             '[:^lower:]' => '${Earabic::not_lower}',
1634             '[:^print:]' => '${Earabic::not_print}',
1635             '[:^punct:]' => '${Earabic::not_punct}',
1636             '[:^space:]' => '${Earabic::not_space}',
1637             '[:^upper:]' => '${Earabic::not_upper}',
1638             '[:^word:]' => '${Earabic::not_word}',
1639             '[:^xdigit:]' => '${Earabic::not_xdigit}',
1640              
1641             }->{$1};
1642             }
1643             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1644 0         0 $char[$i] = $1;
1645             }
1646             }
1647              
1648             # open character list
1649 0         0 my @singleoctet = ();
1650 0         0 my @multipleoctet = ();
1651 0         0 for (my $i=0; $i <= $#char; ) {
1652              
1653             # escaped -
1654 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1655 0         0 $i += 1;
1656 0         0 next;
1657             }
1658              
1659             # make range regexp
1660             elsif ($char[$i] eq '...') {
1661              
1662             # range error
1663 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1664 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1665             }
1666             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1667 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1668 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]);
1669             }
1670             }
1671              
1672             # make range regexp per length
1673 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1674 0         0 my @regexp = ();
1675              
1676             # is first and last
1677 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1678 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1679             }
1680              
1681             # is first
1682             elsif ($length == CORE::length($char[$i-1])) {
1683 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1684             }
1685              
1686             # is inside in first and last
1687             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1688 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1689             }
1690              
1691             # is last
1692             elsif ($length == CORE::length($char[$i+1])) {
1693 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1694             }
1695              
1696             else {
1697 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1698             }
1699              
1700 0 0       0 if ($length == 1) {
1701 0         0 push @singleoctet, @regexp;
1702             }
1703             else {
1704 0         0 push @multipleoctet, @regexp;
1705             }
1706             }
1707              
1708 0         0 $i += 2;
1709             }
1710              
1711             # with /i modifier
1712             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1713 0 0       0 if ($modifier =~ /i/oxms) {
1714 0         0 my $uc = Earabic::uc($char[$i]);
1715 0         0 my $fc = Earabic::fc($char[$i]);
1716 0 0       0 if ($uc ne $fc) {
1717 0 0       0 if (CORE::length($fc) == 1) {
1718 0         0 push @singleoctet, $uc, $fc;
1719             }
1720             else {
1721 0         0 push @singleoctet, $uc;
1722 0         0 push @multipleoctet, $fc;
1723             }
1724             }
1725             else {
1726 0         0 push @singleoctet, $char[$i];
1727             }
1728             }
1729             else {
1730 0         0 push @singleoctet, $char[$i];
1731             }
1732 0         0 $i += 1;
1733             }
1734              
1735             # single character of single octet code
1736             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1737 0         0 push @singleoctet, "\t", "\x20";
1738 0         0 $i += 1;
1739             }
1740             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1741 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1742 0         0 $i += 1;
1743             }
1744             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1745 0         0 push @singleoctet, $char[$i];
1746 0         0 $i += 1;
1747             }
1748              
1749             # single character of multiple-octet code
1750             else {
1751 0         0 push @multipleoctet, $char[$i];
1752 0         0 $i += 1;
1753             }
1754             }
1755              
1756             # quote metachar
1757 0         0 for (@singleoctet) {
1758 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1759 0         0 $_ = '-';
1760             }
1761             elsif (/\A \n \z/oxms) {
1762 0         0 $_ = '\n';
1763             }
1764             elsif (/\A \r \z/oxms) {
1765 0         0 $_ = '\r';
1766             }
1767             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1768 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1769             }
1770             elsif (/\A [\x00-\xFF] \z/oxms) {
1771 0         0 $_ = quotemeta $_;
1772             }
1773             }
1774              
1775             # return character list
1776 0         0 return \@singleoctet, \@multipleoctet;
1777             }
1778              
1779             #
1780             # Arabic octal escape sequence
1781             #
1782             sub octchr {
1783 0     0 0 0 my($octdigit) = @_;
1784              
1785 0         0 my @binary = ();
1786 0         0 for my $octal (split(//,$octdigit)) {
1787 0         0 push @binary, {
1788             '0' => '000',
1789             '1' => '001',
1790             '2' => '010',
1791             '3' => '011',
1792             '4' => '100',
1793             '5' => '101',
1794             '6' => '110',
1795             '7' => '111',
1796             }->{$octal};
1797             }
1798 0         0 my $binary = join '', @binary;
1799              
1800 0         0 my $octchr = {
1801             # 1234567
1802             1 => pack('B*', "0000000$binary"),
1803             2 => pack('B*', "000000$binary"),
1804             3 => pack('B*', "00000$binary"),
1805             4 => pack('B*', "0000$binary"),
1806             5 => pack('B*', "000$binary"),
1807             6 => pack('B*', "00$binary"),
1808             7 => pack('B*', "0$binary"),
1809             0 => pack('B*', "$binary"),
1810              
1811             }->{CORE::length($binary) % 8};
1812              
1813 0         0 return $octchr;
1814             }
1815              
1816             #
1817             # Arabic hexadecimal escape sequence
1818             #
1819             sub hexchr {
1820 0     0 0 0 my($hexdigit) = @_;
1821              
1822 0         0 my $hexchr = {
1823             1 => pack('H*', "0$hexdigit"),
1824             0 => pack('H*', "$hexdigit"),
1825              
1826             }->{CORE::length($_[0]) % 2};
1827              
1828 0         0 return $hexchr;
1829             }
1830              
1831             #
1832             # Arabic open character list for qr
1833             #
1834             sub charlist_qr {
1835              
1836 0     0 0 0 my $modifier = pop @_;
1837 0         0 my @char = @_;
1838              
1839 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1840 0         0 my @singleoctet = @$singleoctet;
1841 0         0 my @multipleoctet = @$multipleoctet;
1842              
1843             # return character list
1844 0 0       0 if (scalar(@singleoctet) >= 1) {
1845              
1846             # with /i modifier
1847 0 0       0 if ($modifier =~ m/i/oxms) {
1848 0         0 my %singleoctet_ignorecase = ();
1849 0         0 for (@singleoctet) {
1850 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1851 0         0 for my $ord (hex($1) .. hex($2)) {
1852 0         0 my $char = CORE::chr($ord);
1853 0         0 my $uc = Earabic::uc($char);
1854 0         0 my $fc = Earabic::fc($char);
1855 0 0       0 if ($uc eq $fc) {
1856 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1857             }
1858             else {
1859 0 0       0 if (CORE::length($fc) == 1) {
1860 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1861 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1862             }
1863             else {
1864 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1865 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1866             }
1867             }
1868             }
1869             }
1870 0 0       0 if ($_ ne '') {
1871 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1872             }
1873             }
1874 0         0 my $i = 0;
1875 0         0 my @singleoctet_ignorecase = ();
1876 0         0 for my $ord (0 .. 255) {
1877 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1878 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1879             }
1880             else {
1881 0         0 $i++;
1882             }
1883             }
1884 0         0 @singleoctet = ();
1885 0         0 for my $range (@singleoctet_ignorecase) {
1886 0 0       0 if (ref $range) {
1887 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1888 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1889             }
1890             elsif (scalar(@{$range}) == 2) {
1891 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1892             }
1893             else {
1894 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1895             }
1896             }
1897             }
1898             }
1899              
1900 0         0 my $not_anchor = '';
1901              
1902 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1903             }
1904 0 0       0 if (scalar(@multipleoctet) >= 2) {
1905 0         0 return '(?:' . join('|', @multipleoctet) . ')';
1906             }
1907             else {
1908 0         0 return $multipleoctet[0];
1909             }
1910             }
1911              
1912             #
1913             # Arabic open character list for not qr
1914             #
1915             sub charlist_not_qr {
1916              
1917 0     0 0 0 my $modifier = pop @_;
1918 0         0 my @char = @_;
1919              
1920 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1921 0         0 my @singleoctet = @$singleoctet;
1922 0         0 my @multipleoctet = @$multipleoctet;
1923              
1924             # with /i modifier
1925 0 0       0 if ($modifier =~ m/i/oxms) {
1926 0         0 my %singleoctet_ignorecase = ();
1927 0         0 for (@singleoctet) {
1928 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1929 0         0 for my $ord (hex($1) .. hex($2)) {
1930 0         0 my $char = CORE::chr($ord);
1931 0         0 my $uc = Earabic::uc($char);
1932 0         0 my $fc = Earabic::fc($char);
1933 0 0       0 if ($uc eq $fc) {
1934 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1935             }
1936             else {
1937 0 0       0 if (CORE::length($fc) == 1) {
1938 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1939 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1940             }
1941             else {
1942 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1943 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1944             }
1945             }
1946             }
1947             }
1948 0 0       0 if ($_ ne '') {
1949 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1950             }
1951             }
1952 0         0 my $i = 0;
1953 0         0 my @singleoctet_ignorecase = ();
1954 0         0 for my $ord (0 .. 255) {
1955 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1956 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1957             }
1958             else {
1959 0         0 $i++;
1960             }
1961             }
1962 0         0 @singleoctet = ();
1963 0         0 for my $range (@singleoctet_ignorecase) {
1964 0 0       0 if (ref $range) {
1965 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1966 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1967             }
1968             elsif (scalar(@{$range}) == 2) {
1969 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1970             }
1971             else {
1972 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1973             }
1974             }
1975             }
1976             }
1977              
1978             # return character list
1979 0 0       0 if (scalar(@multipleoctet) >= 1) {
1980 0 0       0 if (scalar(@singleoctet) >= 1) {
1981              
1982             # any character other than multiple-octet and single octet character class
1983 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
1984             }
1985             else {
1986              
1987             # any character other than multiple-octet character class
1988 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
1989             }
1990             }
1991             else {
1992 0 0       0 if (scalar(@singleoctet) >= 1) {
1993              
1994             # any character other than single octet character class
1995 0         0 return '(?:[^' . join('', @singleoctet) . '])';
1996             }
1997             else {
1998              
1999             # any character
2000 0         0 return "(?:$your_char)";
2001             }
2002             }
2003             }
2004              
2005             #
2006             # open file in read mode
2007             #
2008             sub _open_r {
2009 200     200   1343 my(undef,$file) = @_;
2010 200         8257 $file =~ s#\A (\s) #./$1#oxms;
2011 200   33     18371 return CORE::eval(q{open($_[0],'<',$_[1])}) ||
2012             open($_[0],"< $file\0");
2013             }
2014              
2015             #
2016             # open file in write mode
2017             #
2018             sub _open_w {
2019 0     0   0 my(undef,$file) = @_;
2020 0         0 $file =~ s#\A (\s) #./$1#oxms;
2021 0   0     0 return CORE::eval(q{open($_[0],'>',$_[1])}) ||
2022             open($_[0],"> $file\0");
2023             }
2024              
2025             #
2026             # open file in append mode
2027             #
2028             sub _open_a {
2029 0     0   0 my(undef,$file) = @_;
2030 0         0 $file =~ s#\A (\s) #./$1#oxms;
2031 0   0     0 return CORE::eval(q{open($_[0],'>>',$_[1])}) ||
2032             open($_[0],">> $file\0");
2033             }
2034              
2035             #
2036             # safe system
2037             #
2038             sub _systemx {
2039              
2040             # P.707 29.2.33. exec
2041             # in Chapter 29: Functions
2042             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2043             #
2044             # Be aware that in older releases of Perl, exec (and system) did not flush
2045             # your output buffer, so you needed to enable command buffering by setting $|
2046             # on one or more filehandles to avoid lost output in the case of exec, or
2047             # misordererd output in the case of system. This situation was largely remedied
2048             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2049              
2050             # P.855 exec
2051             # in Chapter 27: Functions
2052             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2053             #
2054             # In very old release of Perl (before v5.6), exec (and system) did not flush
2055             # your output buffer, so you needed to enable command buffering by setting $|
2056             # on one or more filehandles to avoid lost output with exec or misordered
2057             # output with system.
2058              
2059 200     200   795 $| = 1;
2060              
2061             # P.565 23.1.2. Cleaning Up Your Environment
2062             # in Chapter 23: Security
2063             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2064              
2065             # P.656 Cleaning Up Your Environment
2066             # in Chapter 20: Security
2067             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2068              
2069             # local $ENV{'PATH'} = '.';
2070 200         2180 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2071              
2072             # P.707 29.2.33. exec
2073             # in Chapter 29: Functions
2074             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2075             #
2076             # As we mentioned earlier, exec treats a discrete list of arguments as an
2077             # indication that it should bypass shell processing. However, there is one
2078             # place where you might still get tripped up. The exec call (and system, too)
2079             # will not distinguish between a single scalar argument and an array containing
2080             # only one element.
2081             #
2082             # @args = ("echo surprise"); # just one element in list
2083             # exec @args # still subject to shell escapes
2084             # or die "exec: $!"; # because @args == 1
2085             #
2086             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2087             # first argument as the pathname, which forces the rest of the arguments to be
2088             # interpreted as a list, even if there is only one of them:
2089             #
2090             # exec { $args[0] } @args # safe even with one-argument list
2091             # or die "can't exec @args: $!";
2092              
2093             # P.855 exec
2094             # in Chapter 27: Functions
2095             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2096             #
2097             # As we mentioned earlier, exec treats a discrete list of arguments as a
2098             # directive to bypass shell processing. However, there is one place where
2099             # you might still get tripped up. The exec call (and system, too) cannot
2100             # distinguish between a single scalar argument and an array containing
2101             # only one element.
2102             #
2103             # @args = ("echo surprise"); # just one element in list
2104             # exec @args # still subject to shell escapes
2105             # || die "exec: $!"; # because @args == 1
2106             #
2107             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2108             # argument as the pathname, which forces the rest of the arguments to be
2109             # interpreted as a list, even if there is only one of them:
2110             #
2111             # exec { $args[0] } @args # safe even with one-argument list
2112             # || die "can't exec @args: $!";
2113              
2114 200         473 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         24786678  
2115             }
2116              
2117             #
2118             # Arabic order to character (with parameter)
2119             #
2120             sub Earabic::chr(;$) {
2121              
2122 0 0   0 0   my $c = @_ ? $_[0] : $_;
2123              
2124 0 0         if ($c == 0x00) {
2125 0           return "\x00";
2126             }
2127             else {
2128 0           my @chr = ();
2129 0           while ($c > 0) {
2130 0           unshift @chr, ($c % 0x100);
2131 0           $c = int($c / 0x100);
2132             }
2133 0           return pack 'C*', @chr;
2134             }
2135             }
2136              
2137             #
2138             # Arabic order to character (without parameter)
2139             #
2140             sub Earabic::chr_() {
2141              
2142 0     0 0   my $c = $_;
2143              
2144 0 0         if ($c == 0x00) {
2145 0           return "\x00";
2146             }
2147             else {
2148 0           my @chr = ();
2149 0           while ($c > 0) {
2150 0           unshift @chr, ($c % 0x100);
2151 0           $c = int($c / 0x100);
2152             }
2153 0           return pack 'C*', @chr;
2154             }
2155             }
2156              
2157             #
2158             # Arabic path globbing (with parameter)
2159             #
2160             sub Earabic::glob($) {
2161              
2162 0 0   0 0   if (wantarray) {
2163 0           my @glob = _DOS_like_glob(@_);
2164 0           for my $glob (@glob) {
2165 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2166             }
2167 0           return @glob;
2168             }
2169             else {
2170 0           my $glob = _DOS_like_glob(@_);
2171 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2172 0           return $glob;
2173             }
2174             }
2175              
2176             #
2177             # Arabic path globbing (without parameter)
2178             #
2179             sub Earabic::glob_() {
2180              
2181 0 0   0 0   if (wantarray) {
2182 0           my @glob = _DOS_like_glob();
2183 0           for my $glob (@glob) {
2184 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2185             }
2186 0           return @glob;
2187             }
2188             else {
2189 0           my $glob = _DOS_like_glob();
2190 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2191 0           return $glob;
2192             }
2193             }
2194              
2195             #
2196             # Arabic path globbing via File::DosGlob 1.10
2197             #
2198             # Often I confuse "_dosglob" and "_doglob".
2199             # So, I renamed "_dosglob" to "_DOS_like_glob".
2200             #
2201             my %iter;
2202             my %entries;
2203             sub _DOS_like_glob {
2204              
2205             # context (keyed by second cxix argument provided by core)
2206 0     0     my($expr,$cxix) = @_;
2207              
2208             # glob without args defaults to $_
2209 0 0         $expr = $_ if not defined $expr;
2210              
2211             # represents the current user's home directory
2212             #
2213             # 7.3. Expanding Tildes in Filenames
2214             # in Chapter 7. File Access
2215             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2216             #
2217             # and File::HomeDir, File::HomeDir::Windows module
2218              
2219             # DOS-like system
2220 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2221 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2222 0           { my_home_MSWin32() }oxmse;
2223             }
2224              
2225             # UNIX-like system
2226             else {
2227 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2228 0 0 0       { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2229             }
2230              
2231             # assume global context if not provided one
2232 0 0         $cxix = '_G_' if not defined $cxix;
2233 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2234              
2235             # if we're just beginning, do it all first
2236 0 0         if ($iter{$cxix} == 0) {
2237 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2238             }
2239              
2240             # chuck it all out, quick or slow
2241 0 0         if (wantarray) {
2242 0           delete $iter{$cxix};
2243 0           return @{delete $entries{$cxix}};
  0            
2244             }
2245             else {
2246 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2247 0           return shift @{$entries{$cxix}};
  0            
2248             }
2249             else {
2250             # return undef for EOL
2251 0           delete $iter{$cxix};
2252 0           delete $entries{$cxix};
2253 0           return undef;
2254             }
2255             }
2256             }
2257              
2258             #
2259             # Arabic path globbing subroutine
2260             #
2261             sub _do_glob {
2262              
2263 0     0     my($cond,@expr) = @_;
2264 0           my @glob = ();
2265 0           my $fix_drive_relative_paths = 0;
2266              
2267             OUTER:
2268 0           for my $expr (@expr) {
2269 0 0         next OUTER if not defined $expr;
2270 0 0         next OUTER if $expr eq '';
2271              
2272 0           my @matched = ();
2273 0           my @globdir = ();
2274 0           my $head = '.';
2275 0           my $pathsep = '/';
2276 0           my $tail;
2277              
2278             # if argument is within quotes strip em and do no globbing
2279 0 0         if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2280 0           $expr = $1;
2281 0 0         if ($cond eq 'd') {
2282 0 0         if (-d $expr) {
2283 0           push @glob, $expr;
2284             }
2285             }
2286             else {
2287 0 0         if (-e $expr) {
2288 0           push @glob, $expr;
2289             }
2290             }
2291 0           next OUTER;
2292             }
2293              
2294             # wildcards with a drive prefix such as h:*.pm must be changed
2295             # to h:./*.pm to expand correctly
2296 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2297 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2298 0           $fix_drive_relative_paths = 1;
2299             }
2300             }
2301              
2302 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2303 0 0         if ($tail eq '') {
2304 0           push @glob, $expr;
2305 0           next OUTER;
2306             }
2307 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2308 0 0         if (@globdir = _do_glob('d', $head)) {
2309 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2310 0           next OUTER;
2311             }
2312             }
2313 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2314 0           $head .= $pathsep;
2315             }
2316 0           $expr = $tail;
2317             }
2318              
2319             # If file component has no wildcards, we can avoid opendir
2320 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2321 0 0         if ($head eq '.') {
2322 0           $head = '';
2323             }
2324 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2325 0           $head .= $pathsep;
2326             }
2327 0           $head .= $expr;
2328 0 0         if ($cond eq 'd') {
2329 0 0         if (-d $head) {
2330 0           push @glob, $head;
2331             }
2332             }
2333             else {
2334 0 0         if (-e $head) {
2335 0           push @glob, $head;
2336             }
2337             }
2338 0           next OUTER;
2339             }
2340 0 0         opendir(*DIR, $head) or next OUTER;
2341 0           my @leaf = readdir DIR;
2342 0           closedir DIR;
2343              
2344 0 0         if ($head eq '.') {
2345 0           $head = '';
2346             }
2347 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2348 0           $head .= $pathsep;
2349             }
2350              
2351 0           my $pattern = '';
2352 0           while ($expr =~ / \G ($q_char) /oxgc) {
2353 0           my $char = $1;
2354              
2355             # 6.9. Matching Shell Globs as Regular Expressions
2356             # in Chapter 6. Pattern Matching
2357             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2358             # (and so on)
2359              
2360 0 0         if ($char eq '*') {
    0          
    0          
2361 0           $pattern .= "(?:$your_char)*",
2362             }
2363             elsif ($char eq '?') {
2364 0           $pattern .= "(?:$your_char)?", # DOS style
2365             # $pattern .= "(?:$your_char)", # UNIX style
2366             }
2367             elsif ((my $fc = Earabic::fc($char)) ne $char) {
2368 0           $pattern .= $fc;
2369             }
2370             else {
2371 0           $pattern .= quotemeta $char;
2372             }
2373             }
2374 0     0     my $matchsub = sub { Earabic::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2375              
2376             # if ($@) {
2377             # print STDERR "$0: $@\n";
2378             # next OUTER;
2379             # }
2380              
2381             INNER:
2382 0           for my $leaf (@leaf) {
2383 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2384 0           next INNER;
2385             }
2386 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2387 0           next INNER;
2388             }
2389              
2390 0 0         if (&$matchsub($leaf)) {
2391 0           push @matched, "$head$leaf";
2392 0           next INNER;
2393             }
2394              
2395             # [DOS compatibility special case]
2396             # Failed, add a trailing dot and try again, but only...
2397              
2398 0 0 0       if (Earabic::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2399             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2400             Earabic::index($pattern,'\\.') != -1 # pattern has a dot.
2401             ) {
2402 0 0         if (&$matchsub("$leaf.")) {
2403 0           push @matched, "$head$leaf";
2404 0           next INNER;
2405             }
2406             }
2407             }
2408 0 0         if (@matched) {
2409 0           push @glob, @matched;
2410             }
2411             }
2412 0 0         if ($fix_drive_relative_paths) {
2413 0           for my $glob (@glob) {
2414 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2415             }
2416             }
2417 0           return @glob;
2418             }
2419              
2420             #
2421             # Arabic parse line
2422             #
2423             sub _parse_line {
2424              
2425 0     0     my($line) = @_;
2426              
2427 0           $line .= ' ';
2428 0           my @piece = ();
2429 0           while ($line =~ /
2430             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2431             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2432             /oxmsg
2433             ) {
2434 0 0         push @piece, defined($1) ? $1 : $2;
2435             }
2436 0           return @piece;
2437             }
2438              
2439             #
2440             # Arabic parse path
2441             #
2442             sub _parse_path {
2443              
2444 0     0     my($path,$pathsep) = @_;
2445              
2446 0           $path .= '/';
2447 0           my @subpath = ();
2448 0           while ($path =~ /
2449             ((?: [^\/\\] )+?) [\/\\]
2450             /oxmsg
2451             ) {
2452 0           push @subpath, $1;
2453             }
2454              
2455 0           my $tail = pop @subpath;
2456 0           my $head = join $pathsep, @subpath;
2457 0           return $head, $tail;
2458             }
2459              
2460             #
2461             # via File::HomeDir::Windows 1.00
2462             #
2463             sub my_home_MSWin32 {
2464              
2465             # A lot of unix people and unix-derived tools rely on
2466             # the ability to overload HOME. We will support it too
2467             # so that they can replace raw HOME calls with File::HomeDir.
2468 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2469 0           return $ENV{'HOME'};
2470             }
2471              
2472             # Do we have a user profile?
2473             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2474 0           return $ENV{'USERPROFILE'};
2475             }
2476              
2477             # Some Windows use something like $ENV{'HOME'}
2478             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2479 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2480             }
2481              
2482 0           return undef;
2483             }
2484              
2485             #
2486             # via File::HomeDir::Unix 1.00
2487             #
2488             sub my_home {
2489 0     0 0   my $home;
2490              
2491 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2492 0           $home = $ENV{'HOME'};
2493             }
2494              
2495             # This is from the original code, but I'm guessing
2496             # it means "login directory" and exists on some Unixes.
2497             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2498 0           $home = $ENV{'LOGDIR'};
2499             }
2500              
2501             ### More-desperate methods
2502              
2503             # Light desperation on any (Unixish) platform
2504             else {
2505 0           $home = CORE::eval q{ (getpwuid($<))[7] };
2506             }
2507              
2508             # On Unix in general, a non-existant home means "no home"
2509             # For example, "nobody"-like users might use /nonexistant
2510 0 0 0       if (defined $home and ! -d($home)) {
2511 0           $home = undef;
2512             }
2513 0           return $home;
2514             }
2515              
2516             #
2517             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2518             #
2519             sub Earabic::PREMATCH {
2520 0     0 0   return $`;
2521             }
2522              
2523             #
2524             # ${^MATCH}, $MATCH, $& the string that matched
2525             #
2526             sub Earabic::MATCH {
2527 0     0 0   return $&;
2528             }
2529              
2530             #
2531             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2532             #
2533             sub Earabic::POSTMATCH {
2534 0     0 0   return $';
2535             }
2536              
2537             #
2538             # Arabic character to order (with parameter)
2539             #
2540             sub Arabic::ord(;$) {
2541              
2542 0 0   0 1   local $_ = shift if @_;
2543              
2544 0 0         if (/\A ($q_char) /oxms) {
2545 0           my @ord = unpack 'C*', $1;
2546 0           my $ord = 0;
2547 0           while (my $o = shift @ord) {
2548 0           $ord = $ord * 0x100 + $o;
2549             }
2550 0           return $ord;
2551             }
2552             else {
2553 0           return CORE::ord $_;
2554             }
2555             }
2556              
2557             #
2558             # Arabic character to order (without parameter)
2559             #
2560             sub Arabic::ord_() {
2561              
2562 0 0   0 0   if (/\A ($q_char) /oxms) {
2563 0           my @ord = unpack 'C*', $1;
2564 0           my $ord = 0;
2565 0           while (my $o = shift @ord) {
2566 0           $ord = $ord * 0x100 + $o;
2567             }
2568 0           return $ord;
2569             }
2570             else {
2571 0           return CORE::ord $_;
2572             }
2573             }
2574              
2575             #
2576             # Arabic reverse
2577             #
2578             sub Arabic::reverse(@) {
2579              
2580 0 0   0 0   if (wantarray) {
2581 0           return CORE::reverse @_;
2582             }
2583             else {
2584              
2585             # One of us once cornered Larry in an elevator and asked him what
2586             # problem he was solving with this, but he looked as far off into
2587             # the distance as he could in an elevator and said, "It seemed like
2588             # a good idea at the time."
2589              
2590 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2591             }
2592             }
2593              
2594             #
2595             # Arabic getc (with parameter, without parameter)
2596             #
2597             sub Arabic::getc(;*@) {
2598              
2599 0     0 0   my($package) = caller;
2600 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2601 0 0 0       croak 'Too many arguments for Arabic::getc' if @_ and not wantarray;
2602              
2603 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2604 0           my $getc = '';
2605 0           for my $length ($length[0] .. $length[-1]) {
2606 0           $getc .= CORE::getc($fh);
2607 0 0         if (exists $range_tr{CORE::length($getc)}) {
2608 0 0         if ($getc =~ /\A ${Earabic::dot_s} \z/oxms) {
2609 0 0         return wantarray ? ($getc,@_) : $getc;
2610             }
2611             }
2612             }
2613 0 0         return wantarray ? ($getc,@_) : $getc;
2614             }
2615              
2616             #
2617             # Arabic length by character
2618             #
2619             sub Arabic::length(;$) {
2620              
2621 0 0   0 1   local $_ = shift if @_;
2622              
2623 0           local @_ = /\G ($q_char) /oxmsg;
2624 0           return scalar @_;
2625             }
2626              
2627             #
2628             # Arabic substr by character
2629             #
2630             BEGIN {
2631              
2632             # P.232 The lvalue Attribute
2633             # in Chapter 6: Subroutines
2634             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2635              
2636             # P.336 The lvalue Attribute
2637             # in Chapter 7: Subroutines
2638             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2639              
2640             # P.144 8.4 Lvalue subroutines
2641             # in Chapter 8: perlsub: Perl subroutines
2642             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2643              
2644 200 50 0 200 1 147435 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            
2645             # vv----------------------*******
2646             sub Arabic::substr($$;$$) %s {
2647              
2648             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2649              
2650             # If the substring is beyond either end of the string, substr() returns the undefined
2651             # value and produces a warning. When used as an lvalue, specifying a substring that
2652             # is entirely outside the string raises an exception.
2653             # http://perldoc.perl.org/functions/substr.html
2654              
2655             # A return with no argument returns the scalar value undef in scalar context,
2656             # an empty list () in list context, and (naturally) nothing at all in void
2657             # context.
2658              
2659             my $offset = $_[1];
2660             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2661             return;
2662             }
2663              
2664             # substr($string,$offset,$length,$replacement)
2665             if (@_ == 4) {
2666             my(undef,undef,$length,$replacement) = @_;
2667             my $substr = join '', splice(@char, $offset, $length, $replacement);
2668             $_[0] = join '', @char;
2669              
2670             # return $substr; this doesn't work, don't say "return"
2671             $substr;
2672             }
2673              
2674             # substr($string,$offset,$length)
2675             elsif (@_ == 3) {
2676             my(undef,undef,$length) = @_;
2677             my $octet_offset = 0;
2678             my $octet_length = 0;
2679             if ($offset == 0) {
2680             $octet_offset = 0;
2681             }
2682             elsif ($offset > 0) {
2683             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2684             }
2685             else {
2686             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2687             }
2688             if ($length == 0) {
2689             $octet_length = 0;
2690             }
2691             elsif ($length > 0) {
2692             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2693             }
2694             else {
2695             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2696             }
2697             CORE::substr($_[0], $octet_offset, $octet_length);
2698             }
2699              
2700             # substr($string,$offset)
2701             else {
2702             my $octet_offset = 0;
2703             if ($offset == 0) {
2704             $octet_offset = 0;
2705             }
2706             elsif ($offset > 0) {
2707             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2708             }
2709             else {
2710             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2711             }
2712             CORE::substr($_[0], $octet_offset);
2713             }
2714             }
2715             END
2716             }
2717              
2718             #
2719             # Arabic index by character
2720             #
2721             sub Arabic::index($$;$) {
2722              
2723 0     0 1   my $index;
2724 0 0         if (@_ == 3) {
2725 0           $index = Earabic::index($_[0], $_[1], CORE::length(Arabic::substr($_[0], 0, $_[2])));
2726             }
2727             else {
2728 0           $index = Earabic::index($_[0], $_[1]);
2729             }
2730              
2731 0 0         if ($index == -1) {
2732 0           return -1;
2733             }
2734             else {
2735 0           return Arabic::length(CORE::substr $_[0], 0, $index);
2736             }
2737             }
2738              
2739             #
2740             # Arabic rindex by character
2741             #
2742             sub Arabic::rindex($$;$) {
2743              
2744 0     0 1   my $rindex;
2745 0 0         if (@_ == 3) {
2746 0           $rindex = Earabic::rindex($_[0], $_[1], CORE::length(Arabic::substr($_[0], 0, $_[2])));
2747             }
2748             else {
2749 0           $rindex = Earabic::rindex($_[0], $_[1]);
2750             }
2751              
2752 0 0         if ($rindex == -1) {
2753 0           return -1;
2754             }
2755             else {
2756 0           return Arabic::length(CORE::substr $_[0], 0, $rindex);
2757             }
2758             }
2759              
2760             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
2761             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2762 200     200   19861 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   2210  
  200         417  
  200         32181  
2763              
2764             # ord() to ord() or Arabic::ord()
2765 200     200   17778 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   1490  
  200         427  
  200         13684  
2766              
2767             # ord to ord or Arabic::ord_
2768 200     200   14694 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   1403  
  200         380  
  200         13455  
2769              
2770             # reverse to reverse or Arabic::reverse
2771 200     200   13663 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   1271  
  200         385  
  200         18340  
2772              
2773             # getc to getc or Arabic::getc
2774 200     200   14235 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   1185  
  200         496  
  200         14089  
2775              
2776             # P.1023 Appendix W.9 Multibyte Anchoring
2777             # of ISBN 1-56592-224-7 CJKV Information Processing
2778              
2779             my $anchor = '';
2780              
2781 200     200   14633 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   1209  
  200         374  
  200         12976869  
2782              
2783             # regexp of nested parens in qqXX
2784              
2785             # P.340 Matching Nested Constructs with Embedded Code
2786             # in Chapter 7: Perl
2787             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2788              
2789             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2790             [^\\()] |
2791             \( (?{$nest++}) |
2792             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2793             \\ [^c] |
2794             \\c[\x40-\x5F] |
2795             [\x00-\xFF]
2796             }xms;
2797              
2798             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2799             [^\\{}] |
2800             \{ (?{$nest++}) |
2801             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2802             \\ [^c] |
2803             \\c[\x40-\x5F] |
2804             [\x00-\xFF]
2805             }xms;
2806              
2807             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2808             [^\\\[\]] |
2809             \[ (?{$nest++}) |
2810             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2811             \\ [^c] |
2812             \\c[\x40-\x5F] |
2813             [\x00-\xFF]
2814             }xms;
2815              
2816             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2817             [^\\<>] |
2818             \< (?{$nest++}) |
2819             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2820             \\ [^c] |
2821             \\c[\x40-\x5F] |
2822             [\x00-\xFF]
2823             }xms;
2824              
2825             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2826             (?: ::)? (?:
2827             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2828             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2829             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2830             ))
2831             }xms;
2832              
2833             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2834             (?: ::)? (?:
2835             (?>[0-9]+) |
2836             [^a-zA-Z_0-9\[\]] |
2837             ^[A-Z] |
2838             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2839             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2840             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2841             ))
2842             }xms;
2843              
2844             my $qq_substr = qr{(?> Char::substr | Arabic::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2845             }xms;
2846              
2847             # regexp of nested parens in qXX
2848             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2849             [^()] |
2850             \( (?{$nest++}) |
2851             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2852             [\x00-\xFF]
2853             }xms;
2854              
2855             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2856             [^\{\}] |
2857             \{ (?{$nest++}) |
2858             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2859             [\x00-\xFF]
2860             }xms;
2861              
2862             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2863             [^\[\]] |
2864             \[ (?{$nest++}) |
2865             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2866             [\x00-\xFF]
2867             }xms;
2868              
2869             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2870             [^<>] |
2871             \< (?{$nest++}) |
2872             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2873             [\x00-\xFF]
2874             }xms;
2875              
2876             my $matched = '';
2877             my $s_matched = '';
2878              
2879             my $tr_variable = ''; # variable of tr///
2880             my $sub_variable = ''; # variable of s///
2881             my $bind_operator = ''; # =~ or !~
2882              
2883             my @heredoc = (); # here document
2884             my @heredoc_delimiter = ();
2885             my $here_script = ''; # here script
2886              
2887             #
2888             # escape Arabic script
2889             #
2890             sub Arabic::escape(;$) {
2891 0 0   0 0   local($_) = $_[0] if @_;
2892              
2893             # P.359 The Study Function
2894             # in Chapter 7: Perl
2895             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2896              
2897 0           study $_; # Yes, I studied study yesterday.
2898              
2899             # while all script
2900              
2901             # 6.14. Matching from Where the Last Pattern Left Off
2902             # in Chapter 6. Pattern Matching
2903             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2904             # (and so on)
2905              
2906             # one member of Tag-team
2907             #
2908             # P.128 Start of match (or end of previous match): \G
2909             # P.130 Advanced Use of \G with Perl
2910             # in Chapter 3: Overview of Regular Expression Features and Flavors
2911             # P.255 Use leading anchors
2912             # P.256 Expose ^ and \G at the front expressions
2913             # in Chapter 6: Crafting an Efficient Expression
2914             # P.315 "Tag-team" matching with /gc
2915             # in Chapter 7: Perl
2916             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2917              
2918 0           my $e_script = '';
2919 0           while (not /\G \z/oxgc) { # member
2920 0           $e_script .= Arabic::escape_token();
2921             }
2922              
2923 0           return $e_script;
2924             }
2925              
2926             #
2927             # escape Arabic token of script
2928             #
2929             sub Arabic::escape_token {
2930              
2931             # \n output here document
2932              
2933 0     0 0   my $ignore_modules = join('|', qw(
2934             utf8
2935             bytes
2936             charnames
2937             I18N::Japanese
2938             I18N::Collate
2939             I18N::JExt
2940             File::DosGlob
2941             Wild
2942             Wildcard
2943             Japanese
2944             ));
2945              
2946             # another member of Tag-team
2947             #
2948             # P.315 "Tag-team" matching with /gc
2949             # in Chapter 7: Perl
2950             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2951              
2952 0 0 0       if (/\G ( \n ) /oxgc) { # another member (and so on)
    0 0        
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
2953 0           my $heredoc = '';
2954 0 0         if (scalar(@heredoc_delimiter) >= 1) {
2955 0           $slash = 'm//';
2956              
2957 0           $heredoc = join '', @heredoc;
2958 0           @heredoc = ();
2959              
2960             # skip here document
2961 0           for my $heredoc_delimiter (@heredoc_delimiter) {
2962 0           /\G .*? \n $heredoc_delimiter \n/xmsgc;
2963             }
2964 0           @heredoc_delimiter = ();
2965              
2966 0           $here_script = '';
2967             }
2968 0           return "\n" . $heredoc;
2969             }
2970              
2971             # ignore space, comment
2972 0           elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
2973              
2974             # if (, elsif (, unless (, while (, until (, given (, and when (
2975              
2976             # given, when
2977              
2978             # P.225 The given Statement
2979             # in Chapter 15: Smart Matching and given-when
2980             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2981              
2982             # P.133 The given Statement
2983             # in Chapter 4: Statements and Declarations
2984             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2985              
2986             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
2987 0           $slash = 'm//';
2988 0           return $1;
2989             }
2990              
2991             # scalar variable ($scalar = ...) =~ tr///;
2992             # scalar variable ($scalar = ...) =~ s///;
2993              
2994             # state
2995              
2996             # P.68 Persistent, Private Variables
2997             # in Chapter 4: Subroutines
2998             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2999              
3000             # P.160 Persistent Lexically Scoped Variables: state
3001             # in Chapter 4: Statements and Declarations
3002             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3003              
3004             # (and so on)
3005              
3006             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
3007 0           my $e_string = e_string($1);
3008              
3009 0 0         if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3010 0           $tr_variable = $e_string . e_string($1);
3011 0           $bind_operator = $2;
3012 0           $slash = 'm//';
3013 0           return '';
3014             }
3015             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3016 0           $sub_variable = $e_string . e_string($1);
3017 0           $bind_operator = $2;
3018 0           $slash = 'm//';
3019 0           return '';
3020             }
3021             else {
3022 0           $slash = 'div';
3023 0           return $e_string;
3024             }
3025             }
3026              
3027             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Earabic::PREMATCH()
3028             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3029 0           $slash = 'div';
3030 0           return q{Earabic::PREMATCH()};
3031             }
3032              
3033             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Earabic::MATCH()
3034             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3035 0           $slash = 'div';
3036 0           return q{Earabic::MATCH()};
3037             }
3038              
3039             # $', ${'} --> $', ${'}
3040             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3041 0           $slash = 'div';
3042 0           return $1;
3043             }
3044              
3045             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Earabic::POSTMATCH()
3046             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3047 0           $slash = 'div';
3048 0           return q{Earabic::POSTMATCH()};
3049             }
3050              
3051             # scalar variable $scalar =~ tr///;
3052             # scalar variable $scalar =~ s///;
3053             # substr() =~ tr///;
3054             # substr() =~ s///;
3055             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3056 0           my $scalar = e_string($1);
3057              
3058 0 0         if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    0          
3059 0           $tr_variable = $scalar;
3060 0           $bind_operator = $1;
3061 0           $slash = 'm//';
3062 0           return '';
3063             }
3064             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3065 0           $sub_variable = $scalar;
3066 0           $bind_operator = $1;
3067 0           $slash = 'm//';
3068 0           return '';
3069             }
3070             else {
3071 0           $slash = 'div';
3072 0           return $scalar;
3073             }
3074             }
3075              
3076             # end of statement
3077             elsif (/\G ( [,;] ) /oxgc) {
3078 0           $slash = 'm//';
3079              
3080             # clear tr/// variable
3081 0           $tr_variable = '';
3082              
3083             # clear s/// variable
3084 0           $sub_variable = '';
3085              
3086 0           $bind_operator = '';
3087              
3088 0           return $1;
3089             }
3090              
3091             # bareword
3092             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3093 0           return $1;
3094             }
3095              
3096             # $0 --> $0
3097             elsif (/\G ( \$ 0 ) /oxmsgc) {
3098 0           $slash = 'div';
3099 0           return $1;
3100             }
3101             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3102 0           $slash = 'div';
3103 0           return $1;
3104             }
3105              
3106             # $$ --> $$
3107             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3108 0           $slash = 'div';
3109 0           return $1;
3110             }
3111              
3112             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3113             # $1, $2, $3 --> $1, $2, $3 otherwise
3114             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3115 0           $slash = 'div';
3116 0           return e_capture($1);
3117             }
3118             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3119 0           $slash = 'div';
3120 0           return e_capture($1);
3121             }
3122              
3123             # $$foo[ ... ] --> $ $foo->[ ... ]
3124             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3125 0           $slash = 'div';
3126 0           return e_capture($1.'->'.$2);
3127             }
3128              
3129             # $$foo{ ... } --> $ $foo->{ ... }
3130             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3131 0           $slash = 'div';
3132 0           return e_capture($1.'->'.$2);
3133             }
3134              
3135             # $$foo
3136             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3137 0           $slash = 'div';
3138 0           return e_capture($1);
3139             }
3140              
3141             # ${ foo }
3142             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3143 0           $slash = 'div';
3144 0           return '${' . $1 . '}';
3145             }
3146              
3147             # ${ ... }
3148             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3149 0           $slash = 'div';
3150 0           return e_capture($1);
3151             }
3152              
3153             # variable or function
3154             # $ @ % & * $ #
3155             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) {
3156 0           $slash = 'div';
3157 0           return $1;
3158             }
3159             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3160             # $ @ # \ ' " / ? ( ) [ ] < >
3161             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3162 0           $slash = 'div';
3163 0           return $1;
3164             }
3165              
3166             # while ()
3167             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3168 0           return $1;
3169             }
3170              
3171             # while () --- glob
3172              
3173             # avoid "Error: Runtime exception" of perl version 5.005_03
3174              
3175             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3176 0           return 'while ($_ = Earabic::glob("' . $1 . '"))';
3177             }
3178              
3179             # while (glob)
3180             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3181 0           return 'while ($_ = Earabic::glob_)';
3182             }
3183              
3184             # while (glob(WILDCARD))
3185             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3186 0           return 'while ($_ = Earabic::glob';
3187             }
3188              
3189             # doit if, doit unless, doit while, doit until, doit for, doit when
3190 0           elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3191              
3192             # subroutines of package Earabic
3193 0           elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0            
3194 0           elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3195 0           elsif (/\G \b Arabic::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0            
3196 0           elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0            
3197 0           elsif (/\G \b Arabic::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Arabic::escape'; }
  0            
3198 0           elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0            
3199 0           elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::chop'; }
  0            
3200 0           elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0            
3201 0           elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0            
3202 0           elsif (/\G \b Arabic::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Arabic::index'; }
  0            
3203 0           elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::index'; }
  0            
3204 0           elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0            
3205 0           elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0            
3206 0           elsif (/\G \b Arabic::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Arabic::rindex'; }
  0            
3207 0           elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::rindex'; }
  0            
3208 0           elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::lc'; }
  0            
3209 0           elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::lcfirst'; }
  0            
3210 0           elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::uc'; }
  0            
3211 0           elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::ucfirst'; }
  0            
3212 0           elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::fc'; }
  0            
3213              
3214             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3215 0           elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0            
3216 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3217 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3218 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3219 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3220 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3221 0           elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0            
3222              
3223 0           elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0            
3224 0           elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3225 0           elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3226 0           elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3227 0           elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3228 0           elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3229 0           elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0            
3230              
3231             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3232 0           { $slash = 'm//'; return "-s $1"; }
  0            
3233 0           elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0            
3234 0           elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0            
3235 0           elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0            
3236              
3237 0           elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3238 0           elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3239 0           elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::chr'; }
  0            
3240 0           elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3241 0           elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0            
3242 0           elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Earabic::glob'; }
  0            
3243 0           elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::lc_'; }
  0            
3244 0           elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::lcfirst_'; }
  0            
3245 0           elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::uc_'; }
  0            
3246 0           elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::ucfirst_'; }
  0            
3247 0           elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::fc_'; }
  0            
3248 0           elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0            
3249              
3250 0           elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0            
3251 0           elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0            
3252 0           elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::chr_'; }
  0            
3253 0           elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0            
3254 0           elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0            
3255 0           elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Earabic::glob_'; }
  0            
3256 0           elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0            
3257 0           elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0            
3258             # split
3259             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3260 0           $slash = 'm//';
3261              
3262 0           my $e = '';
3263 0           while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3264 0           $e .= $1;
3265             }
3266              
3267             # end of split
3268 0 0         if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Earabic::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          
3269              
3270             # split scalar value
3271 0           elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Earabic::split' . $e . e_string($1); }
3272              
3273             # split literal space
3274 0           elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Earabic::split' . $e . qq {qq$1 $2}; }
3275 0           elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Earabic::split' . $e . qq{$1qq$2 $3}; }
3276 0           elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Earabic::split' . $e . qq{$1qq$2 $3}; }
3277 0           elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Earabic::split' . $e . qq{$1qq$2 $3}; }
3278 0           elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Earabic::split' . $e . qq{$1qq$2 $3}; }
3279 0           elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Earabic::split' . $e . qq{$1qq$2 $3}; }
3280 0           elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Earabic::split' . $e . qq {q$1 $2}; }
3281 0           elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Earabic::split' . $e . qq {$1q$2 $3}; }
3282 0           elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Earabic::split' . $e . qq {$1q$2 $3}; }
3283 0           elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Earabic::split' . $e . qq {$1q$2 $3}; }
3284 0           elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Earabic::split' . $e . qq {$1q$2 $3}; }
3285 0           elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Earabic::split' . $e . qq {$1q$2 $3}; }
3286 0           elsif (/\G ' [ ] ' /oxgc) { return 'Earabic::split' . $e . qq {' '}; }
3287 0           elsif (/\G " [ ] " /oxgc) { return 'Earabic::split' . $e . qq {" "}; }
3288              
3289             # split qq//
3290             elsif (/\G \b (qq) \b /oxgc) {
3291 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0            
3292             else {
3293 0           while (not /\G \z/oxgc) {
3294 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3295 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3296 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3297 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3298 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3299 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3300 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3301             }
3302 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3303             }
3304             }
3305              
3306             # split qr//
3307             elsif (/\G \b (qr) \b /oxgc) {
3308 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0            
3309             else {
3310 0           while (not /\G \z/oxgc) {
3311 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3312 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3313 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3314 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3315 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3316 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3317 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3318 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3319             }
3320 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3321             }
3322             }
3323              
3324             # split q//
3325             elsif (/\G \b (q) \b /oxgc) {
3326 0 0         if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0            
3327             else {
3328 0           while (not /\G \z/oxgc) {
3329 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3330 0           elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3331 0           elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3332 0           elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3333 0           elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3334 0           elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3335 0           elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3336             }
3337 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3338             }
3339             }
3340              
3341             # split m//
3342             elsif (/\G \b (m) \b /oxgc) {
3343 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0            
3344             else {
3345 0           while (not /\G \z/oxgc) {
3346 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3347 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3348 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3349 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3350 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3351 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3352 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3353 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3354             }
3355 0           die __FILE__, ": Search pattern not terminated\n";
3356             }
3357             }
3358              
3359             # split ''
3360             elsif (/\G (\') /oxgc) {
3361 0           my $q_string = '';
3362 0           while (not /\G \z/oxgc) {
3363 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3364 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3365 0           elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3366 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3367             }
3368 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3369             }
3370              
3371             # split ""
3372             elsif (/\G (\") /oxgc) {
3373 0           my $qq_string = '';
3374 0           while (not /\G \z/oxgc) {
3375 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3376 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3377 0           elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3378 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3379             }
3380 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3381             }
3382              
3383             # split //
3384             elsif (/\G (\/) /oxgc) {
3385 0           my $regexp = '';
3386 0           while (not /\G \z/oxgc) {
3387 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3388 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3389 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3390 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3391             }
3392 0           die __FILE__, ": Search pattern not terminated\n";
3393             }
3394             }
3395              
3396             # tr/// or y///
3397              
3398             # about [cdsrbB]* (/B modifier)
3399             #
3400             # P.559 appendix C
3401             # of ISBN 4-89052-384-7 Programming perl
3402             # (Japanese title is: Perl puroguramingu)
3403              
3404             elsif (/\G \b ( tr | y ) \b /oxgc) {
3405 0           my $ope = $1;
3406              
3407             # $1 $2 $3 $4 $5 $6
3408 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3409 0           my @tr = ($tr_variable,$2);
3410 0           return e_tr(@tr,'',$4,$6);
3411             }
3412             else {
3413 0           my $e = '';
3414 0           while (not /\G \z/oxgc) {
3415 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3416             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3417 0           my @tr = ($tr_variable,$2);
3418 0           while (not /\G \z/oxgc) {
3419 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3420 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3421 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3422 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3423 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3424 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3425             }
3426 0           die __FILE__, ": Transliteration replacement not terminated\n";
3427             }
3428             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3429 0           my @tr = ($tr_variable,$2);
3430 0           while (not /\G \z/oxgc) {
3431 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3432 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3433 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3434 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3435 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3436 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3437             }
3438 0           die __FILE__, ": Transliteration replacement not terminated\n";
3439             }
3440             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3441 0           my @tr = ($tr_variable,$2);
3442 0           while (not /\G \z/oxgc) {
3443 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3444 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3445 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3446 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3447 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3448 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3449             }
3450 0           die __FILE__, ": Transliteration replacement not terminated\n";
3451             }
3452             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3453 0           my @tr = ($tr_variable,$2);
3454 0           while (not /\G \z/oxgc) {
3455 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3456 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3457 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3458 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3459 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3460 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3461             }
3462 0           die __FILE__, ": Transliteration replacement not terminated\n";
3463             }
3464             # $1 $2 $3 $4 $5 $6
3465             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3466 0           my @tr = ($tr_variable,$2);
3467 0           return e_tr(@tr,'',$4,$6);
3468             }
3469             }
3470 0           die __FILE__, ": Transliteration pattern not terminated\n";
3471             }
3472             }
3473              
3474             # qq//
3475             elsif (/\G \b (qq) \b /oxgc) {
3476 0           my $ope = $1;
3477              
3478             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3479 0 0         if (/\G (\#) /oxgc) { # qq# #
3480 0           my $qq_string = '';
3481 0           while (not /\G \z/oxgc) {
3482 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3483 0           elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3484 0           elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3485 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3486             }
3487 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3488             }
3489              
3490             else {
3491 0           my $e = '';
3492 0           while (not /\G \z/oxgc) {
3493 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3494              
3495             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3496             elsif (/\G (\() /oxgc) { # qq ( )
3497 0           my $qq_string = '';
3498 0           local $nest = 1;
3499 0           while (not /\G \z/oxgc) {
3500 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3501 0           elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3502 0           elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0            
3503             elsif (/\G (\)) /oxgc) {
3504 0 0         if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0            
3505 0           else { $qq_string .= $1; }
3506             }
3507 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3508             }
3509 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3510             }
3511              
3512             # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3513             elsif (/\G (\{) /oxgc) { # qq { }
3514 0           my $qq_string = '';
3515 0           local $nest = 1;
3516 0           while (not /\G \z/oxgc) {
3517 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3518 0           elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3519 0           elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3520             elsif (/\G (\}) /oxgc) {
3521 0 0         if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  0            
3522 0           else { $qq_string .= $1; }
3523             }
3524 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3525             }
3526 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3527             }
3528              
3529             # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3530             elsif (/\G (\[) /oxgc) { # qq [ ]
3531 0           my $qq_string = '';
3532 0           local $nest = 1;
3533 0           while (not /\G \z/oxgc) {
3534 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3535 0           elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3536 0           elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3537             elsif (/\G (\]) /oxgc) {
3538 0 0         if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0            
3539 0           else { $qq_string .= $1; }
3540             }
3541 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3542             }
3543 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3544             }
3545              
3546             # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3547             elsif (/\G (\<) /oxgc) { # qq < >
3548 0           my $qq_string = '';
3549 0           local $nest = 1;
3550 0           while (not /\G \z/oxgc) {
3551 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
    0          
3552 0           elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3553 0           elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0            
3554             elsif (/\G (\>) /oxgc) {
3555 0 0         if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  0            
3556 0           else { $qq_string .= $1; }
3557             }
3558 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3559             }
3560 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3561             }
3562              
3563             # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3564             elsif (/\G (\S) /oxgc) { # qq * *
3565 0           my $delimiter = $1;
3566 0           my $qq_string = '';
3567 0           while (not /\G \z/oxgc) {
3568 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3569 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3570 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3571 0           elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3572             }
3573 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3574             }
3575             }
3576 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3577             }
3578             }
3579              
3580             # qr//
3581             elsif (/\G \b (qr) \b /oxgc) {
3582 0           my $ope = $1;
3583 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3584 0           return e_qr($ope,$1,$3,$2,$4);
3585             }
3586             else {
3587 0           my $e = '';
3588 0           while (not /\G \z/oxgc) {
3589 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3590 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3591 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3592 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3593 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3594 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3595 0           elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3596 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3597             }
3598 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3599             }
3600             }
3601              
3602             # qw//
3603             elsif (/\G \b (qw) \b /oxgc) {
3604 0           my $ope = $1;
3605 0 0         if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3606 0           return e_qw($ope,$1,$3,$2);
3607             }
3608             else {
3609 0           my $e = '';
3610 0           while (not /\G \z/oxgc) {
3611 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3612              
3613 0           elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3614 0           elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3615              
3616 0           elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3617 0           elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3618              
3619 0           elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3620 0           elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3621              
3622 0           elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3623 0           elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3624              
3625 0           elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3626 0           elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3627             }
3628 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3629             }
3630             }
3631              
3632             # qx//
3633             elsif (/\G \b (qx) \b /oxgc) {
3634 0           my $ope = $1;
3635 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3636 0           return e_qq($ope,$1,$3,$2);
3637             }
3638             else {
3639 0           my $e = '';
3640 0           while (not /\G \z/oxgc) {
3641 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
3642 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3643 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3644 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3645 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3646 0           elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3647 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3648             }
3649 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3650             }
3651             }
3652              
3653             # q//
3654             elsif (/\G \b (q) \b /oxgc) {
3655 0           my $ope = $1;
3656              
3657             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3658              
3659             # avoid "Error: Runtime exception" of perl version 5.005_03
3660             # (and so on)
3661              
3662 0 0         if (/\G (\#) /oxgc) { # q# #
3663 0           my $q_string = '';
3664 0           while (not /\G \z/oxgc) {
3665 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3666 0           elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3667 0           elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3668 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3669             }
3670 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3671             }
3672              
3673             else {
3674 0           my $e = '';
3675 0           while (not /\G \z/oxgc) {
3676 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3677              
3678             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3679             elsif (/\G (\() /oxgc) { # q ( )
3680 0           my $q_string = '';
3681 0           local $nest = 1;
3682 0           while (not /\G \z/oxgc) {
3683 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3684 0           elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3685 0           elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3686 0           elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0            
3687             elsif (/\G (\)) /oxgc) {
3688 0 0         if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0            
3689 0           else { $q_string .= $1; }
3690             }
3691 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3692             }
3693 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3694             }
3695              
3696             # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3697             elsif (/\G (\{) /oxgc) { # q { }
3698 0           my $q_string = '';
3699 0           local $nest = 1;
3700 0           while (not /\G \z/oxgc) {
3701 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3702 0           elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3703 0           elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3704 0           elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  0            
3705             elsif (/\G (\}) /oxgc) {
3706 0 0         if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  0            
3707 0           else { $q_string .= $1; }
3708             }
3709 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3710             }
3711 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3712             }
3713              
3714             # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3715             elsif (/\G (\[) /oxgc) { # q [ ]
3716 0           my $q_string = '';
3717 0           local $nest = 1;
3718 0           while (not /\G \z/oxgc) {
3719 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3720 0           elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3721 0           elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3722 0           elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0            
3723             elsif (/\G (\]) /oxgc) {
3724 0 0         if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0            
3725 0           else { $q_string .= $1; }
3726             }
3727 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3728             }
3729 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3730             }
3731              
3732             # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3733             elsif (/\G (\<) /oxgc) { # q < >
3734 0           my $q_string = '';
3735 0           local $nest = 1;
3736 0           while (not /\G \z/oxgc) {
3737 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
    0          
    0          
3738 0           elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3739 0           elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3740 0           elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0            
3741             elsif (/\G (\>) /oxgc) {
3742 0 0         if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  0            
3743 0           else { $q_string .= $1; }
3744             }
3745 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3746             }
3747 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3748             }
3749              
3750             # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3751             elsif (/\G (\S) /oxgc) { # q * *
3752 0           my $delimiter = $1;
3753 0           my $q_string = '';
3754 0           while (not /\G \z/oxgc) {
3755 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3756 0           elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3757 0           elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3758 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3759             }
3760 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3761             }
3762             }
3763 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3764             }
3765             }
3766              
3767             # m//
3768             elsif (/\G \b (m) \b /oxgc) {
3769 0           my $ope = $1;
3770 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3771 0           return e_qr($ope,$1,$3,$2,$4);
3772             }
3773             else {
3774 0           my $e = '';
3775 0           while (not /\G \z/oxgc) {
3776 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3777 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3778 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3779 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3780 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3781 0           elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3782 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3783 0           elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3784 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3785             }
3786 0           die __FILE__, ": Search pattern not terminated\n";
3787             }
3788             }
3789              
3790             # s///
3791              
3792             # about [cegimosxpradlunbB]* (/cg modifier)
3793             #
3794             # P.67 Pattern-Matching Operators
3795             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3796              
3797             elsif (/\G \b (s) \b /oxgc) {
3798 0           my $ope = $1;
3799              
3800             # $1 $2 $3 $4 $5 $6
3801 0 0         if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3802 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3803             }
3804             else {
3805 0           my $e = '';
3806 0           while (not /\G \z/oxgc) {
3807 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3808             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3809 0           my @s = ($1,$2,$3);
3810 0           while (not /\G \z/oxgc) {
3811 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3812             # $1 $2 $3 $4
3813 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3814 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3815 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3816 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3817 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3818 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3819 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3820 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3821 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3822             }
3823 0           die __FILE__, ": Substitution replacement not terminated\n";
3824             }
3825             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3826 0           my @s = ($1,$2,$3);
3827 0           while (not /\G \z/oxgc) {
3828 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3829             # $1 $2 $3 $4
3830 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3831 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3832 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3833 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3834 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3835 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3836 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3837 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3838 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3839             }
3840 0           die __FILE__, ": Substitution replacement not terminated\n";
3841             }
3842             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3843 0           my @s = ($1,$2,$3);
3844 0           while (not /\G \z/oxgc) {
3845 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
3846             # $1 $2 $3 $4
3847 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3848 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3849 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3850 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3851 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3852 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3853 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3854             }
3855 0           die __FILE__, ": Substitution replacement not terminated\n";
3856             }
3857             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3858 0           my @s = ($1,$2,$3);
3859 0           while (not /\G \z/oxgc) {
3860 0 0         if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3861             # $1 $2 $3 $4
3862 0           elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3863 0           elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3864 0           elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3865 0           elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3866 0           elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3867 0           elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3868 0           elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3869 0           elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3870 0           elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3871             }
3872 0           die __FILE__, ": Substitution replacement not terminated\n";
3873             }
3874             # $1 $2 $3 $4 $5 $6
3875             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3876 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3877             }
3878             # $1 $2 $3 $4 $5 $6
3879             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3880 0           return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3881             }
3882             # $1 $2 $3 $4 $5 $6
3883             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3884 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3885             }
3886             # $1 $2 $3 $4 $5 $6
3887             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3888 0           return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3889             }
3890             }
3891 0           die __FILE__, ": Substitution pattern not terminated\n";
3892             }
3893             }
3894              
3895             # require ignore module
3896 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3897 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3898 0           elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3899              
3900             # use strict; --> use strict; no strict qw(refs);
3901 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3902 0           elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3903 0           elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3904              
3905             # use 5.12.0; --> use 5.12.0; no strict qw(refs);
3906             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3907 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      0        
3908 0           return "use $1; no strict qw(refs);";
3909             }
3910             else {
3911 0           return "use $1;";
3912             }
3913             }
3914             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3915 0 0 0       if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
3916 0           return "use $1; no strict qw(refs);";
3917             }
3918             else {
3919 0           return "use $1;";
3920             }
3921             }
3922              
3923             # ignore use module
3924 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3925 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3926 0           elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3927              
3928             # ignore no module
3929 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3930 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3931 0           elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3932              
3933             # use else
3934 0           elsif (/\G \b use \b /oxmsgc) { return "use"; }
3935              
3936             # use else
3937 0           elsif (/\G \b no \b /oxmsgc) { return "no"; }
3938              
3939             # ''
3940             elsif (/\G (?
3941 0           my $q_string = '';
3942 0           while (not /\G \z/oxgc) {
3943 0 0         if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
3944 0           elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
3945 0           elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
3946 0           elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3947             }
3948 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3949             }
3950              
3951             # ""
3952             elsif (/\G (\") /oxgc) {
3953 0           my $qq_string = '';
3954 0           while (not /\G \z/oxgc) {
3955 0 0         if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
3956 0           elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
3957 0           elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
3958 0           elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3959             }
3960 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3961             }
3962              
3963             # ``
3964             elsif (/\G (\`) /oxgc) {
3965 0           my $qx_string = '';
3966 0           while (not /\G \z/oxgc) {
3967 0 0         if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 0          
    0          
    0          
3968 0           elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
3969 0           elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
3970 0           elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
3971             }
3972 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3973             }
3974              
3975             # // --- not divide operator (num / num), not defined-or
3976             elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
3977 0           my $regexp = '';
3978 0           while (not /\G \z/oxgc) {
3979 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3980 0           elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
3981 0           elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
3982 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3983             }
3984 0           die __FILE__, ": Search pattern not terminated\n";
3985             }
3986              
3987             # ?? --- not conditional operator (condition ? then : else)
3988             elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
3989 0           my $regexp = '';
3990 0           while (not /\G \z/oxgc) {
3991 0 0         if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
3992 0           elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
3993 0           elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
3994 0           elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3995             }
3996 0           die __FILE__, ": Search pattern not terminated\n";
3997             }
3998              
3999             # <<>> (a safer ARGV)
4000 0           elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4001              
4002             # << (bit shift) --- not here document
4003 0           elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0            
4004              
4005             # <<'HEREDOC'
4006             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4007 0           $slash = 'm//';
4008 0           my $here_quote = $1;
4009 0           my $delimiter = $2;
4010              
4011             # get here document
4012 0 0         if ($here_script eq '') {
4013 0           $here_script = CORE::substr $_, pos $_;
4014 0           $here_script =~ s/.*?\n//oxm;
4015             }
4016 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4017 0           push @heredoc, $1 . qq{\n$delimiter\n};
4018 0           push @heredoc_delimiter, $delimiter;
4019             }
4020             else {
4021 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4022             }
4023 0           return $here_quote;
4024             }
4025              
4026             # <<\HEREDOC
4027              
4028             # P.66 2.6.6. "Here" Documents
4029             # in Chapter 2: Bits and Pieces
4030             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4031              
4032             # P.73 "Here" Documents
4033             # in Chapter 2: Bits and Pieces
4034             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4035              
4036             elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4037 0           $slash = 'm//';
4038 0           my $here_quote = $1;
4039 0           my $delimiter = $2;
4040              
4041             # get here document
4042 0 0         if ($here_script eq '') {
4043 0           $here_script = CORE::substr $_, pos $_;
4044 0           $here_script =~ s/.*?\n//oxm;
4045             }
4046 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4047 0           push @heredoc, $1 . qq{\n$delimiter\n};
4048 0           push @heredoc_delimiter, $delimiter;
4049             }
4050             else {
4051 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4052             }
4053 0           return $here_quote;
4054             }
4055              
4056             # <<"HEREDOC"
4057             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4058 0           $slash = 'm//';
4059 0           my $here_quote = $1;
4060 0           my $delimiter = $2;
4061              
4062             # get here document
4063 0 0         if ($here_script eq '') {
4064 0           $here_script = CORE::substr $_, pos $_;
4065 0           $here_script =~ s/.*?\n//oxm;
4066             }
4067 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4068 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4069 0           push @heredoc_delimiter, $delimiter;
4070             }
4071             else {
4072 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4073             }
4074 0           return $here_quote;
4075             }
4076              
4077             # <
4078             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4079 0           $slash = 'm//';
4080 0           my $here_quote = $1;
4081 0           my $delimiter = $2;
4082              
4083             # get here document
4084 0 0         if ($here_script eq '') {
4085 0           $here_script = CORE::substr $_, pos $_;
4086 0           $here_script =~ s/.*?\n//oxm;
4087             }
4088 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4089 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4090 0           push @heredoc_delimiter, $delimiter;
4091             }
4092             else {
4093 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4094             }
4095 0           return $here_quote;
4096             }
4097              
4098             # <<`HEREDOC`
4099             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4100 0           $slash = 'm//';
4101 0           my $here_quote = $1;
4102 0           my $delimiter = $2;
4103              
4104             # get here document
4105 0 0         if ($here_script eq '') {
4106 0           $here_script = CORE::substr $_, pos $_;
4107 0           $here_script =~ s/.*?\n//oxm;
4108             }
4109 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4110 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4111 0           push @heredoc_delimiter, $delimiter;
4112             }
4113             else {
4114 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4115             }
4116 0           return $here_quote;
4117             }
4118              
4119             # <<= <=> <= < operator
4120             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4121 0           return $1;
4122             }
4123              
4124             #
4125             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4126 0           return $1;
4127             }
4128              
4129             # --- glob
4130              
4131             # avoid "Error: Runtime exception" of perl version 5.005_03
4132              
4133             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4134 0           return 'Earabic::glob("' . $1 . '")';
4135             }
4136              
4137             # __DATA__
4138 0           elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4139              
4140             # __END__
4141 0           elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4142              
4143             # \cD Control-D
4144              
4145             # P.68 2.6.8. Other Literal Tokens
4146             # in Chapter 2: Bits and Pieces
4147             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4148              
4149             # P.76 Other Literal Tokens
4150             # in Chapter 2: Bits and Pieces
4151             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4152              
4153 0           elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4154              
4155             # \cZ Control-Z
4156 0           elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4157              
4158             # any operator before div
4159             elsif (/\G (
4160             -- | \+\+ |
4161             [\)\}\]]
4162              
4163 0           ) /oxgc) { $slash = 'div'; return $1; }
  0            
4164              
4165             # yada-yada or triple-dot operator
4166             elsif (/\G (
4167             \.\.\.
4168              
4169 0           ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  0            
4170              
4171             # any operator before m//
4172              
4173             # //, //= (defined-or)
4174              
4175             # P.164 Logical Operators
4176             # in Chapter 10: More Control Structures
4177             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4178              
4179             # P.119 C-Style Logical (Short-Circuit) Operators
4180             # in Chapter 3: Unary and Binary Operators
4181             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4182              
4183             # (and so on)
4184              
4185             # ~~
4186              
4187             # P.221 The Smart Match Operator
4188             # in Chapter 15: Smart Matching and given-when
4189             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4190              
4191             # P.112 Smartmatch Operator
4192             # in Chapter 3: Unary and Binary Operators
4193             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4194              
4195             # (and so on)
4196              
4197             elsif (/\G ((?>
4198              
4199             !~~ | !~ | != | ! |
4200             %= | % |
4201             &&= | && | &= | &\.= | &\. | & |
4202             -= | -> | - |
4203             :(?>\s*)= |
4204             : |
4205             <<>> |
4206             <<= | <=> | <= | < |
4207             == | => | =~ | = |
4208             >>= | >> | >= | > |
4209             \*\*= | \*\* | \*= | \* |
4210             \+= | \+ |
4211             \.\. | \.= | \. |
4212             \/\/= | \/\/ |
4213             \/= | \/ |
4214             \? |
4215             \\ |
4216             \^= | \^\.= | \^\. | \^ |
4217             \b x= |
4218             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4219             ~~ | ~\. | ~ |
4220             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4221             \b(?: print )\b |
4222              
4223             [,;\(\{\[]
4224              
4225 0           )) /oxgc) { $slash = 'm//'; return $1; }
  0            
4226              
4227             # other any character
4228 0           elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  0            
4229              
4230             # system error
4231             else {
4232 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4233             }
4234             }
4235              
4236             # escape Arabic string
4237             sub e_string {
4238 0     0 0   my($string) = @_;
4239 0           my $e_string = '';
4240              
4241 0           local $slash = 'm//';
4242              
4243             # P.1024 Appendix W.10 Multibyte Processing
4244             # of ISBN 1-56592-224-7 CJKV Information Processing
4245             # (and so on)
4246              
4247 0           my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4248              
4249             # without { ... }
4250 0 0 0       if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4251 0 0         if ($string !~ /<
4252 0           return $string;
4253             }
4254             }
4255              
4256             E_STRING_LOOP:
4257 0           while ($string !~ /\G \z/oxgc) {
4258 0 0         if (0) {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4259             }
4260              
4261             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Earabic::PREMATCH()]}
4262 0           elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4263 0           $e_string .= q{Earabic::PREMATCH()};
4264 0           $slash = 'div';
4265             }
4266              
4267             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Earabic::MATCH()]}
4268             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4269 0           $e_string .= q{Earabic::MATCH()};
4270 0           $slash = 'div';
4271             }
4272              
4273             # $', ${'} --> $', ${'}
4274             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4275 0           $e_string .= $1;
4276 0           $slash = 'div';
4277             }
4278              
4279             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Earabic::POSTMATCH()]}
4280             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4281 0           $e_string .= q{Earabic::POSTMATCH()};
4282 0           $slash = 'div';
4283             }
4284              
4285             # bareword
4286             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4287 0           $e_string .= $1;
4288 0           $slash = 'div';
4289             }
4290              
4291             # $0 --> $0
4292             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4293 0           $e_string .= $1;
4294 0           $slash = 'div';
4295             }
4296             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4297 0           $e_string .= $1;
4298 0           $slash = 'div';
4299             }
4300              
4301             # $$ --> $$
4302             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4303 0           $e_string .= $1;
4304 0           $slash = 'div';
4305             }
4306              
4307             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4308             # $1, $2, $3 --> $1, $2, $3 otherwise
4309             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4310 0           $e_string .= e_capture($1);
4311 0           $slash = 'div';
4312             }
4313             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4314 0           $e_string .= e_capture($1);
4315 0           $slash = 'div';
4316             }
4317              
4318             # $$foo[ ... ] --> $ $foo->[ ... ]
4319             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4320 0           $e_string .= e_capture($1.'->'.$2);
4321 0           $slash = 'div';
4322             }
4323              
4324             # $$foo{ ... } --> $ $foo->{ ... }
4325             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4326 0           $e_string .= e_capture($1.'->'.$2);
4327 0           $slash = 'div';
4328             }
4329              
4330             # $$foo
4331             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4332 0           $e_string .= e_capture($1);
4333 0           $slash = 'div';
4334             }
4335              
4336             # ${ foo }
4337             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4338 0           $e_string .= '${' . $1 . '}';
4339 0           $slash = 'div';
4340             }
4341              
4342             # ${ ... }
4343             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4344 0           $e_string .= e_capture($1);
4345 0           $slash = 'div';
4346             }
4347              
4348             # variable or function
4349             # $ @ % & * $ #
4350             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) {
4351 0           $e_string .= $1;
4352 0           $slash = 'div';
4353             }
4354             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4355             # $ @ # \ ' " / ? ( ) [ ] < >
4356             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4357 0           $e_string .= $1;
4358 0           $slash = 'div';
4359             }
4360              
4361             # subroutines of package Earabic
4362 0           elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0            
4363 0           elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4364 0           elsif ($string =~ /\G \b Arabic::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0            
4365 0           elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0            
4366 0           elsif ($string =~ /\G \b Arabic::eval \b /oxgc) { $e_string .= 'eval Arabic::escape'; $slash = 'm//'; }
  0            
4367 0           elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0            
4368 0           elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Earabic::chop'; $slash = 'm//'; }
  0            
4369 0           elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0            
4370 0           elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0            
4371 0           elsif ($string =~ /\G \b Arabic::index \b /oxgc) { $e_string .= 'Arabic::index'; $slash = 'm//'; }
  0            
4372 0           elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Earabic::index'; $slash = 'm//'; }
  0            
4373 0           elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0            
4374 0           elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0            
4375 0           elsif ($string =~ /\G \b Arabic::rindex \b /oxgc) { $e_string .= 'Arabic::rindex'; $slash = 'm//'; }
  0            
4376 0           elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Earabic::rindex'; $slash = 'm//'; }
  0            
4377 0           elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::lc'; $slash = 'm//'; }
  0            
4378 0           elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::lcfirst'; $slash = 'm//'; }
  0            
4379 0           elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::uc'; $slash = 'm//'; }
  0            
4380 0           elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::ucfirst'; $slash = 'm//'; }
  0            
4381 0           elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::fc'; $slash = 'm//'; }
  0            
4382              
4383             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4384 0           elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0            
4385 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4386 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4387 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4388 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4389 0           elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0            
4390 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            
4391              
4392 0           elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0            
4393 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4394 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4395 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4396 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4397 0           elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0            
4398 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            
4399              
4400             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4401 0           { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4402 0           elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0            
4403 0           elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0            
4404 0           elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0            
4405              
4406 0           elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4407 0           elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4408 0           elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::chr'; $slash = 'm//'; }
  0            
4409 0           elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4410 0           elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0            
4411 0           elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Earabic::glob'; $slash = 'm//'; }
  0            
4412 0           elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Earabic::lc_'; $slash = 'm//'; }
  0            
4413 0           elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Earabic::lcfirst_'; $slash = 'm//'; }
  0            
4414 0           elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Earabic::uc_'; $slash = 'm//'; }
  0            
4415 0           elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Earabic::ucfirst_'; $slash = 'm//'; }
  0            
4416 0           elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Earabic::fc_'; $slash = 'm//'; }
  0            
4417 0           elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0            
4418              
4419 0           elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0            
4420 0           elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0            
4421 0           elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Earabic::chr_'; $slash = 'm//'; }
  0            
4422 0           elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0            
4423 0           elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0            
4424 0           elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Earabic::glob_'; $slash = 'm//'; }
  0            
4425 0           elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0            
4426 0           elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0            
4427             # split
4428             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4429 0           $slash = 'm//';
4430              
4431 0           my $e = '';
4432 0           while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4433 0           $e .= $1;
4434             }
4435              
4436             # end of split
4437 0 0         if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Earabic::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          
4438              
4439             # split scalar value
4440 0           elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Earabic::split' . $e . e_string($1); next E_STRING_LOOP; }
  0            
4441              
4442             # split literal space
4443 0           elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0            
4444 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Earabic::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4445 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Earabic::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4446 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Earabic::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4447 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Earabic::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4448 0           elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Earabic::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0            
4449 0           elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0            
4450 0           elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4451 0           elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4452 0           elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4453 0           elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4454 0           elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Earabic::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0            
4455 0           elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Earabic::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0            
4456 0           elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Earabic::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0            
4457              
4458             # split qq//
4459             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4460 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            
4461             else {
4462 0           while ($string !~ /\G \z/oxgc) {
4463 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4464 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0            
4465 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0            
4466 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0            
4467 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0            
4468 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0            
4469 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            
4470             }
4471 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4472             }
4473             }
4474              
4475             # split qr//
4476             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4477 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0            
  0            
4478             else {
4479 0           while ($string !~ /\G \z/oxgc) {
4480 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4481 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0            
4482 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0            
4483 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0            
4484 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0            
4485 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0            
4486 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0            
4487 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0            
4488             }
4489 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4490             }
4491             }
4492              
4493             # split q//
4494             elsif ($string =~ /\G \b (q) \b /oxgc) {
4495 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            
4496             else {
4497 0           while ($string !~ /\G \z/oxgc) {
4498 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4499 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0            
4500 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0            
4501 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0            
4502 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0            
4503 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0            
4504 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            
4505             }
4506 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4507             }
4508             }
4509              
4510             # split m//
4511             elsif ($string =~ /\G \b (m) \b /oxgc) {
4512 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0            
  0            
4513             else {
4514 0           while ($string !~ /\G \z/oxgc) {
4515 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
    0          
4516 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0            
4517 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0            
4518 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0            
4519 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0            
4520 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0            
4521 0           elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0            
4522 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0            
4523             }
4524 0           die __FILE__, ": Search pattern not terminated\n";
4525             }
4526             }
4527              
4528             # split ''
4529             elsif ($string =~ /\G (\') /oxgc) {
4530 0           my $q_string = '';
4531 0           while ($string !~ /\G \z/oxgc) {
4532 0 0         if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0          
    0          
    0          
4533 0           elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4534 0           elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0            
4535 0           elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4536             }
4537 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4538             }
4539              
4540             # split ""
4541             elsif ($string =~ /\G (\") /oxgc) {
4542 0           my $qq_string = '';
4543 0           while ($string !~ /\G \z/oxgc) {
4544 0 0         if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0          
    0          
    0          
4545 0           elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4546 0           elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0            
4547 0           elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4548             }
4549 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4550             }
4551              
4552             # split //
4553             elsif ($string =~ /\G (\/) /oxgc) {
4554 0           my $regexp = '';
4555 0           while ($string !~ /\G \z/oxgc) {
4556 0 0         if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0          
    0          
    0          
4557 0           elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4558 0           elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0            
4559 0           elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4560             }
4561 0           die __FILE__, ": Search pattern not terminated\n";
4562             }
4563             }
4564              
4565             # qq//
4566             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4567 0           my $ope = $1;
4568 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4569 0           $e_string .= e_qq($ope,$1,$3,$2);
4570             }
4571             else {
4572 0           my $e = '';
4573 0           while ($string !~ /\G \z/oxgc) {
4574 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4575 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0            
4576 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0            
4577 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0            
4578 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0            
4579 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0            
4580             }
4581 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4582             }
4583             }
4584              
4585             # qx//
4586             elsif ($string =~ /\G \b (qx) \b /oxgc) {
4587 0           my $ope = $1;
4588 0 0         if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4589 0           $e_string .= e_qq($ope,$1,$3,$2);
4590             }
4591             else {
4592 0           my $e = '';
4593 0           while ($string !~ /\G \z/oxgc) {
4594 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
    0          
4595 0           elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0            
4596 0           elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0            
4597 0           elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0            
4598 0           elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0            
4599 0           elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0            
4600 0           elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0            
4601             }
4602 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4603             }
4604             }
4605              
4606             # q//
4607             elsif ($string =~ /\G \b (q) \b /oxgc) {
4608 0           my $ope = $1;
4609 0 0         if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4610 0           $e_string .= e_q($ope,$1,$3,$2);
4611             }
4612             else {
4613 0           my $e = '';
4614 0           while ($string !~ /\G \z/oxgc) {
4615 0 0         if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0          
    0          
    0          
    0          
    0          
4616 0           elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0            
4617 0           elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0            
4618 0           elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0            
4619 0           elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0            
4620 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            
4621             }
4622 0           die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4623             }
4624             }
4625              
4626             # ''
4627 0           elsif ($string =~ /\G (?
4628              
4629             # ""
4630 0           elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4631              
4632             # ``
4633 0           elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4634              
4635             # <<>> (a safer ARGV)
4636 0           elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4637              
4638             # <<= <=> <= < operator
4639 0           elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4640              
4641             #
4642 0           elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4643              
4644             # --- glob
4645             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4646 0           $e_string .= 'Earabic::glob("' . $1 . '")';
4647             }
4648              
4649             # << (bit shift) --- not here document
4650 0           elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4651              
4652             # <<'HEREDOC'
4653             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4654 0           $slash = 'm//';
4655 0           my $here_quote = $1;
4656 0           my $delimiter = $2;
4657              
4658             # get here document
4659 0 0         if ($here_script eq '') {
4660 0           $here_script = CORE::substr $_, pos $_;
4661 0           $here_script =~ s/.*?\n//oxm;
4662             }
4663 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4664 0           push @heredoc, $1 . qq{\n$delimiter\n};
4665 0           push @heredoc_delimiter, $delimiter;
4666             }
4667             else {
4668 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4669             }
4670 0           $e_string .= $here_quote;
4671             }
4672              
4673             # <<\HEREDOC
4674             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4675 0           $slash = 'm//';
4676 0           my $here_quote = $1;
4677 0           my $delimiter = $2;
4678              
4679             # get here document
4680 0 0         if ($here_script eq '') {
4681 0           $here_script = CORE::substr $_, pos $_;
4682 0           $here_script =~ s/.*?\n//oxm;
4683             }
4684 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4685 0           push @heredoc, $1 . qq{\n$delimiter\n};
4686 0           push @heredoc_delimiter, $delimiter;
4687             }
4688             else {
4689 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4690             }
4691 0           $e_string .= $here_quote;
4692             }
4693              
4694             # <<"HEREDOC"
4695             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4696 0           $slash = 'm//';
4697 0           my $here_quote = $1;
4698 0           my $delimiter = $2;
4699              
4700             # get here document
4701 0 0         if ($here_script eq '') {
4702 0           $here_script = CORE::substr $_, pos $_;
4703 0           $here_script =~ s/.*?\n//oxm;
4704             }
4705 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4706 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4707 0           push @heredoc_delimiter, $delimiter;
4708             }
4709             else {
4710 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4711             }
4712 0           $e_string .= $here_quote;
4713             }
4714              
4715             # <
4716             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4717 0           $slash = 'm//';
4718 0           my $here_quote = $1;
4719 0           my $delimiter = $2;
4720              
4721             # get here document
4722 0 0         if ($here_script eq '') {
4723 0           $here_script = CORE::substr $_, pos $_;
4724 0           $here_script =~ s/.*?\n//oxm;
4725             }
4726 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4727 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4728 0           push @heredoc_delimiter, $delimiter;
4729             }
4730             else {
4731 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4732             }
4733 0           $e_string .= $here_quote;
4734             }
4735              
4736             # <<`HEREDOC`
4737             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4738 0           $slash = 'm//';
4739 0           my $here_quote = $1;
4740 0           my $delimiter = $2;
4741              
4742             # get here document
4743 0 0         if ($here_script eq '') {
4744 0           $here_script = CORE::substr $_, pos $_;
4745 0           $here_script =~ s/.*?\n//oxm;
4746             }
4747 0 0         if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4748 0           push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4749 0           push @heredoc_delimiter, $delimiter;
4750             }
4751             else {
4752 0           die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4753             }
4754 0           $e_string .= $here_quote;
4755             }
4756              
4757             # any operator before div
4758             elsif ($string =~ /\G (
4759             -- | \+\+ |
4760             [\)\}\]]
4761              
4762 0           ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  0            
4763              
4764             # yada-yada or triple-dot operator
4765             elsif ($string =~ /\G (
4766             \.\.\.
4767              
4768 0           ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0            
4769              
4770             # any operator before m//
4771             elsif ($string =~ /\G ((?>
4772              
4773             !~~ | !~ | != | ! |
4774             %= | % |
4775             &&= | && | &= | &\.= | &\. | & |
4776             -= | -> | - |
4777             :(?>\s*)= |
4778             : |
4779             <<>> |
4780             <<= | <=> | <= | < |
4781             == | => | =~ | = |
4782             >>= | >> | >= | > |
4783             \*\*= | \*\* | \*= | \* |
4784             \+= | \+ |
4785             \.\. | \.= | \. |
4786             \/\/= | \/\/ |
4787             \/= | \/ |
4788             \? |
4789             \\ |
4790             \^= | \^\.= | \^\. | \^ |
4791             \b x= |
4792             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4793             ~~ | ~\. | ~ |
4794             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4795             \b(?: print )\b |
4796              
4797             [,;\(\{\[]
4798              
4799 0           )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0            
4800              
4801             # other any character
4802 0           elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4803              
4804             # system error
4805             else {
4806 0           die __FILE__, ": Oops, this shouldn't happen!\n";
4807             }
4808             }
4809              
4810 0           return $e_string;
4811             }
4812              
4813             #
4814             # character class
4815             #
4816             sub character_class {
4817 0     0 0   my($char,$modifier) = @_;
4818              
4819 0 0         if ($char eq '.') {
4820 0 0         if ($modifier =~ /s/) {
4821 0           return '${Earabic::dot_s}';
4822             }
4823             else {
4824 0           return '${Earabic::dot}';
4825             }
4826             }
4827             else {
4828 0           return Earabic::classic_character_class($char);
4829             }
4830             }
4831              
4832             #
4833             # escape capture ($1, $2, $3, ...)
4834             #
4835             sub e_capture {
4836              
4837 0     0 0   return join '', '${', $_[0], '}';
4838             }
4839              
4840             #
4841             # escape transliteration (tr/// or y///)
4842             #
4843             sub e_tr {
4844 0     0 0   my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4845 0           my $e_tr = '';
4846 0   0       $modifier ||= '';
4847              
4848 0           $slash = 'div';
4849              
4850             # quote character class 1
4851 0           $charclass = q_tr($charclass);
4852              
4853             # quote character class 2
4854 0           $charclass2 = q_tr($charclass2);
4855              
4856             # /b /B modifier
4857 0 0         if ($modifier =~ tr/bB//d) {
4858 0 0         if ($variable eq '') {
4859 0           $e_tr = qq{tr$charclass$e$charclass2$modifier};
4860             }
4861             else {
4862 0           $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4863             }
4864             }
4865             else {
4866 0 0         if ($variable eq '') {
4867 0           $e_tr = qq{Earabic::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4868             }
4869             else {
4870 0           $e_tr = qq{Earabic::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4871             }
4872             }
4873              
4874             # clear tr/// variable
4875 0           $tr_variable = '';
4876 0           $bind_operator = '';
4877              
4878 0           return $e_tr;
4879             }
4880              
4881             #
4882             # quote for escape transliteration (tr/// or y///)
4883             #
4884             sub q_tr {
4885 0     0 0   my($charclass) = @_;
4886              
4887             # quote character class
4888 0 0         if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4889 0           return e_q('', "'", "'", $charclass); # --> q' '
4890             }
4891             elsif ($charclass !~ /\//oxms) {
4892 0           return e_q('q', '/', '/', $charclass); # --> q/ /
4893             }
4894             elsif ($charclass !~ /\#/oxms) {
4895 0           return e_q('q', '#', '#', $charclass); # --> q# #
4896             }
4897             elsif ($charclass !~ /[\<\>]/oxms) {
4898 0           return e_q('q', '<', '>', $charclass); # --> q< >
4899             }
4900             elsif ($charclass !~ /[\(\)]/oxms) {
4901 0           return e_q('q', '(', ')', $charclass); # --> q( )
4902             }
4903             elsif ($charclass !~ /[\{\}]/oxms) {
4904 0           return e_q('q', '{', '}', $charclass); # --> q{ }
4905             }
4906             else {
4907 0           for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4908 0 0         if ($charclass !~ /\Q$char\E/xms) {
4909 0           return e_q('q', $char, $char, $charclass);
4910             }
4911             }
4912             }
4913              
4914 0           return e_q('q', '{', '}', $charclass);
4915             }
4916              
4917             #
4918             # escape q string (q//, '')
4919             #
4920             sub e_q {
4921 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4922              
4923 0           $slash = 'div';
4924              
4925 0           return join '', $ope, $delimiter, $string, $end_delimiter;
4926             }
4927              
4928             #
4929             # escape qq string (qq//, "", qx//, ``)
4930             #
4931             sub e_qq {
4932 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
4933              
4934 0           $slash = 'div';
4935              
4936 0           my $left_e = 0;
4937 0           my $right_e = 0;
4938              
4939             # split regexp
4940 0           my @char = $string =~ /\G((?>
4941             [^\\\$] |
4942             \\x\{ (?>[0-9A-Fa-f]+) \} |
4943             \\o\{ (?>[0-7]+) \} |
4944             \\N\{ (?>[^0-9\}][^\}]*) \} |
4945             \\ $q_char |
4946             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
4947             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
4948             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
4949             \$ (?>\s* [0-9]+) |
4950             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
4951             \$ \$ (?![\w\{]) |
4952             \$ (?>\s*) \$ (?>\s*) $qq_variable |
4953             $q_char
4954             ))/oxmsg;
4955              
4956 0           for (my $i=0; $i <= $#char; $i++) {
4957              
4958             # "\L\u" --> "\u\L"
4959 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
4960 0           @char[$i,$i+1] = @char[$i+1,$i];
4961             }
4962              
4963             # "\U\l" --> "\l\U"
4964             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
4965 0           @char[$i,$i+1] = @char[$i+1,$i];
4966             }
4967              
4968             # octal escape sequence
4969             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
4970 0           $char[$i] = Earabic::octchr($1);
4971             }
4972              
4973             # hexadecimal escape sequence
4974             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
4975 0           $char[$i] = Earabic::hexchr($1);
4976             }
4977              
4978             # \N{CHARNAME} --> N{CHARNAME}
4979             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4980 0           $char[$i] = $1;
4981             }
4982              
4983 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          
4984             }
4985              
4986             # \F
4987             #
4988             # P.69 Table 2-6. Translation escapes
4989             # in Chapter 2: Bits and Pieces
4990             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4991             # (and so on)
4992              
4993             # \u \l \U \L \F \Q \E
4994 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
4995 0 0         if ($right_e < $left_e) {
4996 0           $char[$i] = '\\' . $char[$i];
4997             }
4998             }
4999             elsif ($char[$i] eq '\u') {
5000              
5001             # "STRING @{[ LIST EXPR ]} MORE STRING"
5002              
5003             # P.257 Other Tricks You Can Do with Hard References
5004             # in Chapter 8: References
5005             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5006              
5007             # P.353 Other Tricks You Can Do with Hard References
5008             # in Chapter 8: References
5009             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5010              
5011             # (and so on)
5012              
5013 0           $char[$i] = '@{[Earabic::ucfirst qq<';
5014 0           $left_e++;
5015             }
5016             elsif ($char[$i] eq '\l') {
5017 0           $char[$i] = '@{[Earabic::lcfirst qq<';
5018 0           $left_e++;
5019             }
5020             elsif ($char[$i] eq '\U') {
5021 0           $char[$i] = '@{[Earabic::uc qq<';
5022 0           $left_e++;
5023             }
5024             elsif ($char[$i] eq '\L') {
5025 0           $char[$i] = '@{[Earabic::lc qq<';
5026 0           $left_e++;
5027             }
5028             elsif ($char[$i] eq '\F') {
5029 0           $char[$i] = '@{[Earabic::fc qq<';
5030 0           $left_e++;
5031             }
5032             elsif ($char[$i] eq '\Q') {
5033 0           $char[$i] = '@{[CORE::quotemeta qq<';
5034 0           $left_e++;
5035             }
5036             elsif ($char[$i] eq '\E') {
5037 0 0         if ($right_e < $left_e) {
5038 0           $char[$i] = '>]}';
5039 0           $right_e++;
5040             }
5041             else {
5042 0           $char[$i] = '';
5043             }
5044             }
5045             elsif ($char[$i] eq '\Q') {
5046 0           while (1) {
5047 0 0         if (++$i > $#char) {
5048 0           last;
5049             }
5050 0 0         if ($char[$i] eq '\E') {
5051 0           last;
5052             }
5053             }
5054             }
5055             elsif ($char[$i] eq '\E') {
5056             }
5057              
5058             # $0 --> $0
5059             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5060             }
5061             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5062             }
5063              
5064             # $$ --> $$
5065             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5066             }
5067              
5068             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5069             # $1, $2, $3 --> $1, $2, $3 otherwise
5070             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5071 0           $char[$i] = e_capture($1);
5072             }
5073             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5074 0           $char[$i] = e_capture($1);
5075             }
5076              
5077             # $$foo[ ... ] --> $ $foo->[ ... ]
5078             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5079 0           $char[$i] = e_capture($1.'->'.$2);
5080             }
5081              
5082             # $$foo{ ... } --> $ $foo->{ ... }
5083             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5084 0           $char[$i] = e_capture($1.'->'.$2);
5085             }
5086              
5087             # $$foo
5088             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5089 0           $char[$i] = e_capture($1);
5090             }
5091              
5092             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Earabic::PREMATCH()
5093             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5094 0           $char[$i] = '@{[Earabic::PREMATCH()]}';
5095             }
5096              
5097             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Earabic::MATCH()
5098             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5099 0           $char[$i] = '@{[Earabic::MATCH()]}';
5100             }
5101              
5102             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Earabic::POSTMATCH()
5103             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5104 0           $char[$i] = '@{[Earabic::POSTMATCH()]}';
5105             }
5106              
5107             # ${ foo } --> ${ foo }
5108             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5109             }
5110              
5111             # ${ ... }
5112             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5113 0           $char[$i] = e_capture($1);
5114             }
5115             }
5116              
5117             # return string
5118 0 0         if ($left_e > $right_e) {
5119 0           return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5120             }
5121 0           return join '', $ope, $delimiter, @char, $end_delimiter;
5122             }
5123              
5124             #
5125             # escape qw string (qw//)
5126             #
5127             sub e_qw {
5128 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
5129              
5130 0           $slash = 'div';
5131              
5132             # choice again delimiter
5133 0           my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5134 0 0         if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5135 0           return join '', $ope, $delimiter, $string, $end_delimiter;
5136             }
5137             elsif (not $octet{')'}) {
5138 0           return join '', $ope, '(', $string, ')';
5139             }
5140             elsif (not $octet{'}'}) {
5141 0           return join '', $ope, '{', $string, '}';
5142             }
5143             elsif (not $octet{']'}) {
5144 0           return join '', $ope, '[', $string, ']';
5145             }
5146             elsif (not $octet{'>'}) {
5147 0           return join '', $ope, '<', $string, '>';
5148             }
5149             else {
5150 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5151 0 0         if (not $octet{$char}) {
5152 0           return join '', $ope, $char, $string, $char;
5153             }
5154             }
5155             }
5156              
5157             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5158 0           my @string = CORE::split(/\s+/, $string);
5159 0           for my $string (@string) {
5160 0           my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5161 0           for my $octet (@octet) {
5162 0 0         if ($octet =~ /\A (['\\]) \z/oxms) {
5163 0           $octet = '\\' . $1;
5164             }
5165             }
5166 0           $string = join '', @octet;
5167             }
5168 0           return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0            
5169             }
5170              
5171             #
5172             # escape here document (<<"HEREDOC", <
5173             #
5174             sub e_heredoc {
5175 0     0 0   my($string) = @_;
5176              
5177 0           $slash = 'm//';
5178              
5179 0           my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5180              
5181 0           my $left_e = 0;
5182 0           my $right_e = 0;
5183              
5184             # split regexp
5185 0           my @char = $string =~ /\G((?>
5186             [^\\\$] |
5187             \\x\{ (?>[0-9A-Fa-f]+) \} |
5188             \\o\{ (?>[0-7]+) \} |
5189             \\N\{ (?>[^0-9\}][^\}]*) \} |
5190             \\ $q_char |
5191             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5192             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5193             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5194             \$ (?>\s* [0-9]+) |
5195             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5196             \$ \$ (?![\w\{]) |
5197             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5198             $q_char
5199             ))/oxmsg;
5200              
5201 0           for (my $i=0; $i <= $#char; $i++) {
5202              
5203             # "\L\u" --> "\u\L"
5204 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
5205 0           @char[$i,$i+1] = @char[$i+1,$i];
5206             }
5207              
5208             # "\U\l" --> "\l\U"
5209             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5210 0           @char[$i,$i+1] = @char[$i+1,$i];
5211             }
5212              
5213             # octal escape sequence
5214             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5215 0           $char[$i] = Earabic::octchr($1);
5216             }
5217              
5218             # hexadecimal escape sequence
5219             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5220 0           $char[$i] = Earabic::hexchr($1);
5221             }
5222              
5223             # \N{CHARNAME} --> N{CHARNAME}
5224             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5225 0           $char[$i] = $1;
5226             }
5227              
5228 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          
5229             }
5230              
5231             # \u \l \U \L \F \Q \E
5232 0           elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5233 0 0         if ($right_e < $left_e) {
5234 0           $char[$i] = '\\' . $char[$i];
5235             }
5236             }
5237             elsif ($char[$i] eq '\u') {
5238 0           $char[$i] = '@{[Earabic::ucfirst qq<';
5239 0           $left_e++;
5240             }
5241             elsif ($char[$i] eq '\l') {
5242 0           $char[$i] = '@{[Earabic::lcfirst qq<';
5243 0           $left_e++;
5244             }
5245             elsif ($char[$i] eq '\U') {
5246 0           $char[$i] = '@{[Earabic::uc qq<';
5247 0           $left_e++;
5248             }
5249             elsif ($char[$i] eq '\L') {
5250 0           $char[$i] = '@{[Earabic::lc qq<';
5251 0           $left_e++;
5252             }
5253             elsif ($char[$i] eq '\F') {
5254 0           $char[$i] = '@{[Earabic::fc qq<';
5255 0           $left_e++;
5256             }
5257             elsif ($char[$i] eq '\Q') {
5258 0           $char[$i] = '@{[CORE::quotemeta qq<';
5259 0           $left_e++;
5260             }
5261             elsif ($char[$i] eq '\E') {
5262 0 0         if ($right_e < $left_e) {
5263 0           $char[$i] = '>]}';
5264 0           $right_e++;
5265             }
5266             else {
5267 0           $char[$i] = '';
5268             }
5269             }
5270             elsif ($char[$i] eq '\Q') {
5271 0           while (1) {
5272 0 0         if (++$i > $#char) {
5273 0           last;
5274             }
5275 0 0         if ($char[$i] eq '\E') {
5276 0           last;
5277             }
5278             }
5279             }
5280             elsif ($char[$i] eq '\E') {
5281             }
5282              
5283             # $0 --> $0
5284             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5285             }
5286             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5287             }
5288              
5289             # $$ --> $$
5290             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5291             }
5292              
5293             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5294             # $1, $2, $3 --> $1, $2, $3 otherwise
5295             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5296 0           $char[$i] = e_capture($1);
5297             }
5298             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5299 0           $char[$i] = e_capture($1);
5300             }
5301              
5302             # $$foo[ ... ] --> $ $foo->[ ... ]
5303             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5304 0           $char[$i] = e_capture($1.'->'.$2);
5305             }
5306              
5307             # $$foo{ ... } --> $ $foo->{ ... }
5308             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5309 0           $char[$i] = e_capture($1.'->'.$2);
5310             }
5311              
5312             # $$foo
5313             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5314 0           $char[$i] = e_capture($1);
5315             }
5316              
5317             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Earabic::PREMATCH()
5318             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5319 0           $char[$i] = '@{[Earabic::PREMATCH()]}';
5320             }
5321              
5322             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Earabic::MATCH()
5323             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5324 0           $char[$i] = '@{[Earabic::MATCH()]}';
5325             }
5326              
5327             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Earabic::POSTMATCH()
5328             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5329 0           $char[$i] = '@{[Earabic::POSTMATCH()]}';
5330             }
5331              
5332             # ${ foo } --> ${ foo }
5333             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5334             }
5335              
5336             # ${ ... }
5337             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5338 0           $char[$i] = e_capture($1);
5339             }
5340             }
5341              
5342             # return string
5343 0 0         if ($left_e > $right_e) {
5344 0           return join '', @char, '>]}' x ($left_e - $right_e);
5345             }
5346 0           return join '', @char;
5347             }
5348              
5349             #
5350             # escape regexp (m//, qr//)
5351             #
5352             sub e_qr {
5353 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5354 0   0       $modifier ||= '';
5355              
5356 0           $modifier =~ tr/p//d;
5357 0 0         if ($modifier =~ /([adlu])/oxms) {
5358 0           my $line = 0;
5359 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5360 0 0         if ($filename ne __FILE__) {
5361 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5362 0           last;
5363             }
5364             }
5365 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5366             }
5367              
5368 0           $slash = 'div';
5369              
5370             # literal null string pattern
5371 0 0         if ($string eq '') {
    0          
5372 0           $modifier =~ tr/bB//d;
5373 0           $modifier =~ tr/i//d;
5374 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5375             }
5376              
5377             # /b /B modifier
5378             elsif ($modifier =~ tr/bB//d) {
5379              
5380             # choice again delimiter
5381 0 0         if ($delimiter =~ / [\@:] /oxms) {
5382 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5383 0           my %octet = map {$_ => 1} @char;
  0            
5384 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5385 0           $delimiter = '(';
5386 0           $end_delimiter = ')';
5387             }
5388             elsif (not $octet{'}'}) {
5389 0           $delimiter = '{';
5390 0           $end_delimiter = '}';
5391             }
5392             elsif (not $octet{']'}) {
5393 0           $delimiter = '[';
5394 0           $end_delimiter = ']';
5395             }
5396             elsif (not $octet{'>'}) {
5397 0           $delimiter = '<';
5398 0           $end_delimiter = '>';
5399             }
5400             else {
5401 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5402 0 0         if (not $octet{$char}) {
5403 0           $delimiter = $char;
5404 0           $end_delimiter = $char;
5405 0           last;
5406             }
5407             }
5408             }
5409             }
5410              
5411 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5412 0           return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5413             }
5414             else {
5415 0           return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5416             }
5417             }
5418              
5419 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5420 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
5421              
5422             # split regexp
5423 0           my @char = $string =~ /\G((?>
5424             [^\\\$\@\[\(] |
5425             \\x (?>[0-9A-Fa-f]{1,2}) |
5426             \\ (?>[0-7]{2,3}) |
5427             \\c [\x40-\x5F] |
5428             \\x\{ (?>[0-9A-Fa-f]+) \} |
5429             \\o\{ (?>[0-7]+) \} |
5430             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5431             \\ $q_char |
5432             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5433             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5434             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5435             [\$\@] $qq_variable |
5436             \$ (?>\s* [0-9]+) |
5437             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5438             \$ \$ (?![\w\{]) |
5439             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5440             \[\^ |
5441             \[\: (?>[a-z]+) :\] |
5442             \[\:\^ (?>[a-z]+) :\] |
5443             \(\? |
5444             $q_char
5445             ))/oxmsg;
5446              
5447             # choice again delimiter
5448 0 0         if ($delimiter =~ / [\@:] /oxms) {
5449 0           my %octet = map {$_ => 1} @char;
  0            
5450 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
5451 0           $delimiter = '(';
5452 0           $end_delimiter = ')';
5453             }
5454             elsif (not $octet{'}'}) {
5455 0           $delimiter = '{';
5456 0           $end_delimiter = '}';
5457             }
5458             elsif (not $octet{']'}) {
5459 0           $delimiter = '[';
5460 0           $end_delimiter = ']';
5461             }
5462             elsif (not $octet{'>'}) {
5463 0           $delimiter = '<';
5464 0           $end_delimiter = '>';
5465             }
5466             else {
5467 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5468 0 0         if (not $octet{$char}) {
5469 0           $delimiter = $char;
5470 0           $end_delimiter = $char;
5471 0           last;
5472             }
5473             }
5474             }
5475             }
5476              
5477 0           my $left_e = 0;
5478 0           my $right_e = 0;
5479 0           for (my $i=0; $i <= $#char; $i++) {
5480              
5481             # "\L\u" --> "\u\L"
5482 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
5483 0           @char[$i,$i+1] = @char[$i+1,$i];
5484             }
5485              
5486             # "\U\l" --> "\l\U"
5487             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5488 0           @char[$i,$i+1] = @char[$i+1,$i];
5489             }
5490              
5491             # octal escape sequence
5492             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5493 0           $char[$i] = Earabic::octchr($1);
5494             }
5495              
5496             # hexadecimal escape sequence
5497             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5498 0           $char[$i] = Earabic::hexchr($1);
5499             }
5500              
5501             # \b{...} --> b\{...}
5502             # \B{...} --> B\{...}
5503             # \N{CHARNAME} --> N\{CHARNAME}
5504             # \p{PROPERTY} --> p\{PROPERTY}
5505             # \P{PROPERTY} --> P\{PROPERTY}
5506             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5507 0           $char[$i] = $1 . '\\' . $2;
5508             }
5509              
5510             # \p, \P, \X --> p, P, X
5511             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5512 0           $char[$i] = $1;
5513             }
5514              
5515 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          
5516             }
5517              
5518             # join separated multiple-octet
5519 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5520 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        
5521 0           $char[$i] .= join '', splice @char, $i+1, 3;
5522             }
5523             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)) {
5524 0           $char[$i] .= join '', splice @char, $i+1, 2;
5525             }
5526             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)) {
5527 0           $char[$i] .= join '', splice @char, $i+1, 1;
5528             }
5529             }
5530              
5531             # open character class [...]
5532             elsif ($char[$i] eq '[') {
5533 0           my $left = $i;
5534              
5535             # [] make die "Unmatched [] in regexp ...\n"
5536             # (and so on)
5537              
5538 0 0         if ($char[$i+1] eq ']') {
5539 0           $i++;
5540             }
5541              
5542 0           while (1) {
5543 0 0         if (++$i > $#char) {
5544 0           die __FILE__, ": Unmatched [] in regexp\n";
5545             }
5546 0 0         if ($char[$i] eq ']') {
5547 0           my $right = $i;
5548              
5549             # [...]
5550 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5551 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Earabic::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5552             }
5553             else {
5554 0           splice @char, $left, $right-$left+1, Earabic::charlist_qr(@char[$left+1..$right-1], $modifier);
5555             }
5556              
5557 0           $i = $left;
5558 0           last;
5559             }
5560             }
5561             }
5562              
5563             # open character class [^...]
5564             elsif ($char[$i] eq '[^') {
5565 0           my $left = $i;
5566              
5567             # [^] make die "Unmatched [] in regexp ...\n"
5568             # (and so on)
5569              
5570 0 0         if ($char[$i+1] eq ']') {
5571 0           $i++;
5572             }
5573              
5574 0           while (1) {
5575 0 0         if (++$i > $#char) {
5576 0           die __FILE__, ": Unmatched [] in regexp\n";
5577             }
5578 0 0         if ($char[$i] eq ']') {
5579 0           my $right = $i;
5580              
5581             # [^...]
5582 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5583 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Earabic::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
5584             }
5585             else {
5586 0           splice @char, $left, $right-$left+1, Earabic::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5587             }
5588              
5589 0           $i = $left;
5590 0           last;
5591             }
5592             }
5593             }
5594              
5595             # rewrite character class or escape character
5596             elsif (my $char = character_class($char[$i],$modifier)) {
5597 0           $char[$i] = $char;
5598             }
5599              
5600             # /i modifier
5601             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Earabic::uc($char[$i]) ne Earabic::fc($char[$i]))) {
5602 0 0         if (CORE::length(Earabic::fc($char[$i])) == 1) {
5603 0           $char[$i] = '[' . Earabic::uc($char[$i]) . Earabic::fc($char[$i]) . ']';
5604             }
5605             else {
5606 0           $char[$i] = '(?:' . Earabic::uc($char[$i]) . '|' . Earabic::fc($char[$i]) . ')';
5607             }
5608             }
5609              
5610             # \u \l \U \L \F \Q \E
5611             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5612 0 0         if ($right_e < $left_e) {
5613 0           $char[$i] = '\\' . $char[$i];
5614             }
5615             }
5616             elsif ($char[$i] eq '\u') {
5617 0           $char[$i] = '@{[Earabic::ucfirst qq<';
5618 0           $left_e++;
5619             }
5620             elsif ($char[$i] eq '\l') {
5621 0           $char[$i] = '@{[Earabic::lcfirst qq<';
5622 0           $left_e++;
5623             }
5624             elsif ($char[$i] eq '\U') {
5625 0           $char[$i] = '@{[Earabic::uc qq<';
5626 0           $left_e++;
5627             }
5628             elsif ($char[$i] eq '\L') {
5629 0           $char[$i] = '@{[Earabic::lc qq<';
5630 0           $left_e++;
5631             }
5632             elsif ($char[$i] eq '\F') {
5633 0           $char[$i] = '@{[Earabic::fc qq<';
5634 0           $left_e++;
5635             }
5636             elsif ($char[$i] eq '\Q') {
5637 0           $char[$i] = '@{[CORE::quotemeta qq<';
5638 0           $left_e++;
5639             }
5640             elsif ($char[$i] eq '\E') {
5641 0 0         if ($right_e < $left_e) {
5642 0           $char[$i] = '>]}';
5643 0           $right_e++;
5644             }
5645             else {
5646 0           $char[$i] = '';
5647             }
5648             }
5649             elsif ($char[$i] eq '\Q') {
5650 0           while (1) {
5651 0 0         if (++$i > $#char) {
5652 0           last;
5653             }
5654 0 0         if ($char[$i] eq '\E') {
5655 0           last;
5656             }
5657             }
5658             }
5659             elsif ($char[$i] eq '\E') {
5660             }
5661              
5662             # $0 --> $0
5663             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5664 0 0         if ($ignorecase) {
5665 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5666             }
5667             }
5668             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5669 0 0         if ($ignorecase) {
5670 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5671             }
5672             }
5673              
5674             # $$ --> $$
5675             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5676             }
5677              
5678             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5679             # $1, $2, $3 --> $1, $2, $3 otherwise
5680             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5681 0           $char[$i] = e_capture($1);
5682 0 0         if ($ignorecase) {
5683 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5684             }
5685             }
5686             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5687 0           $char[$i] = e_capture($1);
5688 0 0         if ($ignorecase) {
5689 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5690             }
5691             }
5692              
5693             # $$foo[ ... ] --> $ $foo->[ ... ]
5694             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5695 0           $char[$i] = e_capture($1.'->'.$2);
5696 0 0         if ($ignorecase) {
5697 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5698             }
5699             }
5700              
5701             # $$foo{ ... } --> $ $foo->{ ... }
5702             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5703 0           $char[$i] = e_capture($1.'->'.$2);
5704 0 0         if ($ignorecase) {
5705 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5706             }
5707             }
5708              
5709             # $$foo
5710             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5711 0           $char[$i] = e_capture($1);
5712 0 0         if ($ignorecase) {
5713 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5714             }
5715             }
5716              
5717             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Earabic::PREMATCH()
5718             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5719 0 0         if ($ignorecase) {
5720 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::PREMATCH())]}';
5721             }
5722             else {
5723 0           $char[$i] = '@{[Earabic::PREMATCH()]}';
5724             }
5725             }
5726              
5727             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Earabic::MATCH()
5728             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5729 0 0         if ($ignorecase) {
5730 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::MATCH())]}';
5731             }
5732             else {
5733 0           $char[$i] = '@{[Earabic::MATCH()]}';
5734             }
5735             }
5736              
5737             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Earabic::POSTMATCH()
5738             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5739 0 0         if ($ignorecase) {
5740 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::POSTMATCH())]}';
5741             }
5742             else {
5743 0           $char[$i] = '@{[Earabic::POSTMATCH()]}';
5744             }
5745             }
5746              
5747             # ${ foo }
5748             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5749 0 0         if ($ignorecase) {
5750 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5751             }
5752             }
5753              
5754             # ${ ... }
5755             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5756 0           $char[$i] = e_capture($1);
5757 0 0         if ($ignorecase) {
5758 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5759             }
5760             }
5761              
5762             # $scalar or @array
5763             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5764 0           $char[$i] = e_string($char[$i]);
5765 0 0         if ($ignorecase) {
5766 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
5767             }
5768             }
5769              
5770             # quote character before ? + * {
5771             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5772 0 0 0       if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    0          
5773             }
5774             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5775 0           my $char = $char[$i-1];
5776 0 0         if ($char[$i] eq '{') {
5777 0           die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
5778             }
5779             else {
5780 0           die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
5781             }
5782             }
5783             else {
5784 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5785             }
5786             }
5787             }
5788              
5789             # make regexp string
5790 0           $modifier =~ tr/i//d;
5791 0 0         if ($left_e > $right_e) {
5792 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5793 0           return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5794             }
5795             else {
5796 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5797             }
5798             }
5799 0 0 0       if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5800 0           return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5801             }
5802             else {
5803 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5804             }
5805             }
5806              
5807             #
5808             # double quote stuff
5809             #
5810             sub qq_stuff {
5811 0     0 0   my($delimiter,$end_delimiter,$stuff) = @_;
5812              
5813             # scalar variable or array variable
5814 0 0         if ($stuff =~ /\A [\$\@] /oxms) {
5815 0           return $stuff;
5816             }
5817              
5818             # quote by delimiter
5819 0           my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  0            
5820 0           for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5821 0 0         next if $char eq $delimiter;
5822 0 0         next if $char eq $end_delimiter;
5823 0 0         if (not $octet{$char}) {
5824 0           return join '', 'qq', $char, $stuff, $char;
5825             }
5826             }
5827 0           return join '', 'qq', '<', $stuff, '>';
5828             }
5829              
5830             #
5831             # escape regexp (m'', qr'', and m''b, qr''b)
5832             #
5833             sub e_qr_q {
5834 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5835 0   0       $modifier ||= '';
5836              
5837 0           $modifier =~ tr/p//d;
5838 0 0         if ($modifier =~ /([adlu])/oxms) {
5839 0           my $line = 0;
5840 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5841 0 0         if ($filename ne __FILE__) {
5842 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5843 0           last;
5844             }
5845             }
5846 0           die qq{Unsupported modifier "$1" used at line $line.\n};
5847             }
5848              
5849 0           $slash = 'div';
5850              
5851             # literal null string pattern
5852 0 0         if ($string eq '') {
    0          
5853 0           $modifier =~ tr/bB//d;
5854 0           $modifier =~ tr/i//d;
5855 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
5856             }
5857              
5858             # with /b /B modifier
5859             elsif ($modifier =~ tr/bB//d) {
5860 0           return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5861             }
5862              
5863             # without /b /B modifier
5864             else {
5865 0           return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
5866             }
5867             }
5868              
5869             #
5870             # escape regexp (m'', qr'')
5871             #
5872             sub e_qr_qt {
5873 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5874              
5875 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5876              
5877             # split regexp
5878 0           my @char = $string =~ /\G((?>
5879             [^\\\[\$\@\/] |
5880             [\x00-\xFF] |
5881             \[\^ |
5882             \[\: (?>[a-z]+) \:\] |
5883             \[\:\^ (?>[a-z]+) \:\] |
5884             [\$\@\/] |
5885             \\ (?:$q_char) |
5886             (?:$q_char)
5887             ))/oxmsg;
5888              
5889             # unescape character
5890 0           for (my $i=0; $i <= $#char; $i++) {
5891 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
5892             }
5893              
5894             # open character class [...]
5895 0           elsif ($char[$i] eq '[') {
5896 0           my $left = $i;
5897 0 0         if ($char[$i+1] eq ']') {
5898 0           $i++;
5899             }
5900 0           while (1) {
5901 0 0         if (++$i > $#char) {
5902 0           die __FILE__, ": Unmatched [] in regexp\n";
5903             }
5904 0 0         if ($char[$i] eq ']') {
5905 0           my $right = $i;
5906              
5907             # [...]
5908 0           splice @char, $left, $right-$left+1, Earabic::charlist_qr(@char[$left+1..$right-1], $modifier);
5909              
5910 0           $i = $left;
5911 0           last;
5912             }
5913             }
5914             }
5915              
5916             # open character class [^...]
5917             elsif ($char[$i] eq '[^') {
5918 0           my $left = $i;
5919 0 0         if ($char[$i+1] eq ']') {
5920 0           $i++;
5921             }
5922 0           while (1) {
5923 0 0         if (++$i > $#char) {
5924 0           die __FILE__, ": Unmatched [] in regexp\n";
5925             }
5926 0 0         if ($char[$i] eq ']') {
5927 0           my $right = $i;
5928              
5929             # [^...]
5930 0           splice @char, $left, $right-$left+1, Earabic::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5931              
5932 0           $i = $left;
5933 0           last;
5934             }
5935             }
5936             }
5937              
5938             # escape $ @ / and \
5939             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5940 0           $char[$i] = '\\' . $char[$i];
5941             }
5942              
5943             # rewrite character class or escape character
5944             elsif (my $char = character_class($char[$i],$modifier)) {
5945 0           $char[$i] = $char;
5946             }
5947              
5948             # /i modifier
5949             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Earabic::uc($char[$i]) ne Earabic::fc($char[$i]))) {
5950 0 0         if (CORE::length(Earabic::fc($char[$i])) == 1) {
5951 0           $char[$i] = '[' . Earabic::uc($char[$i]) . Earabic::fc($char[$i]) . ']';
5952             }
5953             else {
5954 0           $char[$i] = '(?:' . Earabic::uc($char[$i]) . '|' . Earabic::fc($char[$i]) . ')';
5955             }
5956             }
5957              
5958             # quote character before ? + * {
5959             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5960 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
5961             }
5962             else {
5963 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
5964             }
5965             }
5966             }
5967              
5968 0           $delimiter = '/';
5969 0           $end_delimiter = '/';
5970              
5971 0           $modifier =~ tr/i//d;
5972 0           return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5973             }
5974              
5975             #
5976             # escape regexp (m''b, qr''b)
5977             #
5978             sub e_qr_qb {
5979 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5980              
5981             # split regexp
5982 0           my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
5983              
5984             # unescape character
5985 0           for (my $i=0; $i <= $#char; $i++) {
5986 0 0         if (0) {
    0          
5987             }
5988              
5989             # remain \\
5990 0           elsif ($char[$i] eq '\\\\') {
5991             }
5992              
5993             # escape $ @ / and \
5994             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5995 0           $char[$i] = '\\' . $char[$i];
5996             }
5997             }
5998              
5999 0           $delimiter = '/';
6000 0           $end_delimiter = '/';
6001 0           return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6002             }
6003              
6004             #
6005             # escape regexp (s/here//)
6006             #
6007             sub e_s1 {
6008 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6009 0   0       $modifier ||= '';
6010              
6011 0           $modifier =~ tr/p//d;
6012 0 0         if ($modifier =~ /([adlu])/oxms) {
6013 0           my $line = 0;
6014 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6015 0 0         if ($filename ne __FILE__) {
6016 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6017 0           last;
6018             }
6019             }
6020 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6021             }
6022              
6023 0           $slash = 'div';
6024              
6025             # literal null string pattern
6026 0 0         if ($string eq '') {
    0          
6027 0           $modifier =~ tr/bB//d;
6028 0           $modifier =~ tr/i//d;
6029 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6030             }
6031              
6032             # /b /B modifier
6033             elsif ($modifier =~ tr/bB//d) {
6034              
6035             # choice again delimiter
6036 0 0         if ($delimiter =~ / [\@:] /oxms) {
6037 0           my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6038 0           my %octet = map {$_ => 1} @char;
  0            
6039 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6040 0           $delimiter = '(';
6041 0           $end_delimiter = ')';
6042             }
6043             elsif (not $octet{'}'}) {
6044 0           $delimiter = '{';
6045 0           $end_delimiter = '}';
6046             }
6047             elsif (not $octet{']'}) {
6048 0           $delimiter = '[';
6049 0           $end_delimiter = ']';
6050             }
6051             elsif (not $octet{'>'}) {
6052 0           $delimiter = '<';
6053 0           $end_delimiter = '>';
6054             }
6055             else {
6056 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6057 0 0         if (not $octet{$char}) {
6058 0           $delimiter = $char;
6059 0           $end_delimiter = $char;
6060 0           last;
6061             }
6062             }
6063             }
6064             }
6065              
6066 0           my $prematch = '';
6067 0           return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6068             }
6069              
6070 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6071 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6072              
6073             # split regexp
6074 0           my @char = $string =~ /\G((?>
6075             [^\\\$\@\[\(] |
6076             \\ (?>[1-9][0-9]*) |
6077             \\g (?>\s*) (?>[1-9][0-9]*) |
6078             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6079             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6080             \\x (?>[0-9A-Fa-f]{1,2}) |
6081             \\ (?>[0-7]{2,3}) |
6082             \\c [\x40-\x5F] |
6083             \\x\{ (?>[0-9A-Fa-f]+) \} |
6084             \\o\{ (?>[0-7]+) \} |
6085             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6086             \\ $q_char |
6087             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6088             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6089             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6090             [\$\@] $qq_variable |
6091             \$ (?>\s* [0-9]+) |
6092             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6093             \$ \$ (?![\w\{]) |
6094             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6095             \[\^ |
6096             \[\: (?>[a-z]+) :\] |
6097             \[\:\^ (?>[a-z]+) :\] |
6098             \(\? |
6099             $q_char
6100             ))/oxmsg;
6101              
6102             # choice again delimiter
6103 0 0         if ($delimiter =~ / [\@:] /oxms) {
6104 0           my %octet = map {$_ => 1} @char;
  0            
6105 0 0         if (not $octet{')'}) {
    0          
    0          
    0          
6106 0           $delimiter = '(';
6107 0           $end_delimiter = ')';
6108             }
6109             elsif (not $octet{'}'}) {
6110 0           $delimiter = '{';
6111 0           $end_delimiter = '}';
6112             }
6113             elsif (not $octet{']'}) {
6114 0           $delimiter = '[';
6115 0           $end_delimiter = ']';
6116             }
6117             elsif (not $octet{'>'}) {
6118 0           $delimiter = '<';
6119 0           $end_delimiter = '>';
6120             }
6121             else {
6122 0           for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6123 0 0         if (not $octet{$char}) {
6124 0           $delimiter = $char;
6125 0           $end_delimiter = $char;
6126 0           last;
6127             }
6128             }
6129             }
6130             }
6131              
6132             # count '('
6133 0           my $parens = grep { $_ eq '(' } @char;
  0            
6134              
6135 0           my $left_e = 0;
6136 0           my $right_e = 0;
6137 0           for (my $i=0; $i <= $#char; $i++) {
6138              
6139             # "\L\u" --> "\u\L"
6140 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
6141 0           @char[$i,$i+1] = @char[$i+1,$i];
6142             }
6143              
6144             # "\U\l" --> "\l\U"
6145             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6146 0           @char[$i,$i+1] = @char[$i+1,$i];
6147             }
6148              
6149             # octal escape sequence
6150             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6151 0           $char[$i] = Earabic::octchr($1);
6152             }
6153              
6154             # hexadecimal escape sequence
6155             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6156 0           $char[$i] = Earabic::hexchr($1);
6157             }
6158              
6159             # \b{...} --> b\{...}
6160             # \B{...} --> B\{...}
6161             # \N{CHARNAME} --> N\{CHARNAME}
6162             # \p{PROPERTY} --> p\{PROPERTY}
6163             # \P{PROPERTY} --> P\{PROPERTY}
6164             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6165 0           $char[$i] = $1 . '\\' . $2;
6166             }
6167              
6168             # \p, \P, \X --> p, P, X
6169             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6170 0           $char[$i] = $1;
6171             }
6172              
6173 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          
6174             }
6175              
6176             # join separated multiple-octet
6177 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6178 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        
6179 0           $char[$i] .= join '', splice @char, $i+1, 3;
6180             }
6181             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)) {
6182 0           $char[$i] .= join '', splice @char, $i+1, 2;
6183             }
6184             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)) {
6185 0           $char[$i] .= join '', splice @char, $i+1, 1;
6186             }
6187             }
6188              
6189             # open character class [...]
6190             elsif ($char[$i] eq '[') {
6191 0           my $left = $i;
6192 0 0         if ($char[$i+1] eq ']') {
6193 0           $i++;
6194             }
6195 0           while (1) {
6196 0 0         if (++$i > $#char) {
6197 0           die __FILE__, ": Unmatched [] in regexp\n";
6198             }
6199 0 0         if ($char[$i] eq ']') {
6200 0           my $right = $i;
6201              
6202             # [...]
6203 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6204 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Earabic::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6205             }
6206             else {
6207 0           splice @char, $left, $right-$left+1, Earabic::charlist_qr(@char[$left+1..$right-1], $modifier);
6208             }
6209              
6210 0           $i = $left;
6211 0           last;
6212             }
6213             }
6214             }
6215              
6216             # open character class [^...]
6217             elsif ($char[$i] eq '[^') {
6218 0           my $left = $i;
6219 0 0         if ($char[$i+1] eq ']') {
6220 0           $i++;
6221             }
6222 0           while (1) {
6223 0 0         if (++$i > $#char) {
6224 0           die __FILE__, ": Unmatched [] in regexp\n";
6225             }
6226 0 0         if ($char[$i] eq ']') {
6227 0           my $right = $i;
6228              
6229             # [^...]
6230 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6231 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Earabic::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6232             }
6233             else {
6234 0           splice @char, $left, $right-$left+1, Earabic::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6235             }
6236              
6237 0           $i = $left;
6238 0           last;
6239             }
6240             }
6241             }
6242              
6243             # rewrite character class or escape character
6244             elsif (my $char = character_class($char[$i],$modifier)) {
6245 0           $char[$i] = $char;
6246             }
6247              
6248             # /i modifier
6249             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Earabic::uc($char[$i]) ne Earabic::fc($char[$i]))) {
6250 0 0         if (CORE::length(Earabic::fc($char[$i])) == 1) {
6251 0           $char[$i] = '[' . Earabic::uc($char[$i]) . Earabic::fc($char[$i]) . ']';
6252             }
6253             else {
6254 0           $char[$i] = '(?:' . Earabic::uc($char[$i]) . '|' . Earabic::fc($char[$i]) . ')';
6255             }
6256             }
6257              
6258             # \u \l \U \L \F \Q \E
6259             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6260 0 0         if ($right_e < $left_e) {
6261 0           $char[$i] = '\\' . $char[$i];
6262             }
6263             }
6264             elsif ($char[$i] eq '\u') {
6265 0           $char[$i] = '@{[Earabic::ucfirst qq<';
6266 0           $left_e++;
6267             }
6268             elsif ($char[$i] eq '\l') {
6269 0           $char[$i] = '@{[Earabic::lcfirst qq<';
6270 0           $left_e++;
6271             }
6272             elsif ($char[$i] eq '\U') {
6273 0           $char[$i] = '@{[Earabic::uc qq<';
6274 0           $left_e++;
6275             }
6276             elsif ($char[$i] eq '\L') {
6277 0           $char[$i] = '@{[Earabic::lc qq<';
6278 0           $left_e++;
6279             }
6280             elsif ($char[$i] eq '\F') {
6281 0           $char[$i] = '@{[Earabic::fc qq<';
6282 0           $left_e++;
6283             }
6284             elsif ($char[$i] eq '\Q') {
6285 0           $char[$i] = '@{[CORE::quotemeta qq<';
6286 0           $left_e++;
6287             }
6288             elsif ($char[$i] eq '\E') {
6289 0 0         if ($right_e < $left_e) {
6290 0           $char[$i] = '>]}';
6291 0           $right_e++;
6292             }
6293             else {
6294 0           $char[$i] = '';
6295             }
6296             }
6297             elsif ($char[$i] eq '\Q') {
6298 0           while (1) {
6299 0 0         if (++$i > $#char) {
6300 0           last;
6301             }
6302 0 0         if ($char[$i] eq '\E') {
6303 0           last;
6304             }
6305             }
6306             }
6307             elsif ($char[$i] eq '\E') {
6308             }
6309              
6310             # \0 --> \0
6311             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6312             }
6313              
6314             # \g{N}, \g{-N}
6315              
6316             # P.108 Using Simple Patterns
6317             # in Chapter 7: In the World of Regular Expressions
6318             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6319              
6320             # P.221 Capturing
6321             # in Chapter 5: Pattern Matching
6322             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6323              
6324             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6325             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6326             }
6327              
6328             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6329             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6330             }
6331              
6332             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6333             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6334             }
6335              
6336             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6337             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6338             }
6339              
6340             # $0 --> $0
6341             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6342 0 0         if ($ignorecase) {
6343 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6344             }
6345             }
6346             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6347 0 0         if ($ignorecase) {
6348 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6349             }
6350             }
6351              
6352             # $$ --> $$
6353             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6354             }
6355              
6356             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6357             # $1, $2, $3 --> $1, $2, $3 otherwise
6358             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6359 0           $char[$i] = e_capture($1);
6360 0 0         if ($ignorecase) {
6361 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6362             }
6363             }
6364             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6365 0           $char[$i] = e_capture($1);
6366 0 0         if ($ignorecase) {
6367 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6368             }
6369             }
6370              
6371             # $$foo[ ... ] --> $ $foo->[ ... ]
6372             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6373 0           $char[$i] = e_capture($1.'->'.$2);
6374 0 0         if ($ignorecase) {
6375 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6376             }
6377             }
6378              
6379             # $$foo{ ... } --> $ $foo->{ ... }
6380             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6381 0           $char[$i] = e_capture($1.'->'.$2);
6382 0 0         if ($ignorecase) {
6383 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6384             }
6385             }
6386              
6387             # $$foo
6388             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6389 0           $char[$i] = e_capture($1);
6390 0 0         if ($ignorecase) {
6391 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6392             }
6393             }
6394              
6395             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Earabic::PREMATCH()
6396             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6397 0 0         if ($ignorecase) {
6398 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::PREMATCH())]}';
6399             }
6400             else {
6401 0           $char[$i] = '@{[Earabic::PREMATCH()]}';
6402             }
6403             }
6404              
6405             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Earabic::MATCH()
6406             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6407 0 0         if ($ignorecase) {
6408 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::MATCH())]}';
6409             }
6410             else {
6411 0           $char[$i] = '@{[Earabic::MATCH()]}';
6412             }
6413             }
6414              
6415             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Earabic::POSTMATCH()
6416             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6417 0 0         if ($ignorecase) {
6418 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::POSTMATCH())]}';
6419             }
6420             else {
6421 0           $char[$i] = '@{[Earabic::POSTMATCH()]}';
6422             }
6423             }
6424              
6425             # ${ foo }
6426             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6427 0 0         if ($ignorecase) {
6428 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6429             }
6430             }
6431              
6432             # ${ ... }
6433             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6434 0           $char[$i] = e_capture($1);
6435 0 0         if ($ignorecase) {
6436 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6437             }
6438             }
6439              
6440             # $scalar or @array
6441             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6442 0           $char[$i] = e_string($char[$i]);
6443 0 0         if ($ignorecase) {
6444 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
6445             }
6446             }
6447              
6448             # quote character before ? + * {
6449             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6450 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6451             }
6452             else {
6453 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6454             }
6455             }
6456             }
6457              
6458             # make regexp string
6459 0           my $prematch = '';
6460 0           $modifier =~ tr/i//d;
6461 0 0         if ($left_e > $right_e) {
6462 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6463             }
6464 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6465             }
6466              
6467             #
6468             # escape regexp (s'here'' or s'here''b)
6469             #
6470             sub e_s1_q {
6471 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6472 0   0       $modifier ||= '';
6473              
6474 0           $modifier =~ tr/p//d;
6475 0 0         if ($modifier =~ /([adlu])/oxms) {
6476 0           my $line = 0;
6477 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6478 0 0         if ($filename ne __FILE__) {
6479 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6480 0           last;
6481             }
6482             }
6483 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6484             }
6485              
6486 0           $slash = 'div';
6487              
6488             # literal null string pattern
6489 0 0         if ($string eq '') {
    0          
6490 0           $modifier =~ tr/bB//d;
6491 0           $modifier =~ tr/i//d;
6492 0           return join '', $ope, $delimiter, $end_delimiter, $modifier;
6493             }
6494              
6495             # with /b /B modifier
6496             elsif ($modifier =~ tr/bB//d) {
6497 0           return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6498             }
6499              
6500             # without /b /B modifier
6501             else {
6502 0           return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6503             }
6504             }
6505              
6506             #
6507             # escape regexp (s'here'')
6508             #
6509             sub e_s1_qt {
6510 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6511              
6512 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6513              
6514             # split regexp
6515 0           my @char = $string =~ /\G((?>
6516             [^\\\[\$\@\/] |
6517             [\x00-\xFF] |
6518             \[\^ |
6519             \[\: (?>[a-z]+) \:\] |
6520             \[\:\^ (?>[a-z]+) \:\] |
6521             [\$\@\/] |
6522             \\ (?:$q_char) |
6523             (?:$q_char)
6524             ))/oxmsg;
6525              
6526             # unescape character
6527 0           for (my $i=0; $i <= $#char; $i++) {
6528 0 0 0       if (0) {
    0 0        
    0 0        
    0          
    0          
    0          
6529             }
6530              
6531             # open character class [...]
6532 0           elsif ($char[$i] eq '[') {
6533 0           my $left = $i;
6534 0 0         if ($char[$i+1] eq ']') {
6535 0           $i++;
6536             }
6537 0           while (1) {
6538 0 0         if (++$i > $#char) {
6539 0           die __FILE__, ": Unmatched [] in regexp\n";
6540             }
6541 0 0         if ($char[$i] eq ']') {
6542 0           my $right = $i;
6543              
6544             # [...]
6545 0           splice @char, $left, $right-$left+1, Earabic::charlist_qr(@char[$left+1..$right-1], $modifier);
6546              
6547 0           $i = $left;
6548 0           last;
6549             }
6550             }
6551             }
6552              
6553             # open character class [^...]
6554             elsif ($char[$i] eq '[^') {
6555 0           my $left = $i;
6556 0 0         if ($char[$i+1] eq ']') {
6557 0           $i++;
6558             }
6559 0           while (1) {
6560 0 0         if (++$i > $#char) {
6561 0           die __FILE__, ": Unmatched [] in regexp\n";
6562             }
6563 0 0         if ($char[$i] eq ']') {
6564 0           my $right = $i;
6565              
6566             # [^...]
6567 0           splice @char, $left, $right-$left+1, Earabic::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6568              
6569 0           $i = $left;
6570 0           last;
6571             }
6572             }
6573             }
6574              
6575             # escape $ @ / and \
6576             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6577 0           $char[$i] = '\\' . $char[$i];
6578             }
6579              
6580             # rewrite character class or escape character
6581             elsif (my $char = character_class($char[$i],$modifier)) {
6582 0           $char[$i] = $char;
6583             }
6584              
6585             # /i modifier
6586             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Earabic::uc($char[$i]) ne Earabic::fc($char[$i]))) {
6587 0 0         if (CORE::length(Earabic::fc($char[$i])) == 1) {
6588 0           $char[$i] = '[' . Earabic::uc($char[$i]) . Earabic::fc($char[$i]) . ']';
6589             }
6590             else {
6591 0           $char[$i] = '(?:' . Earabic::uc($char[$i]) . '|' . Earabic::fc($char[$i]) . ')';
6592             }
6593             }
6594              
6595             # quote character before ? + * {
6596             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6597 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6598             }
6599             else {
6600 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
6601             }
6602             }
6603             }
6604              
6605 0           $modifier =~ tr/i//d;
6606 0           $delimiter = '/';
6607 0           $end_delimiter = '/';
6608 0           my $prematch = '';
6609 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6610             }
6611              
6612             #
6613             # escape regexp (s'here''b)
6614             #
6615             sub e_s1_qb {
6616 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6617              
6618             # split regexp
6619 0           my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6620              
6621             # unescape character
6622 0           for (my $i=0; $i <= $#char; $i++) {
6623 0 0         if (0) {
    0          
6624             }
6625              
6626             # remain \\
6627 0           elsif ($char[$i] eq '\\\\') {
6628             }
6629              
6630             # escape $ @ / and \
6631             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6632 0           $char[$i] = '\\' . $char[$i];
6633             }
6634             }
6635              
6636 0           $delimiter = '/';
6637 0           $end_delimiter = '/';
6638 0           my $prematch = '';
6639 0           return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6640             }
6641              
6642             #
6643             # escape regexp (s''here')
6644             #
6645             sub e_s2_q {
6646 0     0 0   my($ope,$delimiter,$end_delimiter,$string) = @_;
6647              
6648 0           $slash = 'div';
6649              
6650 0           my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6651 0           for (my $i=0; $i <= $#char; $i++) {
6652 0 0         if (0) {
    0          
6653             }
6654              
6655             # not escape \\
6656 0           elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6657             }
6658              
6659             # escape $ @ / and \
6660             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6661 0           $char[$i] = '\\' . $char[$i];
6662             }
6663             }
6664              
6665 0           return join '', $ope, $delimiter, @char, $end_delimiter;
6666             }
6667              
6668             #
6669             # escape regexp (s/here/and here/modifier)
6670             #
6671             sub e_sub {
6672 0     0 0   my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6673 0   0       $modifier ||= '';
6674              
6675 0           $modifier =~ tr/p//d;
6676 0 0         if ($modifier =~ /([adlu])/oxms) {
6677 0           my $line = 0;
6678 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6679 0 0         if ($filename ne __FILE__) {
6680 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6681 0           last;
6682             }
6683             }
6684 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6685             }
6686              
6687 0 0         if ($variable eq '') {
6688 0           $variable = '$_';
6689 0           $bind_operator = ' =~ ';
6690             }
6691              
6692 0           $slash = 'div';
6693              
6694             # P.128 Start of match (or end of previous match): \G
6695             # P.130 Advanced Use of \G with Perl
6696             # in Chapter 3: Overview of Regular Expression Features and Flavors
6697             # P.312 Iterative Matching: Scalar Context, with /g
6698             # in Chapter 7: Perl
6699             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6700              
6701             # P.181 Where You Left Off: The \G Assertion
6702             # in Chapter 5: Pattern Matching
6703             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6704              
6705             # P.220 Where You Left Off: The \G Assertion
6706             # in Chapter 5: Pattern Matching
6707             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6708              
6709 0           my $e_modifier = $modifier =~ tr/e//d;
6710 0           my $r_modifier = $modifier =~ tr/r//d;
6711              
6712 0           my $my = '';
6713 0 0         if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6714 0           $my = $variable;
6715 0           $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6716 0           $variable =~ s/ = .+ \z//oxms;
6717             }
6718              
6719 0           (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6720 0           $variable_basename =~ s/ \s+ \z//oxms;
6721              
6722             # quote replacement string
6723 0           my $e_replacement = '';
6724 0 0         if ($e_modifier >= 1) {
6725 0           $e_replacement = e_qq('', '', '', $replacement);
6726 0           $e_modifier--;
6727             }
6728             else {
6729 0 0         if ($delimiter2 eq "'") {
6730 0           $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6731             }
6732             else {
6733 0           $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6734             }
6735             }
6736              
6737 0           my $sub = '';
6738              
6739             # with /r
6740 0 0         if ($r_modifier) {
6741 0 0         if (0) {
6742             }
6743              
6744             # s///gr without multibyte anchoring
6745 0           elsif ($modifier =~ /g/oxms) {
6746 0 0         $sub = sprintf(
6747             # 1 2 3 4 5
6748             q,
6749              
6750             $variable, # 1
6751             ($delimiter1 eq "'") ? # 2
6752             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6753             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6754             $s_matched, # 3
6755             $e_replacement, # 4
6756             '$Arabic::re_r=CORE::eval $Arabic::re_r; ' x $e_modifier, # 5
6757             );
6758             }
6759              
6760             # s///r
6761             else {
6762              
6763 0           my $prematch = q{$`};
6764              
6765 0 0         $sub = sprintf(
6766             # 1 2 3 4 5 6 7
6767             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Arabic::re_r=%s; %s"%s$Arabic::re_r$'" } : %s>,
6768              
6769             $variable, # 1
6770             ($delimiter1 eq "'") ? # 2
6771             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6772             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6773             $s_matched, # 3
6774             $e_replacement, # 4
6775             '$Arabic::re_r=CORE::eval $Arabic::re_r; ' x $e_modifier, # 5
6776             $prematch, # 6
6777             $variable, # 7
6778             );
6779             }
6780              
6781             # $var !~ s///r doesn't make sense
6782 0 0         if ($bind_operator =~ / !~ /oxms) {
6783 0           $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6784             }
6785             }
6786              
6787             # without /r
6788             else {
6789 0 0         if (0) {
6790             }
6791              
6792             # s///g without multibyte anchoring
6793 0           elsif ($modifier =~ /g/oxms) {
6794 0 0         $sub = sprintf(
    0          
6795             # 1 2 3 4 5 6 7 8
6796             q,
6797              
6798             $variable, # 1
6799             ($delimiter1 eq "'") ? # 2
6800             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6801             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6802             $s_matched, # 3
6803             $e_replacement, # 4
6804             '$Arabic::re_r=CORE::eval $Arabic::re_r; ' x $e_modifier, # 5
6805             $variable, # 6
6806             $variable, # 7
6807             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
6808             );
6809             }
6810              
6811             # s///
6812             else {
6813              
6814 0           my $prematch = q{$`};
6815              
6816 0 0         $sub = sprintf(
    0          
6817              
6818             ($bind_operator =~ / =~ /oxms) ?
6819              
6820             # 1 2 3 4 5 6 7 8
6821             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Arabic::re_r=%s; %s%s="%s$Arabic::re_r$'"; 1 } : undef> :
6822              
6823             # 1 2 3 4 5 6 7 8
6824             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Arabic::re_r=%s; %s%s="%s$Arabic::re_r$'"; undef }>,
6825              
6826             $variable, # 1
6827             $bind_operator, # 2
6828             ($delimiter1 eq "'") ? # 3
6829             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6830             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6831             $s_matched, # 4
6832             $e_replacement, # 5
6833             '$Arabic::re_r=CORE::eval $Arabic::re_r; ' x $e_modifier, # 6
6834             $variable, # 7
6835             $prematch, # 8
6836             );
6837             }
6838             }
6839              
6840             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
6841 0 0         if ($my ne '') {
6842 0           $sub = "($my, $sub)[1]";
6843             }
6844              
6845             # clear s/// variable
6846 0           $sub_variable = '';
6847 0           $bind_operator = '';
6848              
6849 0           return $sub;
6850             }
6851              
6852             #
6853             # escape regexp of split qr//
6854             #
6855             sub e_split {
6856 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6857 0   0       $modifier ||= '';
6858              
6859 0           $modifier =~ tr/p//d;
6860 0 0         if ($modifier =~ /([adlu])/oxms) {
6861 0           my $line = 0;
6862 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6863 0 0         if ($filename ne __FILE__) {
6864 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6865 0           last;
6866             }
6867             }
6868 0           die qq{Unsupported modifier "$1" used at line $line.\n};
6869             }
6870              
6871 0           $slash = 'div';
6872              
6873             # /b /B modifier
6874 0 0         if ($modifier =~ tr/bB//d) {
6875 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6876             }
6877              
6878 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6879 0           my $metachar = qr/[\@\\|[\]{^]/oxms;
6880              
6881             # split regexp
6882 0           my @char = $string =~ /\G((?>
6883             [^\\\$\@\[\(] |
6884             \\x (?>[0-9A-Fa-f]{1,2}) |
6885             \\ (?>[0-7]{2,3}) |
6886             \\c [\x40-\x5F] |
6887             \\x\{ (?>[0-9A-Fa-f]+) \} |
6888             \\o\{ (?>[0-7]+) \} |
6889             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6890             \\ $q_char |
6891             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6892             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6893             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6894             [\$\@] $qq_variable |
6895             \$ (?>\s* [0-9]+) |
6896             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6897             \$ \$ (?![\w\{]) |
6898             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6899             \[\^ |
6900             \[\: (?>[a-z]+) :\] |
6901             \[\:\^ (?>[a-z]+) :\] |
6902             \(\? |
6903             $q_char
6904             ))/oxmsg;
6905              
6906 0           my $left_e = 0;
6907 0           my $right_e = 0;
6908 0           for (my $i=0; $i <= $#char; $i++) {
6909              
6910             # "\L\u" --> "\u\L"
6911 0 0 0       if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    0 0        
    0          
    0          
    0          
    0          
6912 0           @char[$i,$i+1] = @char[$i+1,$i];
6913             }
6914              
6915             # "\U\l" --> "\l\U"
6916             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6917 0           @char[$i,$i+1] = @char[$i+1,$i];
6918             }
6919              
6920             # octal escape sequence
6921             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6922 0           $char[$i] = Earabic::octchr($1);
6923             }
6924              
6925             # hexadecimal escape sequence
6926             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6927 0           $char[$i] = Earabic::hexchr($1);
6928             }
6929              
6930             # \b{...} --> b\{...}
6931             # \B{...} --> B\{...}
6932             # \N{CHARNAME} --> N\{CHARNAME}
6933             # \p{PROPERTY} --> p\{PROPERTY}
6934             # \P{PROPERTY} --> P\{PROPERTY}
6935             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6936 0           $char[$i] = $1 . '\\' . $2;
6937             }
6938              
6939             # \p, \P, \X --> p, P, X
6940             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6941 0           $char[$i] = $1;
6942             }
6943              
6944 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          
6945             }
6946              
6947             # join separated multiple-octet
6948 0           elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6949 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        
6950 0           $char[$i] .= join '', splice @char, $i+1, 3;
6951             }
6952             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)) {
6953 0           $char[$i] .= join '', splice @char, $i+1, 2;
6954             }
6955             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)) {
6956 0           $char[$i] .= join '', splice @char, $i+1, 1;
6957             }
6958             }
6959              
6960             # open character class [...]
6961             elsif ($char[$i] eq '[') {
6962 0           my $left = $i;
6963 0 0         if ($char[$i+1] eq ']') {
6964 0           $i++;
6965             }
6966 0           while (1) {
6967 0 0         if (++$i > $#char) {
6968 0           die __FILE__, ": Unmatched [] in regexp\n";
6969             }
6970 0 0         if ($char[$i] eq ']') {
6971 0           my $right = $i;
6972              
6973             # [...]
6974 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6975 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Earabic::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
6976             }
6977             else {
6978 0           splice @char, $left, $right-$left+1, Earabic::charlist_qr(@char[$left+1..$right-1], $modifier);
6979             }
6980              
6981 0           $i = $left;
6982 0           last;
6983             }
6984             }
6985             }
6986              
6987             # open character class [^...]
6988             elsif ($char[$i] eq '[^') {
6989 0           my $left = $i;
6990 0 0         if ($char[$i+1] eq ']') {
6991 0           $i++;
6992             }
6993 0           while (1) {
6994 0 0         if (++$i > $#char) {
6995 0           die __FILE__, ": Unmatched [] in regexp\n";
6996             }
6997 0 0         if ($char[$i] eq ']') {
6998 0           my $right = $i;
6999              
7000             # [^...]
7001 0 0         if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7002 0           splice @char, $left, $right-$left+1, sprintf(q{@{[Earabic::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0            
7003             }
7004             else {
7005 0           splice @char, $left, $right-$left+1, Earabic::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7006             }
7007              
7008 0           $i = $left;
7009 0           last;
7010             }
7011             }
7012             }
7013              
7014             # rewrite character class or escape character
7015             elsif (my $char = character_class($char[$i],$modifier)) {
7016 0           $char[$i] = $char;
7017             }
7018              
7019             # P.794 29.2.161. split
7020             # in Chapter 29: Functions
7021             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7022              
7023             # P.951 split
7024             # in Chapter 27: Functions
7025             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7026              
7027             # said "The //m modifier is assumed when you split on the pattern /^/",
7028             # but perl5.008 is not so. Therefore, this software adds //m.
7029             # (and so on)
7030              
7031             # split(m/^/) --> split(m/^/m)
7032             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7033 0           $modifier .= 'm';
7034             }
7035              
7036             # /i modifier
7037             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Earabic::uc($char[$i]) ne Earabic::fc($char[$i]))) {
7038 0 0         if (CORE::length(Earabic::fc($char[$i])) == 1) {
7039 0           $char[$i] = '[' . Earabic::uc($char[$i]) . Earabic::fc($char[$i]) . ']';
7040             }
7041             else {
7042 0           $char[$i] = '(?:' . Earabic::uc($char[$i]) . '|' . Earabic::fc($char[$i]) . ')';
7043             }
7044             }
7045              
7046             # \u \l \U \L \F \Q \E
7047             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7048 0 0         if ($right_e < $left_e) {
7049 0           $char[$i] = '\\' . $char[$i];
7050             }
7051             }
7052             elsif ($char[$i] eq '\u') {
7053 0           $char[$i] = '@{[Earabic::ucfirst qq<';
7054 0           $left_e++;
7055             }
7056             elsif ($char[$i] eq '\l') {
7057 0           $char[$i] = '@{[Earabic::lcfirst qq<';
7058 0           $left_e++;
7059             }
7060             elsif ($char[$i] eq '\U') {
7061 0           $char[$i] = '@{[Earabic::uc qq<';
7062 0           $left_e++;
7063             }
7064             elsif ($char[$i] eq '\L') {
7065 0           $char[$i] = '@{[Earabic::lc qq<';
7066 0           $left_e++;
7067             }
7068             elsif ($char[$i] eq '\F') {
7069 0           $char[$i] = '@{[Earabic::fc qq<';
7070 0           $left_e++;
7071             }
7072             elsif ($char[$i] eq '\Q') {
7073 0           $char[$i] = '@{[CORE::quotemeta qq<';
7074 0           $left_e++;
7075             }
7076             elsif ($char[$i] eq '\E') {
7077 0 0         if ($right_e < $left_e) {
7078 0           $char[$i] = '>]}';
7079 0           $right_e++;
7080             }
7081             else {
7082 0           $char[$i] = '';
7083             }
7084             }
7085             elsif ($char[$i] eq '\Q') {
7086 0           while (1) {
7087 0 0         if (++$i > $#char) {
7088 0           last;
7089             }
7090 0 0         if ($char[$i] eq '\E') {
7091 0           last;
7092             }
7093             }
7094             }
7095             elsif ($char[$i] eq '\E') {
7096             }
7097              
7098             # $0 --> $0
7099             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7100 0 0         if ($ignorecase) {
7101 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7102             }
7103             }
7104             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7105 0 0         if ($ignorecase) {
7106 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7107             }
7108             }
7109              
7110             # $$ --> $$
7111             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7112             }
7113              
7114             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7115             # $1, $2, $3 --> $1, $2, $3 otherwise
7116             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7117 0           $char[$i] = e_capture($1);
7118 0 0         if ($ignorecase) {
7119 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7120             }
7121             }
7122             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7123 0           $char[$i] = e_capture($1);
7124 0 0         if ($ignorecase) {
7125 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7126             }
7127             }
7128              
7129             # $$foo[ ... ] --> $ $foo->[ ... ]
7130             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7131 0           $char[$i] = e_capture($1.'->'.$2);
7132 0 0         if ($ignorecase) {
7133 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7134             }
7135             }
7136              
7137             # $$foo{ ... } --> $ $foo->{ ... }
7138             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7139 0           $char[$i] = e_capture($1.'->'.$2);
7140 0 0         if ($ignorecase) {
7141 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7142             }
7143             }
7144              
7145             # $$foo
7146             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7147 0           $char[$i] = e_capture($1);
7148 0 0         if ($ignorecase) {
7149 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7150             }
7151             }
7152              
7153             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Earabic::PREMATCH()
7154             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7155 0 0         if ($ignorecase) {
7156 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::PREMATCH())]}';
7157             }
7158             else {
7159 0           $char[$i] = '@{[Earabic::PREMATCH()]}';
7160             }
7161             }
7162              
7163             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Earabic::MATCH()
7164             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7165 0 0         if ($ignorecase) {
7166 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::MATCH())]}';
7167             }
7168             else {
7169 0           $char[$i] = '@{[Earabic::MATCH()]}';
7170             }
7171             }
7172              
7173             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Earabic::POSTMATCH()
7174             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7175 0 0         if ($ignorecase) {
7176 0           $char[$i] = '@{[Earabic::ignorecase(Earabic::POSTMATCH())]}';
7177             }
7178             else {
7179 0           $char[$i] = '@{[Earabic::POSTMATCH()]}';
7180             }
7181             }
7182              
7183             # ${ foo }
7184             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7185 0 0         if ($ignorecase) {
7186 0           $char[$i] = '@{[Earabic::ignorecase(' . $1 . ')]}';
7187             }
7188             }
7189              
7190             # ${ ... }
7191             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7192 0           $char[$i] = e_capture($1);
7193 0 0         if ($ignorecase) {
7194 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7195             }
7196             }
7197              
7198             # $scalar or @array
7199             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7200 0           $char[$i] = e_string($char[$i]);
7201 0 0         if ($ignorecase) {
7202 0           $char[$i] = '@{[Earabic::ignorecase(' . $char[$i] . ')]}';
7203             }
7204             }
7205              
7206             # quote character before ? + * {
7207             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7208 0 0         if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7209             }
7210             else {
7211 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7212             }
7213             }
7214             }
7215              
7216             # make regexp string
7217 0           $modifier =~ tr/i//d;
7218 0 0         if ($left_e > $right_e) {
7219 0           return join '', 'Earabic::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7220             }
7221 0           return join '', 'Earabic::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7222             }
7223              
7224             #
7225             # escape regexp of split qr''
7226             #
7227             sub e_split_q {
7228 0     0 0   my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7229 0   0       $modifier ||= '';
7230              
7231 0           $modifier =~ tr/p//d;
7232 0 0         if ($modifier =~ /([adlu])/oxms) {
7233 0           my $line = 0;
7234 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7235 0 0         if ($filename ne __FILE__) {
7236 0           $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7237 0           last;
7238             }
7239             }
7240 0           die qq{Unsupported modifier "$1" used at line $line.\n};
7241             }
7242              
7243 0           $slash = 'div';
7244              
7245             # /b /B modifier
7246 0 0         if ($modifier =~ tr/bB//d) {
7247 0           return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7248             }
7249              
7250 0 0         my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7251              
7252             # split regexp
7253 0           my @char = $string =~ /\G((?>
7254             [^\\\[] |
7255             [\x00-\xFF] |
7256             \[\^ |
7257             \[\: (?>[a-z]+) \:\] |
7258             \[\:\^ (?>[a-z]+) \:\] |
7259             \\ (?:$q_char) |
7260             (?:$q_char)
7261             ))/oxmsg;
7262              
7263             # unescape character
7264 0           for (my $i=0; $i <= $#char; $i++) {
7265 0 0 0       if (0) {
    0 0        
    0 0        
    0 0        
    0          
    0          
7266             }
7267              
7268             # open character class [...]
7269 0           elsif ($char[$i] eq '[') {
7270 0           my $left = $i;
7271 0 0         if ($char[$i+1] eq ']') {
7272 0           $i++;
7273             }
7274 0           while (1) {
7275 0 0         if (++$i > $#char) {
7276 0           die __FILE__, ": Unmatched [] in regexp\n";
7277             }
7278 0 0         if ($char[$i] eq ']') {
7279 0           my $right = $i;
7280              
7281             # [...]
7282 0           splice @char, $left, $right-$left+1, Earabic::charlist_qr(@char[$left+1..$right-1], $modifier);
7283              
7284 0           $i = $left;
7285 0           last;
7286             }
7287             }
7288             }
7289              
7290             # open character class [^...]
7291             elsif ($char[$i] eq '[^') {
7292 0           my $left = $i;
7293 0 0         if ($char[$i+1] eq ']') {
7294 0           $i++;
7295             }
7296 0           while (1) {
7297 0 0         if (++$i > $#char) {
7298 0           die __FILE__, ": Unmatched [] in regexp\n";
7299             }
7300 0 0         if ($char[$i] eq ']') {
7301 0           my $right = $i;
7302              
7303             # [^...]
7304 0           splice @char, $left, $right-$left+1, Earabic::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7305              
7306 0           $i = $left;
7307 0           last;
7308             }
7309             }
7310             }
7311              
7312             # rewrite character class or escape character
7313             elsif (my $char = character_class($char[$i],$modifier)) {
7314 0           $char[$i] = $char;
7315             }
7316              
7317             # split(m/^/) --> split(m/^/m)
7318             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7319 0           $modifier .= 'm';
7320             }
7321              
7322             # /i modifier
7323             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Earabic::uc($char[$i]) ne Earabic::fc($char[$i]))) {
7324 0 0         if (CORE::length(Earabic::fc($char[$i])) == 1) {
7325 0           $char[$i] = '[' . Earabic::uc($char[$i]) . Earabic::fc($char[$i]) . ']';
7326             }
7327             else {
7328 0           $char[$i] = '(?:' . Earabic::uc($char[$i]) . '|' . Earabic::fc($char[$i]) . ')';
7329             }
7330             }
7331              
7332             # quote character before ? + * {
7333             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7334 0 0         if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7335             }
7336             else {
7337 0           $char[$i-1] = '(?:' . $char[$i-1] . ')';
7338             }
7339             }
7340             }
7341              
7342 0           $modifier =~ tr/i//d;
7343 0           return join '', 'Earabic::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7344             }
7345              
7346             #
7347             # instead of Carp::carp
7348             #
7349             sub carp {
7350 0     0 0   my($package,$filename,$line) = caller(1);
7351 0           print STDERR "@_ at $filename line $line.\n";
7352             }
7353              
7354             #
7355             # instead of Carp::croak
7356             #
7357             sub croak {
7358 0     0 0   my($package,$filename,$line) = caller(1);
7359 0           print STDERR "@_ at $filename line $line.\n";
7360 0           die "\n";
7361             }
7362              
7363             #
7364             # instead of Carp::cluck
7365             #
7366             sub cluck {
7367 0     0 0   my $i = 0;
7368 0           my @cluck = ();
7369 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7370 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7371 0           $i++;
7372             }
7373 0           print STDERR CORE::reverse @cluck;
7374 0           print STDERR "\n";
7375 0           carp @_;
7376             }
7377              
7378             #
7379             # instead of Carp::confess
7380             #
7381             sub confess {
7382 0     0 0   my $i = 0;
7383 0           my @confess = ();
7384 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7385 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
7386 0           $i++;
7387             }
7388 0           print STDERR CORE::reverse @confess;
7389 0           print STDERR "\n";
7390 0           croak @_;
7391             }
7392              
7393             1;
7394              
7395             __END__