File Coverage

blib/lib/Ehebrew.pm
Criterion Covered Total %
statement 856 3080 27.7
branch 938 2674 35.0
condition 98 373 26.2
subroutine 67 125 53.6
pod 7 74 9.4
total 1966 6326 31.0


line stmt bran cond sub pod time code
1             package Ehebrew;
2             ######################################################################
3             #
4             # Ehebrew - Run-time routines for Hebrew.pm
5             #
6             # http://search.cpan.org/dist/Char-Hebrew/
7             #
8             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 INABA Hitoshi
9             ######################################################################
10              
11 200     200   3057 use 5.00503; # Galapagos Consensus 1998 for primetools
  200         538  
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   11250 BEGIN { CORE::eval q{ use vars qw($VERSION) } }
  200     200   896  
  200         267  
  200         24996  
27             $VERSION = '1.08';
28             $VERSION = CORE::eval $VERSION;
29              
30             BEGIN {
31 200 50   200   1098 if ($^X =~ / jperl /oxmsi) {
32 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
33             }
34 200         240 if (CORE::ord('A') == 193) {
35             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
36             }
37 200         22764 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   11593 CORE::eval q{
  200     200   890  
  200     66   368  
  200         20023  
  48         3645  
  54         4467  
  45         3454  
  53         4050  
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       85359 if ($@) {
55 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
56 0         0 *utf8::downgrade = sub { 1 };
  0         0  
57 0         0 *utf8::encode = sub { };
58 0         0 *utf8::decode = sub { 1 };
  0         0  
59 0         0 *utf8::is_utf8 = sub { };
60 0         0 *utf8::valid = sub { 1 };
  0         0  
61             }
62             }
63              
64             # instead of Symbol.pm
65 0         0 BEGIN {
66 200     200   455 my $genpkg = "Symbol::";
67 200         7651 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) && (Ehebrew::index($name, '::') == -1) && (Ehebrew::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   387 if (CORE::eval { local $@; CORE::require strict }) {
  200         293  
  200         1820  
115 200         18327 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   12396 BEGIN { CORE::eval q{ use vars qw($your_char) } } $your_char = q{[\x00-\xFF]};
  200     200   877  
  200         227  
  200         30375  
145 200     200   10141 BEGIN { CORE::eval q{ use vars qw($qq_char ) } } $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  200     200   829  
  200         250  
  200         10412  
146 200     200   9931 BEGIN { CORE::eval q{ use vars qw($q_char ) } } $q_char = qr/$your_char/oxms;
  200     200   783  
  200         259  
  200         11940  
147              
148             #
149             # Hebrew character range per length
150             #
151             my %range_tr = ();
152              
153             #
154             # alias of encoding name
155             #
156 200     200   10074 BEGIN { CORE::eval q{ use vars qw($encoding_alias) } }
  200     200   835  
  200         241  
  200         149809  
157              
158             #
159             # Hebrew 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 Ehebrew \z/oxms) {
175             %range_tr = (
176             1 => [ [0x00..0xFF],
177             ],
178             );
179             $encoding_alias = qr/ \b (?: iso[-_ ]?8859-8 | iec[- ]?8859-8 | hebrew ) \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 = Ehebrew::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 = Ehebrew::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 = \&Hebrew::ord;
224 0         0 *Char::ord_ = \&Hebrew::ord_;
225 0         0 *Char::reverse = \&Hebrew::reverse;
226 0         0 *Char::getc = \&Hebrew::getc;
227 0         0 *Char::length = \&Hebrew::length;
228 0         0 *Char::substr = \&Hebrew::substr;
229 0         0 *Char::index = \&Hebrew::index;
230 0         0 *Char::rindex = \&Hebrew::rindex;
231 0         0 *Char::eval = \&Hebrew::eval;
232 0         0 *Char::escape = \&Hebrew::escape;
233 0         0 *Char::escape_token = \&Hebrew::escape_token;
234 0         0 *Char::escape_script = \&Hebrew::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     sub unimport {}
259             sub Ehebrew::split(;$$$);
260             sub Ehebrew::tr($$$$;$);
261             sub Ehebrew::chop(@);
262             sub Ehebrew::index($$;$);
263             sub Ehebrew::rindex($$;$);
264             sub Ehebrew::lcfirst(@);
265             sub Ehebrew::lcfirst_();
266             sub Ehebrew::lc(@);
267             sub Ehebrew::lc_();
268             sub Ehebrew::ucfirst(@);
269             sub Ehebrew::ucfirst_();
270             sub Ehebrew::uc(@);
271             sub Ehebrew::uc_();
272             sub Ehebrew::fc(@);
273             sub Ehebrew::fc_();
274             sub Ehebrew::ignorecase;
275             sub Ehebrew::classic_character_class;
276             sub Ehebrew::capture;
277             sub Ehebrew::chr(;$);
278             sub Ehebrew::chr_();
279             sub Ehebrew::glob($);
280             sub Ehebrew::glob_();
281              
282             sub Hebrew::ord(;$);
283             sub Hebrew::ord_();
284             sub Hebrew::reverse(@);
285             sub Hebrew::getc(;*@);
286             sub Hebrew::length(;$);
287             sub Hebrew::substr($$;$$);
288             sub Hebrew::index($$;$);
289             sub Hebrew::rindex($$;$);
290             sub Hebrew::escape(;$);
291              
292             #
293             # Regexp work
294             #
295 200     200   12779 BEGIN { CORE::eval q{ use vars qw(
  200     200   927  
  200         268  
  200         65794  
296             $Hebrew::re_a
297             $Hebrew::re_t
298             $Hebrew::re_n
299             $Hebrew::re_r
300             ) } }
301              
302             #
303             # Character class
304             #
305 200     200   13193 BEGIN { CORE::eval q{ use vars qw(
  200     200   865  
  200         331  
  200         2033633  
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             ${Ehebrew::dot} = qr{(?>[^\x0A])};
336             ${Ehebrew::dot_s} = qr{(?>[\x00-\xFF])};
337             ${Ehebrew::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             # ${Ehebrew::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
343             # ${Ehebrew::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
344             ${Ehebrew::eS} = qr{(?>[^\s])};
345              
346             ${Ehebrew::eW} = qr{(?>[^0-9A-Z_a-z])};
347             ${Ehebrew::eH} = qr{(?>[^\x09\x20])};
348             ${Ehebrew::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
349             ${Ehebrew::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
350             ${Ehebrew::eN} = qr{(?>[^\x0A])};
351             ${Ehebrew::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
352             ${Ehebrew::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
353             ${Ehebrew::not_ascii} = qr{(?>[^\x00-\x7F])};
354             ${Ehebrew::not_blank} = qr{(?>[^\x09\x20])};
355             ${Ehebrew::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
356             ${Ehebrew::not_digit} = qr{(?>[^\x30-\x39])};
357             ${Ehebrew::not_graph} = qr{(?>[^\x21-\x7F])};
358             ${Ehebrew::not_lower} = qr{(?>[^\x61-\x7A])};
359             ${Ehebrew::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
360             # ${Ehebrew::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
361             ${Ehebrew::not_print} = qr{(?>[^\x20-\x7F])};
362             ${Ehebrew::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
363             ${Ehebrew::not_space} = qr{(?>[^\s\x0B])};
364             ${Ehebrew::not_upper} = qr{(?>[^\x41-\x5A])};
365             ${Ehebrew::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
366             # ${Ehebrew::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
367             ${Ehebrew::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
368             ${Ehebrew::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
369             ${Ehebrew::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             ${Ehebrew::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 "Ehebrew::foo" used only once: possible typo at here.
373             ${Ehebrew::dot} = ${Ehebrew::dot};
374             ${Ehebrew::dot_s} = ${Ehebrew::dot_s};
375             ${Ehebrew::eD} = ${Ehebrew::eD};
376             ${Ehebrew::eS} = ${Ehebrew::eS};
377             ${Ehebrew::eW} = ${Ehebrew::eW};
378             ${Ehebrew::eH} = ${Ehebrew::eH};
379             ${Ehebrew::eV} = ${Ehebrew::eV};
380             ${Ehebrew::eR} = ${Ehebrew::eR};
381             ${Ehebrew::eN} = ${Ehebrew::eN};
382             ${Ehebrew::not_alnum} = ${Ehebrew::not_alnum};
383             ${Ehebrew::not_alpha} = ${Ehebrew::not_alpha};
384             ${Ehebrew::not_ascii} = ${Ehebrew::not_ascii};
385             ${Ehebrew::not_blank} = ${Ehebrew::not_blank};
386             ${Ehebrew::not_cntrl} = ${Ehebrew::not_cntrl};
387             ${Ehebrew::not_digit} = ${Ehebrew::not_digit};
388             ${Ehebrew::not_graph} = ${Ehebrew::not_graph};
389             ${Ehebrew::not_lower} = ${Ehebrew::not_lower};
390             ${Ehebrew::not_lower_i} = ${Ehebrew::not_lower_i};
391             ${Ehebrew::not_print} = ${Ehebrew::not_print};
392             ${Ehebrew::not_punct} = ${Ehebrew::not_punct};
393             ${Ehebrew::not_space} = ${Ehebrew::not_space};
394             ${Ehebrew::not_upper} = ${Ehebrew::not_upper};
395             ${Ehebrew::not_upper_i} = ${Ehebrew::not_upper_i};
396             ${Ehebrew::not_word} = ${Ehebrew::not_word};
397             ${Ehebrew::not_xdigit} = ${Ehebrew::not_xdigit};
398             ${Ehebrew::eb} = ${Ehebrew::eb};
399             ${Ehebrew::eB} = ${Ehebrew::eB};
400              
401             #
402             # Hebrew split
403             #
404             sub Ehebrew::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             # Hebrew transliteration (tr///)
614             #
615             sub Ehebrew::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             # Hebrew chop
705             #
706             sub Ehebrew::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             # Hebrew index by octet
726             #
727             sub Ehebrew::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             # Hebrew reverse index
751             #
752             sub Ehebrew::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             # Hebrew lower case first with parameter
775             #
776             sub Ehebrew::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 Ehebrew::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
781             }
782             else {
783 0         0 return Ehebrew::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
784             }
785             }
786             else {
787 0         0 return Ehebrew::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
788             }
789             }
790              
791             #
792             # Hebrew lower case first without parameter
793             #
794             sub Ehebrew::lcfirst_() {
795 0     0 0 0 return Ehebrew::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
796             }
797              
798             #
799             # Hebrew lower case with parameter
800             #
801             sub Ehebrew::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 Ehebrew::lc_();
813             }
814             }
815              
816             #
817             # Hebrew lower case without parameter
818             #
819             sub Ehebrew::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             # Hebrew upper case first with parameter
826             #
827             sub Ehebrew::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 Ehebrew::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
832             }
833             else {
834 0         0 return Ehebrew::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
835             }
836             }
837             else {
838 0         0 return Ehebrew::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
839             }
840             }
841              
842             #
843             # Hebrew upper case first without parameter
844             #
845             sub Ehebrew::ucfirst_() {
846 0     0 0 0 return Ehebrew::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
847             }
848              
849             #
850             # Hebrew upper case with parameter
851             #
852             sub Ehebrew::uc(@) {
853 114 50   114 0 173 if (@_) {
854 114         109 my $s = shift @_;
855 114 50 33     222 if (@_ and wantarray) {
856 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
857             }
858             else {
859 114 100       355 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  114         379  
860             }
861             }
862             else {
863 0         0 return Ehebrew::uc_();
864             }
865             }
866              
867             #
868             # Hebrew upper case without parameter
869             #
870             sub Ehebrew::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             # Hebrew fold case with parameter
877             #
878             sub Ehebrew::fc(@) {
879 137 50   137 0 171 if (@_) {
880 137         118 my $s = shift @_;
881 137 50 33     245 if (@_ and wantarray) {
882 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
883             }
884             else {
885 137 100       343 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  137         1124  
886             }
887             }
888             else {
889 0         0 return Ehebrew::fc_();
890             }
891             }
892              
893             #
894             # Hebrew fold case without parameter
895             #
896             sub Ehebrew::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             # Hebrew regexp capture
903             #
904             {
905             sub Ehebrew::capture {
906 0     0 1 0 return $_[0];
907             }
908             }
909              
910             #
911             # Hebrew regexp ignore case modifier
912             #
913             sub Ehebrew::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 = Ehebrew::uc($char[$i]);
1010 0         0 my $fc = Ehebrew::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 Ehebrew::classic_character_class {
1048 1822     1822 0 1659 my($char) = @_;
1049              
1050             return {
1051             '\D' => '${Ehebrew::eD}',
1052             '\S' => '${Ehebrew::eS}',
1053             '\W' => '${Ehebrew::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' => '${Ehebrew::eH}',
1096             '\V' => '${Ehebrew::eV}',
1097             '\h' => '[\x09\x20]',
1098             '\v' => '[\x0A\x0B\x0C\x0D]',
1099             '\R' => '${Ehebrew::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' => '${Ehebrew::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' => '${Ehebrew::eb}',
1122              
1123             # \B really means (?:(?<=\w)(?=\w)|(?
1124             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1125             '\B' => '${Ehebrew::eB}',
1126              
1127 1822   100     73280 }->{$char} || '';
1128             }
1129              
1130             #
1131             # prepare Hebrew 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             # Hebrew 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             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 0         0 }->{$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             # Hebrew 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             # Hebrew octet range
1383             #
1384             sub _octets {
1385 182     182   277 my $length = shift @_;
1386              
1387 182 50       303 if ($length == 1) {
1388 182         487 my($a1) = unpack 'C', $_[0];
1389 182         258 my($z1) = unpack 'C', $_[1];
1390              
1391 182 50       349 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 182 50       465 if ($a1 == $z1) {
    50          
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 182         1344 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             # Hebrew range regexp
1412             #
1413             sub _range_regexp {
1414 182     182   263 my($length,$first,$last) = @_;
1415              
1416 182         218 my @range_regexp = ();
1417 182 50       462 if (not exists $range_tr{$length}) {
1418 0         0 return @range_regexp;
1419             }
1420              
1421 182         175 my @ranges = @{ $range_tr{$length} };
  182         359  
1422 182         578 while (my @range = splice(@ranges,0,$length)) {
1423 182         207 my $min = '';
1424 182         157 my $max = '';
1425 182         428 for (my $i=0; $i < $length; $i++) {
1426 182         695 $min .= pack 'C', $range[$i][0];
1427 182         455 $max .= pack 'C', $range[$i][-1];
1428             }
1429              
1430             # min___max
1431             # FIRST_____________LAST
1432             # (nothing)
1433              
1434 182 50 33     2145 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    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 182         405 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 182         324 return @range_regexp;
1495             }
1496              
1497             #
1498             # Hebrew open character list for qr and not qr
1499             #
1500             sub _charlist {
1501              
1502 346     346   443 my $modifier = pop @_;
1503 346         596 my @char = @_;
1504              
1505 346 100       649 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1506              
1507             # unescape character
1508 346         891 for (my $i=0; $i <= $#char; $i++) {
1509              
1510             # escape - to ...
1511 1101 100 100     8543 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1512 206 100 100     831 if ((0 < $i) and ($i < $#char)) {
1513 182         373 $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 22         91 $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             $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' => '${Ehebrew::eD}',
1572             '\S' => '${Ehebrew::eS}',
1573             '\W' => '${Ehebrew::eW}',
1574              
1575             '\H' => '${Ehebrew::eH}',
1576             '\V' => '${Ehebrew::eV}',
1577             '\h' => '[\x09\x20]',
1578             '\v' => '[\x0A\x0B\x0C\x0D]',
1579             '\R' => '${Ehebrew::eR}',
1580              
1581 25         360 }->{$1};
1582             }
1583              
1584             # POSIX-style character classes
1585             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1586             $char[$i] = {
1587              
1588             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1589             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1590             '[:^lower:]' => '${Ehebrew::not_lower_i}',
1591             '[:^upper:]' => '${Ehebrew::not_upper_i}',
1592              
1593 8         60 }->{$1};
1594             }
1595             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1596             $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:]' => '${Ehebrew::not_alnum}',
1627             '[:^alpha:]' => '${Ehebrew::not_alpha}',
1628             '[:^ascii:]' => '${Ehebrew::not_ascii}',
1629             '[:^blank:]' => '${Ehebrew::not_blank}',
1630             '[:^cntrl:]' => '${Ehebrew::not_cntrl}',
1631             '[:^digit:]' => '${Ehebrew::not_digit}',
1632             '[:^graph:]' => '${Ehebrew::not_graph}',
1633             '[:^lower:]' => '${Ehebrew::not_lower}',
1634             '[:^print:]' => '${Ehebrew::not_print}',
1635             '[:^punct:]' => '${Ehebrew::not_punct}',
1636             '[:^space:]' => '${Ehebrew::not_space}',
1637             '[:^upper:]' => '${Ehebrew::not_upper}',
1638             '[:^word:]' => '${Ehebrew::not_word}',
1639             '[:^xdigit:]' => '${Ehebrew::not_xdigit}',
1640              
1641 70         1291 }->{$1};
1642             }
1643             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1644 7         34 $char[$i] = $1;
1645             }
1646             }
1647              
1648             # open character list
1649 346         498 my @singleoctet = ();
1650 346         369 my @multipleoctet = ();
1651 346         758 for (my $i=0; $i <= $#char; ) {
1652              
1653             # escaped -
1654 919 100 100     3949 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1655 182         173 $i += 1;
1656 182         335 next;
1657             }
1658              
1659             # make range regexp
1660             elsif ($char[$i] eq '...') {
1661              
1662             # range error
1663 182 50       659 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
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 182 50       445 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 182         550 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1674 182         227 my @regexp = ();
1675              
1676             # is first and last
1677 182 50 33     822 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1678 182         460 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 182 50       386 if ($length == 1) {
1701 182         373 push @singleoctet, @regexp;
1702             }
1703             else {
1704 0         0 push @multipleoctet, @regexp;
1705             }
1706             }
1707              
1708 182         354 $i += 2;
1709             }
1710              
1711             # with /i modifier
1712             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1713 469 50       535 if ($modifier =~ /i/oxms) {
1714 0         0 my $uc = Ehebrew::uc($char[$i]);
1715 0         0 my $fc = Ehebrew::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 469         500 push @singleoctet, $char[$i];
1731             }
1732 469         634 $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 2         4 push @singleoctet, $char[$i];
1746 2         6 $i += 1;
1747             }
1748              
1749             # single character of multiple-octet code
1750             else {
1751 84         122 push @multipleoctet, $char[$i];
1752 84         142 $i += 1;
1753             }
1754             }
1755              
1756             # quote metachar
1757 346         612 for (@singleoctet) {
1758 653 50       2863 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1759 0         0 $_ = '-';
1760             }
1761             elsif (/\A \n \z/oxms) {
1762 8         15 $_ = '\n';
1763             }
1764             elsif (/\A \r \z/oxms) {
1765 8         15 $_ = '\r';
1766             }
1767             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1768 24         80 $_ = sprintf('\x%02X', CORE::ord $1);
1769             }
1770             elsif (/\A [\x00-\xFF] \z/oxms) {
1771 429         468 $_ = quotemeta $_;
1772             }
1773             }
1774              
1775             # return character list
1776 346         883 return \@singleoctet, \@multipleoctet;
1777             }
1778              
1779             #
1780             # Hebrew octal escape sequence
1781             #
1782             sub octchr {
1783 5     5 0 9 my($octdigit) = @_;
1784              
1785 5         6 my @binary = ();
1786 5         16 for my $octal (split(//,$octdigit)) {
1787             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 50         137 }->{$octal};
1797             }
1798 5         13 my $binary = join '', @binary;
1799              
1800             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 5         61 }->{CORE::length($binary) % 8};
1812              
1813 5         18 return $octchr;
1814             }
1815              
1816             #
1817             # Hebrew hexadecimal escape sequence
1818             #
1819             sub hexchr {
1820 5     5 0 10 my($hexdigit) = @_;
1821              
1822             my $hexchr = {
1823             1 => pack('H*', "0$hexdigit"),
1824             0 => pack('H*', "$hexdigit"),
1825              
1826 5         42 }->{CORE::length($_[0]) % 2};
1827              
1828 5         15 return $hexchr;
1829             }
1830              
1831             #
1832             # Hebrew open character list for qr
1833             #
1834             sub charlist_qr {
1835              
1836 302     302 0 480 my $modifier = pop @_;
1837 302         633 my @char = @_;
1838              
1839 302         710 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1840 302         561 my @singleoctet = @$singleoctet;
1841 302         370 my @multipleoctet = @$multipleoctet;
1842              
1843             # return character list
1844 302 100       643 if (scalar(@singleoctet) >= 1) {
1845              
1846             # with /i modifier
1847 224 100       433 if ($modifier =~ m/i/oxms) {
1848 10         15 my %singleoctet_ignorecase = ();
1849 10         10 for (@singleoctet) {
1850 10   66     60 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1851 10         31 for my $ord (hex($1) .. hex($2)) {
1852 30         32 my $char = CORE::chr($ord);
1853 30         40 my $uc = Ehebrew::uc($char);
1854 30         44 my $fc = Ehebrew::fc($char);
1855 30 50       41 if ($uc eq $fc) {
1856 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1857             }
1858             else {
1859 30 50       32 if (CORE::length($fc) == 1) {
1860 30         49 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1861 30         83 $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 10 50       16 if ($_ ne '') {
1871 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1872             }
1873             }
1874 10         8 my $i = 0;
1875 10         12 my @singleoctet_ignorecase = ();
1876 10         13 for my $ord (0 .. 255) {
1877 2560 100       2207 if (exists $singleoctet_ignorecase{$ord}) {
1878 60         31 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         77  
1879             }
1880             else {
1881 2500         1518 $i++;
1882             }
1883             }
1884 10         13 @singleoctet = ();
1885 10         22 for my $range (@singleoctet_ignorecase) {
1886 960 100       1258 if (ref $range) {
1887 20 50       13 if (scalar(@{$range}) == 1) {
  20 50       29  
1888 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1889             }
1890 20         20 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 20         14 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         19  
  20         69  
1895             }
1896             }
1897             }
1898             }
1899              
1900 224         271 my $not_anchor = '';
1901              
1902 224         518 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1903             }
1904 302 100       542 if (scalar(@multipleoctet) >= 2) {
1905 6         26 return '(?:' . join('|', @multipleoctet) . ')';
1906             }
1907             else {
1908 296         1157 return $multipleoctet[0];
1909             }
1910             }
1911              
1912             #
1913             # Hebrew open character list for not qr
1914             #
1915             sub charlist_not_qr {
1916              
1917 44     44 0 66 my $modifier = pop @_;
1918 44         77 my @char = @_;
1919              
1920 44         91 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1921 44         76 my @singleoctet = @$singleoctet;
1922 44         52 my @multipleoctet = @$multipleoctet;
1923              
1924             # with /i modifier
1925 44 100       87 if ($modifier =~ m/i/oxms) {
1926 10         13 my %singleoctet_ignorecase = ();
1927 10         10 for (@singleoctet) {
1928 10   66     39 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1929 10         27 for my $ord (hex($1) .. hex($2)) {
1930 30         26 my $char = CORE::chr($ord);
1931 30         39 my $uc = Ehebrew::uc($char);
1932 30         34 my $fc = Ehebrew::fc($char);
1933 30 50       40 if ($uc eq $fc) {
1934 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1935             }
1936             else {
1937 30 50       28 if (CORE::length($fc) == 1) {
1938 30         49 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1939 30         78 $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 10 50       21 if ($_ ne '') {
1949 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1950             }
1951             }
1952 10         6 my $i = 0;
1953 10         9 my @singleoctet_ignorecase = ();
1954 10         11 for my $ord (0 .. 255) {
1955 2560 100       2090 if (exists $singleoctet_ignorecase{$ord}) {
1956 60         31 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         72  
1957             }
1958             else {
1959 2500         1506 $i++;
1960             }
1961             }
1962 10         11 @singleoctet = ();
1963 10         16 for my $range (@singleoctet_ignorecase) {
1964 960 100       1277 if (ref $range) {
1965 20 50       15 if (scalar(@{$range}) == 1) {
  20 50       27  
1966 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1967             }
1968 20         23 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 20         15 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         21  
  20         69  
1973             }
1974             }
1975             }
1976             }
1977              
1978             # return character list
1979 44 50       103 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 44 50       69 if (scalar(@singleoctet) >= 1) {
1993              
1994             # any character other than single octet character class
1995 44         211 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 400     400   2525 my(undef,$file) = @_;
2010 400         1873 $file =~ s#\A (\s) #./$1#oxms;
2011 400   33     29372 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   619 $| = 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         1650 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         495 return CORE::system { $_[0] } @_; # safe even with one-argument list
  200         14309485  
2115             }
2116              
2117             #
2118             # Hebrew order to character (with parameter)
2119             #
2120             sub Ehebrew::chr(;$) {
2121              
2122 0 0   0 0 0 my $c = @_ ? $_[0] : $_;
2123              
2124 0 0       0 if ($c == 0x00) {
2125 0         0 return "\x00";
2126             }
2127             else {
2128 0         0 my @chr = ();
2129 0         0 while ($c > 0) {
2130 0         0 unshift @chr, ($c % 0x100);
2131 0         0 $c = int($c / 0x100);
2132             }
2133 0         0 return pack 'C*', @chr;
2134             }
2135             }
2136              
2137             #
2138             # Hebrew order to character (without parameter)
2139             #
2140             sub Ehebrew::chr_() {
2141              
2142 0     0 0 0 my $c = $_;
2143              
2144 0 0       0 if ($c == 0x00) {
2145 0         0 return "\x00";
2146             }
2147             else {
2148 0         0 my @chr = ();
2149 0         0 while ($c > 0) {
2150 0         0 unshift @chr, ($c % 0x100);
2151 0         0 $c = int($c / 0x100);
2152             }
2153 0         0 return pack 'C*', @chr;
2154             }
2155             }
2156              
2157             #
2158             # Hebrew path globbing (with parameter)
2159             #
2160             sub Ehebrew::glob($) {
2161              
2162 0 0   0 0 0 if (wantarray) {
2163 0         0 my @glob = _DOS_like_glob(@_);
2164 0         0 for my $glob (@glob) {
2165 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2166             }
2167 0         0 return @glob;
2168             }
2169             else {
2170 0         0 my $glob = _DOS_like_glob(@_);
2171 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2172 0         0 return $glob;
2173             }
2174             }
2175              
2176             #
2177             # Hebrew path globbing (without parameter)
2178             #
2179             sub Ehebrew::glob_() {
2180              
2181 0 0   0 0 0 if (wantarray) {
2182 0         0 my @glob = _DOS_like_glob();
2183 0         0 for my $glob (@glob) {
2184 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2185             }
2186 0         0 return @glob;
2187             }
2188             else {
2189 0         0 my $glob = _DOS_like_glob();
2190 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2191 0         0 return $glob;
2192             }
2193             }
2194              
2195             #
2196             # Hebrew 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   0 my($expr,$cxix) = @_;
2207              
2208             # glob without args defaults to $_
2209 0 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       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2221 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
2222 0         0 { my_home_MSWin32() }oxmse;
2223             }
2224              
2225             # UNIX-like system
2226             else {
2227 0         0 $expr =~ s{ \A ~ ( (?:[^/])* ) }
2228 0 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       0 $cxix = '_G_' if not defined $cxix;
2233 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
2234              
2235             # if we're just beginning, do it all first
2236 0 0       0 if ($iter{$cxix} == 0) {
2237 0         0 $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2238             }
2239              
2240             # chuck it all out, quick or slow
2241 0 0       0 if (wantarray) {
2242 0         0 delete $iter{$cxix};
2243 0         0 return @{delete $entries{$cxix}};
  0         0  
2244             }
2245             else {
2246 0 0       0 if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0         0  
2247 0         0 return shift @{$entries{$cxix}};
  0         0  
2248             }
2249             else {
2250             # return undef for EOL
2251 0         0 delete $iter{$cxix};
2252 0         0 delete $entries{$cxix};
2253 0         0 return undef;
2254             }
2255             }
2256             }
2257              
2258             #
2259             # Hebrew path globbing subroutine
2260             #
2261             sub _do_glob {
2262              
2263 0     0   0 my($cond,@expr) = @_;
2264 0         0 my @glob = ();
2265 0         0 my $fix_drive_relative_paths = 0;
2266              
2267             OUTER:
2268 0         0 for my $expr (@expr) {
2269 0 0       0 next OUTER if not defined $expr;
2270 0 0       0 next OUTER if $expr eq '';
2271              
2272 0         0 my @matched = ();
2273 0         0 my @globdir = ();
2274 0         0 my $head = '.';
2275 0         0 my $pathsep = '/';
2276 0         0 my $tail;
2277              
2278             # if argument is within quotes strip em and do no globbing
2279 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2280 0         0 $expr = $1;
2281 0 0       0 if ($cond eq 'd') {
2282 0 0       0 if (-d $expr) {
2283 0         0 push @glob, $expr;
2284             }
2285             }
2286             else {
2287 0 0       0 if (-e $expr) {
2288 0         0 push @glob, $expr;
2289             }
2290             }
2291 0         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       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2297 0 0       0 if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2298 0         0 $fix_drive_relative_paths = 1;
2299             }
2300             }
2301              
2302 0 0       0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2303 0 0       0 if ($tail eq '') {
2304 0         0 push @glob, $expr;
2305 0         0 next OUTER;
2306             }
2307 0 0       0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2308 0 0       0 if (@globdir = _do_glob('d', $head)) {
2309 0         0 push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0         0  
2310 0         0 next OUTER;
2311             }
2312             }
2313 0 0 0     0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2314 0         0 $head .= $pathsep;
2315             }
2316 0         0 $expr = $tail;
2317             }
2318              
2319             # If file component has no wildcards, we can avoid opendir
2320 0 0       0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2321 0 0       0 if ($head eq '.') {
2322 0         0 $head = '';
2323             }
2324 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2325 0         0 $head .= $pathsep;
2326             }
2327 0         0 $head .= $expr;
2328 0 0       0 if ($cond eq 'd') {
2329 0 0       0 if (-d $head) {
2330 0         0 push @glob, $head;
2331             }
2332             }
2333             else {
2334 0 0       0 if (-e $head) {
2335 0         0 push @glob, $head;
2336             }
2337             }
2338 0         0 next OUTER;
2339             }
2340 0 0       0 opendir(*DIR, $head) or next OUTER;
2341 0         0 my @leaf = readdir DIR;
2342 0         0 closedir DIR;
2343              
2344 0 0       0 if ($head eq '.') {
2345 0         0 $head = '';
2346             }
2347 0 0 0     0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2348 0         0 $head .= $pathsep;
2349             }
2350              
2351 0         0 my $pattern = '';
2352 0         0 while ($expr =~ / \G ($q_char) /oxgc) {
2353 0         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       0 if ($char eq '*') {
    0          
    0          
2361 0         0 $pattern .= "(?:$your_char)*",
2362             }
2363             elsif ($char eq '?') {
2364 0         0 $pattern .= "(?:$your_char)?", # DOS style
2365             # $pattern .= "(?:$your_char)", # UNIX style
2366             }
2367             elsif ((my $fc = Ehebrew::fc($char)) ne $char) {
2368 0         0 $pattern .= $fc;
2369             }
2370             else {
2371 0         0 $pattern .= quotemeta $char;
2372             }
2373             }
2374 0     0   0 my $matchsub = sub { Ehebrew::fc($_[0]) =~ /\A $pattern \z/xms };
  0         0  
2375              
2376             # if ($@) {
2377             # print STDERR "$0: $@\n";
2378             # next OUTER;
2379             # }
2380              
2381             INNER:
2382 0         0 for my $leaf (@leaf) {
2383 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
2384 0         0 next INNER;
2385             }
2386 0 0 0     0 if ($cond eq 'd' and not -d "$head$leaf") {
2387 0         0 next INNER;
2388             }
2389              
2390 0 0       0 if (&$matchsub($leaf)) {
2391 0         0 push @matched, "$head$leaf";
2392 0         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     0 if (Ehebrew::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             Ehebrew::index($pattern,'\\.') != -1 # pattern has a dot.
2401             ) {
2402 0 0       0 if (&$matchsub("$leaf.")) {
2403 0         0 push @matched, "$head$leaf";
2404 0         0 next INNER;
2405             }
2406             }
2407             }
2408 0 0       0 if (@matched) {
2409 0         0 push @glob, @matched;
2410             }
2411             }
2412 0 0       0 if ($fix_drive_relative_paths) {
2413 0         0 for my $glob (@glob) {
2414 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2415             }
2416             }
2417 0         0 return @glob;
2418             }
2419              
2420             #
2421             # Hebrew parse line
2422             #
2423             sub _parse_line {
2424              
2425 0     0   0 my($line) = @_;
2426              
2427 0         0 $line .= ' ';
2428 0         0 my @piece = ();
2429 0         0 while ($line =~ /
2430             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2431             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2432             /oxmsg
2433             ) {
2434 0 0       0 push @piece, defined($1) ? $1 : $2;
2435             }
2436 0         0 return @piece;
2437             }
2438              
2439             #
2440             # Hebrew parse path
2441             #
2442             sub _parse_path {
2443              
2444 0     0   0 my($path,$pathsep) = @_;
2445              
2446 0         0 $path .= '/';
2447 0         0 my @subpath = ();
2448 0         0 while ($path =~ /
2449             ((?: [^\/\\] )+?) [\/\\]
2450             /oxmsg
2451             ) {
2452 0         0 push @subpath, $1;
2453             }
2454              
2455 0         0 my $tail = pop @subpath;
2456 0         0 my $head = join $pathsep, @subpath;
2457 0         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 0 if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2469 0         0 return $ENV{'HOME'};
2470             }
2471              
2472             # Do we have a user profile?
2473             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2474 0         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         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2480             }
2481              
2482 0         0 return undef;
2483             }
2484              
2485             #
2486             # via File::HomeDir::Unix 1.00
2487             #
2488             sub my_home {
2489 0     0 0 0 my $home;
2490              
2491 0 0 0     0 if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2492 0         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         0 $home = $ENV{'LOGDIR'};
2499             }
2500              
2501             ### More-desperate methods
2502              
2503             # Light desperation on any (Unixish) platform
2504             else {
2505 0         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     0 if (defined $home and ! -d($home)) {
2511 0         0 $home = undef;
2512             }
2513 0         0 return $home;
2514             }
2515              
2516             #
2517             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2518             #
2519             sub Ehebrew::PREMATCH {
2520 0     0 0 0 return $`;
2521             }
2522              
2523             #
2524             # ${^MATCH}, $MATCH, $& the string that matched
2525             #
2526             sub Ehebrew::MATCH {
2527 0     0 0 0 return $&;
2528             }
2529              
2530             #
2531             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2532             #
2533             sub Ehebrew::POSTMATCH {
2534 0     0 0 0 return $';
2535             }
2536              
2537             #
2538             # Hebrew character to order (with parameter)
2539             #
2540             sub Hebrew::ord(;$) {
2541              
2542 0 0   0 1 0 local $_ = shift if @_;
2543              
2544 0 0       0 if (/\A ($q_char) /oxms) {
2545 0         0 my @ord = unpack 'C*', $1;
2546 0         0 my $ord = 0;
2547 0         0 while (my $o = shift @ord) {
2548 0         0 $ord = $ord * 0x100 + $o;
2549             }
2550 0         0 return $ord;
2551             }
2552             else {
2553 0         0 return CORE::ord $_;
2554             }
2555             }
2556              
2557             #
2558             # Hebrew character to order (without parameter)
2559             #
2560             sub Hebrew::ord_() {
2561              
2562 0 0   0 0 0 if (/\A ($q_char) /oxms) {
2563 0         0 my @ord = unpack 'C*', $1;
2564 0         0 my $ord = 0;
2565 0         0 while (my $o = shift @ord) {
2566 0         0 $ord = $ord * 0x100 + $o;
2567             }
2568 0         0 return $ord;
2569             }
2570             else {
2571 0         0 return CORE::ord $_;
2572             }
2573             }
2574              
2575             #
2576             # Hebrew reverse
2577             #
2578             sub Hebrew::reverse(@) {
2579              
2580 0 0   0 0 0 if (wantarray) {
2581 0         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         0 return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2591             }
2592             }
2593              
2594             #
2595             # Hebrew getc (with parameter, without parameter)
2596             #
2597             sub Hebrew::getc(;*@) {
2598              
2599 0     0 0 0 my($package) = caller;
2600 0 0       0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2601 0 0 0     0 croak 'Too many arguments for Hebrew::getc' if @_ and not wantarray;
2602              
2603 0         0 my @length = sort { $a <=> $b } keys %range_tr;
  0         0  
2604 0         0 my $getc = '';
2605 0         0 for my $length ($length[0] .. $length[-1]) {
2606 0         0 $getc .= CORE::getc($fh);
2607 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2608 0 0       0 if ($getc =~ /\A ${Ehebrew::dot_s} \z/oxms) {
2609 0 0       0 return wantarray ? ($getc,@_) : $getc;
2610             }
2611             }
2612             }
2613 0 0       0 return wantarray ? ($getc,@_) : $getc;
2614             }
2615              
2616             #
2617             # Hebrew length by character
2618             #
2619             sub Hebrew::length(;$) {
2620              
2621 0 0   0 1 0 local $_ = shift if @_;
2622              
2623 0         0 local @_ = /\G ($q_char) /oxmsg;
2624 0         0 return scalar @_;
2625             }
2626              
2627             #
2628             # Hebrew 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 94846 CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2645             # vv----------------------*******
2646             sub Hebrew::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             # Hebrew index by character
2720             #
2721             sub Hebrew::index($$;$) {
2722              
2723 0     0 1 0 my $index;
2724 0 0       0 if (@_ == 3) {
2725 0         0 $index = Ehebrew::index($_[0], $_[1], CORE::length(Hebrew::substr($_[0], 0, $_[2])));
2726             }
2727             else {
2728 0         0 $index = Ehebrew::index($_[0], $_[1]);
2729             }
2730              
2731 0 0       0 if ($index == -1) {
2732 0         0 return -1;
2733             }
2734             else {
2735 0         0 return Hebrew::length(CORE::substr $_[0], 0, $index);
2736             }
2737             }
2738              
2739             #
2740             # Hebrew rindex by character
2741             #
2742             sub Hebrew::rindex($$;$) {
2743              
2744 0     0 1 0 my $rindex;
2745 0 0       0 if (@_ == 3) {
2746 0         0 $rindex = Ehebrew::rindex($_[0], $_[1], CORE::length(Hebrew::substr($_[0], 0, $_[2])));
2747             }
2748             else {
2749 0         0 $rindex = Ehebrew::rindex($_[0], $_[1]);
2750             }
2751              
2752 0 0       0 if ($rindex == -1) {
2753 0         0 return -1;
2754             }
2755             else {
2756 0         0 return Hebrew::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   13427 BEGIN { CORE::eval q{ use vars qw($slash) } } $slash = 'm//';
  200     200   1415  
  200         293  
  200         11068  
2763              
2764             # ord() to ord() or Hebrew::ord()
2765 200     200   10815 BEGIN { CORE::eval q{ use vars qw($function_ord) } } $function_ord = 'ord';
  200     200   935  
  200         327  
  200         9320  
2766              
2767             # ord to ord or Hebrew::ord_
2768 200     200   9799 BEGIN { CORE::eval q{ use vars qw($function_ord_) } } $function_ord_ = 'ord';
  200     200   888  
  200         277  
  200         12435  
2769              
2770             # reverse to reverse or Hebrew::reverse
2771 200     200   10261 BEGIN { CORE::eval q{ use vars qw($function_reverse) } } $function_reverse = 'reverse';
  200     200   870  
  200         288  
  200         9171  
2772              
2773             # getc to getc or Hebrew::getc
2774 200     200   9167 BEGIN { CORE::eval q{ use vars qw($function_getc) } } $function_getc = 'getc';
  200     200   830  
  200         269  
  200         9693  
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   9601 BEGIN { CORE::eval q{ use vars qw($nest) } }
  200     200   818  
  200         291  
  200         7119210  
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 | Hebrew::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 Hebrew script
2889             #
2890             sub Hebrew::escape(;$) {
2891 200 50   200 0 2266 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 200         1093 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 200         310 my $e_script = '';
2919 200         2422 while (not /\G \z/oxgc) { # member
2920 70108         79688 $e_script .= Hebrew::escape_token();
2921             }
2922              
2923 200         2204 return $e_script;
2924             }
2925              
2926             #
2927             # escape Hebrew token of script
2928             #
2929             sub Hebrew::escape_token {
2930              
2931             # \n output here document
2932              
2933 70108     70108 0 54432 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 70108 100 100     3489672 if (/\G ( \n ) /oxgc) { # another member (and so on)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
2953 11798         9874 my $heredoc = '';
2954 11798 100       20733 if (scalar(@heredoc_delimiter) >= 1) {
2955 150         156 $slash = 'm//';
2956              
2957 150         229 $heredoc = join '', @heredoc;
2958 150         249 @heredoc = ();
2959              
2960             # skip here document
2961 150         241 for my $heredoc_delimiter (@heredoc_delimiter) {
2962 150         1066 /\G .*? \n $heredoc_delimiter \n/xmsgc;
2963             }
2964 150         191 @heredoc_delimiter = ();
2965              
2966 150         163 $here_script = '';
2967             }
2968 11798         30702 return "\n" . $heredoc;
2969             }
2970              
2971             # ignore space, comment
2972 16514         41519 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 1351         1428 $slash = 'm//';
2988 1351         3676 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 85         175 my $e_string = e_string($1);
3008              
3009 85 50       1691 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    50          
3010 0         0 $tr_variable = $e_string . e_string($1);
3011 0         0 $bind_operator = $2;
3012 0         0 $slash = 'm//';
3013 0         0 return '';
3014             }
3015             elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3016 0         0 $sub_variable = $e_string . e_string($1);
3017 0         0 $bind_operator = $2;
3018 0         0 $slash = 'm//';
3019 0         0 return '';
3020             }
3021             else {
3022 85         103 $slash = 'div';
3023 85         254 return $e_string;
3024             }
3025             }
3026              
3027             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ehebrew::PREMATCH()
3028             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3029 4         7 $slash = 'div';
3030 4         15 return q{Ehebrew::PREMATCH()};
3031             }
3032              
3033             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ehebrew::MATCH()
3034             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3035 28         48 $slash = 'div';
3036 28         87 return q{Ehebrew::MATCH()};
3037             }
3038              
3039             # $', ${'} --> $', ${'}
3040             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3041 1         3 $slash = 'div';
3042 1         5 return $1;
3043             }
3044              
3045             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ehebrew::POSTMATCH()
3046             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3047 3         5 $slash = 'div';
3048 3         10 return q{Ehebrew::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 1601         2762 my $scalar = e_string($1);
3057              
3058 1601 100       5959 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
    100          
3059 1         2 $tr_variable = $scalar;
3060 1         2 $bind_operator = $1;
3061 1         1 $slash = 'm//';
3062 1         2 return '';
3063             }
3064             elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3065 61         110 $sub_variable = $scalar;
3066 61         108 $bind_operator = $1;
3067 61         77 $slash = 'm//';
3068 61         177 return '';
3069             }
3070             else {
3071 1539         1513 $slash = 'div';
3072 1539         3783 return $scalar;
3073             }
3074             }
3075              
3076             # end of statement
3077             elsif (/\G ( [,;] ) /oxgc) {
3078 4403         4406 $slash = 'm//';
3079              
3080             # clear tr/// variable
3081 4403         3630 $tr_variable = '';
3082              
3083             # clear s/// variable
3084 4403         3267 $sub_variable = '';
3085              
3086 4403         3197 $bind_operator = '';
3087              
3088 4403         13087 return $1;
3089             }
3090              
3091             # bareword
3092             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3093 0         0 return $1;
3094             }
3095              
3096             # $0 --> $0
3097             elsif (/\G ( \$ 0 ) /oxmsgc) {
3098 2         4 $slash = 'div';
3099 2         5 return $1;
3100             }
3101             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3102 0         0 $slash = 'div';
3103 0         0 return $1;
3104             }
3105              
3106             # $$ --> $$
3107             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3108 1         2 $slash = 'div';
3109 1         5 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 4         8 $slash = 'div';
3116 4         13 return e_capture($1);
3117             }
3118             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3119 0         0 $slash = 'div';
3120 0         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         0 $slash = 'div';
3126 0         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         0 $slash = 'div';
3132 0         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         0 $slash = 'div';
3138 0         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         0 $slash = 'div';
3144 0         0 return '${' . $1 . '}';
3145             }
3146              
3147             # ${ ... }
3148             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3149 0         0 $slash = 'div';
3150 0         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 32         36 $slash = 'div';
3157 32         101 return $1;
3158             }
3159             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3160             # $ @ # \ ' " / ? ( ) [ ] < >
3161             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3162 60         108 $slash = 'div';
3163 60         202 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         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         0 return 'while ($_ = Ehebrew::glob("' . $1 . '"))';
3177             }
3178              
3179             # while (glob)
3180             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3181 0         0 return 'while ($_ = Ehebrew::glob_)';
3182             }
3183              
3184             # while (glob(WILDCARD))
3185             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3186 0         0 return 'while ($_ = Ehebrew::glob';
3187             }
3188              
3189             # doit if, doit unless, doit while, doit until, doit for, doit when
3190 241         431 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  241         853  
3191              
3192             # subroutines of package Ehebrew
3193 19         23 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  19         63  
3194 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3195 13         25 elsif (/\G \b Hebrew::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  13         43  
3196 0         0 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  0         0  
3197 114         121 elsif (/\G \b Hebrew::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Hebrew::escape'; }
  114         288  
3198 2         5 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         6  
3199 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::chop'; }
  0         0  
3200 2         6 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         6  
3201 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3202 0         0 elsif (/\G \b Hebrew::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Hebrew::index'; }
  0         0  
3203 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::index'; }
  0         0  
3204 2         6 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         7  
3205 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3206 0         0 elsif (/\G \b Hebrew::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Hebrew::rindex'; }
  0         0  
3207 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::rindex'; }
  0         0  
3208 1         1 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::lc'; }
  1         3  
3209 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::lcfirst'; }
  0         0  
3210 1         1 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::uc'; }
  1         3  
3211 0         0 elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::ucfirst'; }
  0         0  
3212 2         3 elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::fc'; }
  2         5  
3213              
3214             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
3215 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3216 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3217 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3218 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3219 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3220 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3221 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3222              
3223 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3224 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3225 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3226 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3227 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3228 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3229 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3230              
3231             elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
3232 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3233 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3234 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  0         0  
3235 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  0         0  
3236              
3237 2         6 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         10  
3238 2         5 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         10  
3239 36         52 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::chr'; }
  36         104  
3240 2         5 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  2         8  
3241 8         10 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  8         19  
3242 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Ehebrew::glob'; }
  0         0  
3243 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::lc_'; }
  0         0  
3244 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::lcfirst_'; }
  0         0  
3245 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::uc_'; }
  0         0  
3246 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::ucfirst_'; }
  0         0  
3247 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::fc_'; }
  0         0  
3248 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3249              
3250 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3251 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3252 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::chr_'; }
  0         0  
3253 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3254 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3255 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Ehebrew::glob_'; }
  0         0  
3256 0         0 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
3257 8         15 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  8         33  
3258             # split
3259             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3260 87         164 $slash = 'm//';
3261              
3262 87         129 my $e = '';
3263 87         373 while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3264 85         390 $e .= $1;
3265             }
3266              
3267             # end of split
3268 87 100       7227 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Ehebrew::split' . $e; }
  2 100       14  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3269              
3270             # split scalar value
3271 1         3 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Ehebrew::split' . $e . e_string($1); }
3272              
3273             # split literal space
3274 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Ehebrew::split' . $e . qq {qq$1 $2}; }
3275 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ehebrew::split' . $e . qq{$1qq$2 $3}; }
3276 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ehebrew::split' . $e . qq{$1qq$2 $3}; }
3277 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ehebrew::split' . $e . qq{$1qq$2 $3}; }
3278 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ehebrew::split' . $e . qq{$1qq$2 $3}; }
3279 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ehebrew::split' . $e . qq{$1qq$2 $3}; }
3280 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Ehebrew::split' . $e . qq {q$1 $2}; }
3281 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Ehebrew::split' . $e . qq {$1q$2 $3}; }
3282 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Ehebrew::split' . $e . qq {$1q$2 $3}; }
3283 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Ehebrew::split' . $e . qq {$1q$2 $3}; }
3284 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Ehebrew::split' . $e . qq {$1q$2 $3}; }
3285 0         0 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Ehebrew::split' . $e . qq {$1q$2 $3}; }
3286 10         52 elsif (/\G ' [ ] ' /oxgc) { return 'Ehebrew::split' . $e . qq {' '}; }
3287 0         0 elsif (/\G " [ ] " /oxgc) { return 'Ehebrew::split' . $e . qq {" "}; }
3288              
3289             # split qq//
3290             elsif (/\G \b (qq) \b /oxgc) {
3291 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0         0  
3292             else {
3293 0         0 while (not /\G \z/oxgc) {
3294 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3295 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3296 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3297 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3298 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3299 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3300 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3301             }
3302 0         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 12 50       482 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  0         0  
3309             else {
3310 12         60 while (not /\G \z/oxgc) {
3311 12 50       3345 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3312 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3313 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3314 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3315 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3316 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3317 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3318 12         74 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3319             }
3320 0         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       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0         0  
3327             else {
3328 0         0 while (not /\G \z/oxgc) {
3329 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3330 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3331 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3332 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3333 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3334 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3335 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3336             }
3337 0         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 18 50       518 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  0         0  
3344             else {
3345 18         80 while (not /\G \z/oxgc) {
3346 18 50       3538 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    50          
    50          
3347 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3348 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3349 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3350 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3351 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3352 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3353 18         94 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3354             }
3355 0         0 die __FILE__, ": Search pattern not terminated\n";
3356             }
3357             }
3358              
3359             # split ''
3360             elsif (/\G (\') /oxgc) {
3361 0         0 my $q_string = '';
3362 0         0 while (not /\G \z/oxgc) {
3363 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3364 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3365 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3366 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3367             }
3368 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3369             }
3370              
3371             # split ""
3372             elsif (/\G (\") /oxgc) {
3373 0         0 my $qq_string = '';
3374 0         0 while (not /\G \z/oxgc) {
3375 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3376 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3377 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3378 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3379             }
3380 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3381             }
3382              
3383             # split //
3384             elsif (/\G (\/) /oxgc) {
3385 44         83 my $regexp = '';
3386 44         182 while (not /\G \z/oxgc) {
3387 381 50       1804 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3388 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3389 44         222 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3390 337         840 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3391             }
3392 0         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 3         6 my $ope = $1;
3406              
3407             # $1 $2 $3 $4 $5 $6
3408 3 50       39 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3409 0         0 my @tr = ($tr_variable,$2);
3410 0         0 return e_tr(@tr,'',$4,$6);
3411             }
3412             else {
3413 3         4 my $e = '';
3414 3         8 while (not /\G \z/oxgc) {
3415 3 50       196 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
3416             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3417 0         0 my @tr = ($tr_variable,$2);
3418 0         0 while (not /\G \z/oxgc) {
3419 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3420 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3421 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3422 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3423 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3424 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3425             }
3426 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3427             }
3428             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3429 0         0 my @tr = ($tr_variable,$2);
3430 0         0 while (not /\G \z/oxgc) {
3431 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3432 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3433 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3434 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3435 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3436 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3437             }
3438 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3439             }
3440             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3441 0         0 my @tr = ($tr_variable,$2);
3442 0         0 while (not /\G \z/oxgc) {
3443 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3444 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3445 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3446 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3447 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3448 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3449             }
3450 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
3451             }
3452             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3453 0         0 my @tr = ($tr_variable,$2);
3454 0         0 while (not /\G \z/oxgc) {
3455 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3456 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3457 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3458 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3459 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3460 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3461             }
3462 0         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 3         7 my @tr = ($tr_variable,$2);
3467 3         15 return e_tr(@tr,'',$4,$6);
3468             }
3469             }
3470 0         0 die __FILE__, ": Transliteration pattern not terminated\n";
3471             }
3472             }
3473              
3474             # qq//
3475             elsif (/\G \b (qq) \b /oxgc) {
3476 2086         3272 my $ope = $1;
3477              
3478             # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3479 2086 50       3102 if (/\G (\#) /oxgc) { # qq# #
3480 0         0 my $qq_string = '';
3481 0         0 while (not /\G \z/oxgc) {
3482 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3483 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3484 0         0 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3485 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3486             }
3487 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3488             }
3489              
3490             else {
3491 2086         1942 my $e = '';
3492 2086         4187 while (not /\G \z/oxgc) {
3493 2086 50       7203 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    50          
    0          
3494              
3495             # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3496             elsif (/\G (\() /oxgc) { # qq ( )
3497 0         0 my $qq_string = '';
3498 0         0 local $nest = 1;
3499 0         0 while (not /\G \z/oxgc) {
3500 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3501 0         0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3502 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3503             elsif (/\G (\)) /oxgc) {
3504 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
  0         0  
3505 0         0 else { $qq_string .= $1; }
3506             }
3507 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3508             }
3509 0         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 2056         1877 my $qq_string = '';
3515 2056         2267 local $nest = 1;
3516 2056         4319 while (not /\G \z/oxgc) {
3517 81920 100       248117 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  610 50       1052  
    100          
    100          
    50          
3518 0         0 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3519 1123         1121 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  1123         1819  
3520             elsif (/\G (\}) /oxgc) {
3521 3179 100       3813 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
  2056         3548  
3522 1123         2134 else { $qq_string .= $1; }
3523             }
3524 77008         128885 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3525             }
3526 0         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         0 my $qq_string = '';
3532 0         0 local $nest = 1;
3533 0         0 while (not /\G \z/oxgc) {
3534 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
    0          
3535 0         0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3536 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3537             elsif (/\G (\]) /oxgc) {
3538 0 0       0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
  0         0  
3539 0         0 else { $qq_string .= $1; }
3540             }
3541 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3542             }
3543 0         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 30         34 my $qq_string = '';
3549 30         48 local $nest = 1;
3550 30         93 while (not /\G \z/oxgc) {
3551 1166 100       3932 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  22 50       52  
    50          
    100          
    50          
3552 0         0 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3553 0         0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3554             elsif (/\G (\>) /oxgc) {
3555 30 50       60 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
  30         64  
3556 0         0 else { $qq_string .= $1; }
3557             }
3558 1114         1909 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3559             }
3560 0         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         0 my $delimiter = $1;
3566 0         0 my $qq_string = '';
3567 0         0 while (not /\G \z/oxgc) {
3568 0 0       0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
3569 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3570 0         0 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3571 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3572             }
3573 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3574             }
3575             }
3576 0         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         0 my $ope = $1;
3583 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3584 0         0 return e_qr($ope,$1,$3,$2,$4);
3585             }
3586             else {
3587 0         0 my $e = '';
3588 0         0 while (not /\G \z/oxgc) {
3589 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3590 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3591 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3592 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3593 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3594 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3595 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3596 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3597             }
3598 0         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 14         28 my $ope = $1;
3605 14 50       52 if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3606 0         0 return e_qw($ope,$1,$3,$2);
3607             }
3608             else {
3609 14         19 my $e = '';
3610 14         46 while (not /\G \z/oxgc) {
3611 14 50       86 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3612              
3613 14         41 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3614 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3615              
3616 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3617 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3618              
3619 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3620 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3621              
3622 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3623 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3624              
3625 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3626 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3627             }
3628 0         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         0 my $ope = $1;
3635 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3636 0         0 return e_qq($ope,$1,$3,$2);
3637             }
3638             else {
3639 0         0 my $e = '';
3640 0         0 while (not /\G \z/oxgc) {
3641 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3642 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3643 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3644 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3645 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3646 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3647 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3648             }
3649 0         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 257         616 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 257 50       746 if (/\G (\#) /oxgc) { # q# #
3663 0         0 my $q_string = '';
3664 0         0 while (not /\G \z/oxgc) {
3665 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
3666 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3667 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3668 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3669             }
3670 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3671             }
3672              
3673             else {
3674 257         428 my $e = '';
3675 257         877 while (not /\G \z/oxgc) {
3676 257 50       1600 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    100          
    50          
    100          
    50          
3677              
3678             # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3679             elsif (/\G (\() /oxgc) { # q ( )
3680 0         0 my $q_string = '';
3681 0         0 local $nest = 1;
3682 0         0 while (not /\G \z/oxgc) {
3683 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3684 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
3685 0         0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3686 0         0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3687             elsif (/\G (\)) /oxgc) {
3688 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
  0         0  
3689 0         0 else { $q_string .= $1; }
3690             }
3691 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3692             }
3693 0         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 251         371 my $q_string = '';
3699 251         458 local $nest = 1;
3700 251         751 while (not /\G \z/oxgc) {
3701 6607 50       25730 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    100          
    100          
    50          
3702 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
3703 0         0 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3704 149         167 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  149         250  
3705             elsif (/\G (\}) /oxgc) {
3706 400 100       749 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
  251         796  
3707 149         305 else { $q_string .= $1; }
3708             }
3709 6058         10698 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3710             }
3711 0         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         0 my $q_string = '';
3717 0         0 local $nest = 1;
3718 0         0 while (not /\G \z/oxgc) {
3719 0 0       0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
3720 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
3721 0         0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3722 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3723             elsif (/\G (\]) /oxgc) {
3724 0 0       0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
  0         0  
3725 0         0 else { $q_string .= $1; }
3726             }
3727 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3728             }
3729 0         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 5         5 my $q_string = '';
3735 5         8 local $nest = 1;
3736 5         52 while (not /\G \z/oxgc) {
3737 88 50       408 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    50          
    50          
    100          
    50          
3738 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
3739 0         0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3740 0         0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3741             elsif (/\G (\>) /oxgc) {
3742 5 50       11 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
  5         11  
3743 0         0 else { $q_string .= $1; }
3744             }
3745 83         139 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3746             }
3747 0         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 1         2 my $delimiter = $1;
3753 1         1 my $q_string = '';
3754 1         6 while (not /\G \z/oxgc) {
3755 14 50       63 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0 50       0  
    100          
    50          
3756 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3757 1         3 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3758 13         21 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3759             }
3760 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3761             }
3762             }
3763 0         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 209         377 my $ope = $1;
3770 209 50       1836 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3771 0         0 return e_qr($ope,$1,$3,$2,$4);
3772             }
3773             else {
3774 209         243 my $e = '';
3775 209         521 while (not /\G \z/oxgc) {
3776 209 50       11799 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3777 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3778 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3779 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3780 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3781 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3782 10         31 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3783 0         0 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3784 199         535 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3785             }
3786 0         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 97         187 my $ope = $1;
3799              
3800             # $1 $2 $3 $4 $5 $6
3801 97 100       1970 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3802 1         3 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3803             }
3804             else {
3805 96         127 my $e = '';
3806 96         287 while (not /\G \z/oxgc) {
3807 96 50       11585 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 50       0  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3808             elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3809 0         0 my @s = ($1,$2,$3);
3810 0         0 while (not /\G \z/oxgc) {
3811 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3812             # $1 $2 $3 $4
3813 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3814 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3815 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3816 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3817 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3818 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3819 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3820 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3821 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3822             }
3823 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3824             }
3825             elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3826 0         0 my @s = ($1,$2,$3);
3827 0         0 while (not /\G \z/oxgc) {
3828 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3829             # $1 $2 $3 $4
3830 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3831 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3832 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3833 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3834 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3835 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3836 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3837 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3838 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3839             }
3840 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3841             }
3842             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3843 0         0 my @s = ($1,$2,$3);
3844 0         0 while (not /\G \z/oxgc) {
3845 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3846             # $1 $2 $3 $4
3847 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3848 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3849 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3850 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3851 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3852 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3853 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3854             }
3855 0         0 die __FILE__, ": Substitution replacement not terminated\n";
3856             }
3857             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3858 0         0 my @s = ($1,$2,$3);
3859 0         0 while (not /\G \z/oxgc) {
3860 0 0       0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3861             # $1 $2 $3 $4
3862 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3863 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3864 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3865 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3866 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3867 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3868 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3869 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3870 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3871             }
3872 0         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 21         53 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         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         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 75         279 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3889             }
3890             }
3891 0         0 die __FILE__, ": Substitution pattern not terminated\n";
3892             }
3893             }
3894              
3895             # require ignore module
3896 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3897 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3898 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3899              
3900             # use strict; --> use strict; no strict qw(refs);
3901 36         268 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3902 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3903 0         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 2 50 33     51 if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
      33        
3908 0         0 return "use $1; no strict qw(refs);";
3909             }
3910             else {
3911 2         10 return "use $1;";
3912             }
3913             }
3914             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3915 0 0 0     0 if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
      0        
3916 0         0 return "use $1; no strict qw(refs);";
3917             }
3918             else {
3919 0         0 return "use $1;";
3920             }
3921             }
3922              
3923             # ignore use module
3924 2         16 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3925 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3926 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3927              
3928             # ignore no module
3929 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3930 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3931 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3932              
3933             # use else
3934 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
3935              
3936             # use else
3937 2         7 elsif (/\G \b no \b /oxmsgc) { return "no"; }
3938              
3939             # ''
3940             elsif (/\G (?
3941 829         1118 my $q_string = '';
3942 829         1995 while (not /\G \z/oxgc) {
3943 9419 100       29717 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  4 100       10  
    100          
    50          
3944 12         26 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
3945 829         1730 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
3946 8574         16069 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3947             }
3948 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3949             }
3950              
3951             # ""
3952             elsif (/\G (\") /oxgc) {
3953 1511         1927 my $qq_string = '';
3954 1511         3349 while (not /\G \z/oxgc) {
3955 35029 100       97499 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  67 100       153  
    100          
    50          
3956 12         25 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
3957 1511         3041 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
3958 33439         57488 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3959             }
3960 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3961             }
3962              
3963             # ``
3964             elsif (/\G (\`) /oxgc) {
3965 1         2 my $qx_string = '';
3966 1         3 while (not /\G \z/oxgc) {
3967 19 50       79 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
  0 50       0  
    100          
    50          
3968 0         0 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
3969 1         3 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
3970 18         29 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
3971             }
3972 0         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 424         593 my $regexp = '';
3978 424         1085 while (not /\G \z/oxgc) {
3979 4216 50       14114 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 50       0  
    100          
    50          
3980 0         0 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
3981 424         954 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
3982 3792         6584 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3983             }
3984 0         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         0 my $regexp = '';
3990 0         0 while (not /\G \z/oxgc) {
3991 0 0       0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
3992 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
3993 0         0 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
3994 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3995             }
3996 0         0 die __FILE__, ": Search pattern not terminated\n";
3997             }
3998              
3999             # <<>> (a safer ARGV)
4000 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4001              
4002             # << (bit shift) --- not here document
4003 0         0 elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
4004              
4005             # <<'HEREDOC'
4006             elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4007 72         90 $slash = 'm//';
4008 72         130 my $here_quote = $1;
4009 72         86 my $delimiter = $2;
4010              
4011             # get here document
4012 72 50       135 if ($here_script eq '') {
4013 72         377 $here_script = CORE::substr $_, pos $_;
4014 72         350 $here_script =~ s/.*?\n//oxm;
4015             }
4016 72 50       511 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4017 72         184 push @heredoc, $1 . qq{\n$delimiter\n};
4018 72         97 push @heredoc_delimiter, $delimiter;
4019             }
4020             else {
4021 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4022             }
4023 72         246 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         0 $slash = 'm//';
4038 0         0 my $here_quote = $1;
4039 0         0 my $delimiter = $2;
4040              
4041             # get here document
4042 0 0       0 if ($here_script eq '') {
4043 0         0 $here_script = CORE::substr $_, pos $_;
4044 0         0 $here_script =~ s/.*?\n//oxm;
4045             }
4046 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4047 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4048 0         0 push @heredoc_delimiter, $delimiter;
4049             }
4050             else {
4051 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4052             }
4053 0         0 return $here_quote;
4054             }
4055              
4056             # <<"HEREDOC"
4057             elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4058 36         61 $slash = 'm//';
4059 36         84 my $here_quote = $1;
4060 36         66 my $delimiter = $2;
4061              
4062             # get here document
4063 36 50       102 if ($here_script eq '') {
4064 36         360 $here_script = CORE::substr $_, pos $_;
4065 36         567 $here_script =~ s/.*?\n//oxm;
4066             }
4067 36 50       503 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4068 36         95 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4069 36         80 push @heredoc_delimiter, $delimiter;
4070             }
4071             else {
4072 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4073             }
4074 36         444 return $here_quote;
4075             }
4076              
4077             # <
4078             elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4079 42         88 $slash = 'm//';
4080 42         80 my $here_quote = $1;
4081 42         66 my $delimiter = $2;
4082              
4083             # get here document
4084 42 50       113 if ($here_script eq '') {
4085 42         337 $here_script = CORE::substr $_, pos $_;
4086 42         312 $here_script =~ s/.*?\n//oxm;
4087             }
4088 42 50       628 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4089 42         112 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4090 42         76 push @heredoc_delimiter, $delimiter;
4091             }
4092             else {
4093 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4094             }
4095 42         162 return $here_quote;
4096             }
4097              
4098             # <<`HEREDOC`
4099             elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4100 0         0 $slash = 'm//';
4101 0         0 my $here_quote = $1;
4102 0         0 my $delimiter = $2;
4103              
4104             # get here document
4105 0 0       0 if ($here_script eq '') {
4106 0         0 $here_script = CORE::substr $_, pos $_;
4107 0         0 $here_script =~ s/.*?\n//oxm;
4108             }
4109 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4110 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4111 0         0 push @heredoc_delimiter, $delimiter;
4112             }
4113             else {
4114 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4115             }
4116 0         0 return $here_quote;
4117             }
4118              
4119             # <<= <=> <= < operator
4120             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4121 11         46 return $1;
4122             }
4123              
4124             #
4125             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4126 0         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         0 return 'Ehebrew::glob("' . $1 . '")';
4135             }
4136              
4137             # __DATA__
4138 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4139              
4140             # __END__
4141 200         1223 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         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4154              
4155             # \cZ Control-Z
4156 0         0 elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4157              
4158             # any operator before div
4159             elsif (/\G (
4160             -- | \+\+ |
4161             [\)\}\]]
4162              
4163 4760         5519 ) /oxgc) { $slash = 'div'; return $1; }
  4760         18132  
4164              
4165             # yada-yada or triple-dot operator
4166             elsif (/\G (
4167             \.\.\.
4168              
4169 7         11 ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
  7         24  
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 8291         8837 )) /oxgc) { $slash = 'm//'; return $1; }
  8291         30580  
4226              
4227             # other any character
4228 14787         15124 elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
  14787         56219  
4229              
4230             # system error
4231             else {
4232 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4233             }
4234             }
4235              
4236             # escape Hebrew string
4237             sub e_string {
4238 1699     1699 0 2822 my($string) = @_;
4239 1699         1672 my $e_string = '';
4240              
4241 1699         1898 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 1699         15077 my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4248              
4249             # without { ... }
4250 1699 100 66     6985 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4251 1683 50       3175 if ($string !~ /<
4252 1683         3481 return $string;
4253             }
4254             }
4255              
4256             E_STRING_LOOP:
4257 16         41 while ($string !~ /\G \z/oxgc) {
4258 185 50       11142 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4259             }
4260              
4261             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Ehebrew::PREMATCH()]}
4262 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4263 0         0 $e_string .= q{Ehebrew::PREMATCH()};
4264 0         0 $slash = 'div';
4265             }
4266              
4267             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Ehebrew::MATCH()]}
4268             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4269 0         0 $e_string .= q{Ehebrew::MATCH()};
4270 0         0 $slash = 'div';
4271             }
4272              
4273             # $', ${'} --> $', ${'}
4274             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4275 0         0 $e_string .= $1;
4276 0         0 $slash = 'div';
4277             }
4278              
4279             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Ehebrew::POSTMATCH()]}
4280             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4281 0         0 $e_string .= q{Ehebrew::POSTMATCH()};
4282 0         0 $slash = 'div';
4283             }
4284              
4285             # bareword
4286             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4287 0         0 $e_string .= $1;
4288 0         0 $slash = 'div';
4289             }
4290              
4291             # $0 --> $0
4292             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4293 0         0 $e_string .= $1;
4294 0         0 $slash = 'div';
4295             }
4296             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4297 0         0 $e_string .= $1;
4298 0         0 $slash = 'div';
4299             }
4300              
4301             # $$ --> $$
4302             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4303 0         0 $e_string .= $1;
4304 0         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         0 $e_string .= e_capture($1);
4311 0         0 $slash = 'div';
4312             }
4313             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4314 0         0 $e_string .= e_capture($1);
4315 0         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         0 $e_string .= e_capture($1.'->'.$2);
4321 0         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         0 $e_string .= e_capture($1.'->'.$2);
4327 0         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         0 $e_string .= e_capture($1);
4333 0         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         0 $e_string .= '${' . $1 . '}';
4339 0         0 $slash = 'div';
4340             }
4341              
4342             # ${ ... }
4343             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4344 3         8 $e_string .= e_capture($1);
4345 3         14 $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 6         10 $e_string .= $1;
4352 6         15 $slash = 'div';
4353             }
4354             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4355             # $ @ # \ ' " / ? ( ) [ ] < >
4356             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4357 0         0 $e_string .= $1;
4358 0         0 $slash = 'div';
4359             }
4360              
4361             # subroutines of package Ehebrew
4362 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4363 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4364 0         0 elsif ($string =~ /\G \b Hebrew::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4365 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4366 0         0 elsif ($string =~ /\G \b Hebrew::eval \b /oxgc) { $e_string .= 'eval Hebrew::escape'; $slash = 'm//'; }
  0         0  
4367 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4368 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Ehebrew::chop'; $slash = 'm//'; }
  0         0  
4369 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4370 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4371 0         0 elsif ($string =~ /\G \b Hebrew::index \b /oxgc) { $e_string .= 'Hebrew::index'; $slash = 'm//'; }
  0         0  
4372 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Ehebrew::index'; $slash = 'm//'; }
  0         0  
4373 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4374 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4375 0         0 elsif ($string =~ /\G \b Hebrew::rindex \b /oxgc) { $e_string .= 'Hebrew::rindex'; $slash = 'm//'; }
  0         0  
4376 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Ehebrew::rindex'; $slash = 'm//'; }
  0         0  
4377 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::lc'; $slash = 'm//'; }
  0         0  
4378 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::lcfirst'; $slash = 'm//'; }
  0         0  
4379 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::uc'; $slash = 'm//'; }
  0         0  
4380 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::ucfirst'; $slash = 'm//'; }
  0         0  
4381 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::fc'; $slash = 'm//'; }
  0         0  
4382              
4383             # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
4384 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4385 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4386 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4387 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4388 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4389 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4390 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
4391              
4392 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4393 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4394 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4395 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4396 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4397 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4398 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
4399              
4400             elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
4401 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4402 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4403 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
4404 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4405              
4406 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4407 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4408 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::chr'; $slash = 'm//'; }
  0         0  
4409 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4410 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4411 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Ehebrew::glob'; $slash = 'm//'; }
  0         0  
4412 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Ehebrew::lc_'; $slash = 'm//'; }
  0         0  
4413 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Ehebrew::lcfirst_'; $slash = 'm//'; }
  0         0  
4414 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Ehebrew::uc_'; $slash = 'm//'; }
  0         0  
4415 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Ehebrew::ucfirst_'; $slash = 'm//'; }
  0         0  
4416 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Ehebrew::fc_'; $slash = 'm//'; }
  0         0  
4417 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4418              
4419 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4420 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4421 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Ehebrew::chr_'; $slash = 'm//'; }
  0         0  
4422 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4423 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4424 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Ehebrew::glob_'; $slash = 'm//'; }
  0         0  
4425 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
4426 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
4427             # split
4428             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4429 0         0 $slash = 'm//';
4430              
4431 0         0 my $e = '';
4432 0         0 while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4433 0         0 $e .= $1;
4434             }
4435              
4436             # end of split
4437 0 0       0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Ehebrew::split' . $e; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4438              
4439             # split scalar value
4440 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Ehebrew::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
4441              
4442             # split literal space
4443 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4444 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4445 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4446 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4447 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4448 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4449 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4450 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4451 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4452 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4453 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4454 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4455 0         0 elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {' '}; next E_STRING_LOOP; }
  0         0  
4456 0         0 elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Ehebrew::split' . $e . qq {" "}; next E_STRING_LOOP; }
  0         0  
4457              
4458             # split qq//
4459             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4460 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0         0  
  0         0  
4461             else {
4462 0         0 while ($string !~ /\G \z/oxgc) {
4463 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4464 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
4465 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
4466 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
4467 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
4468 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
  0         0  
4469 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
  0         0  
4470             }
4471 0         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       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0         0  
  0         0  
4478             else {
4479 0         0 while ($string !~ /\G \z/oxgc) {
4480 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4481 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ( )
  0         0  
4482 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr { }
  0         0  
4483 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr [ ]
  0         0  
4484 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr < >
  0         0  
4485 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
  0         0  
4486 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
  0         0  
4487 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
  0         0  
4488             }
4489 0         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       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0         0  
  0         0  
4496             else {
4497 0         0 while ($string !~ /\G \z/oxgc) {
4498 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4499 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
4500 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
4501 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
4502 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
4503 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
  0         0  
4504 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q * * --> qr * *
  0         0  
4505             }
4506 0         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       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0         0  
  0         0  
4513             else {
4514 0         0 while ($string !~ /\G \z/oxgc) {
4515 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4516 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ( ) --> qr ( )
  0         0  
4517 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m { } --> qr { }
  0         0  
4518 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m [ ] --> qr [ ]
  0         0  
4519 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m < > --> qr < >
  0         0  
4520 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
  0         0  
4521 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
  0         0  
4522 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m * * --> qr * *
  0         0  
4523             }
4524 0         0 die __FILE__, ": Search pattern not terminated\n";
4525             }
4526             }
4527              
4528             # split ''
4529             elsif ($string =~ /\G (\') /oxgc) {
4530 0         0 my $q_string = '';
4531 0         0 while ($string !~ /\G \z/oxgc) {
4532 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0 0       0  
    0          
    0          
4533 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4534 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
  0         0  
4535 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4536             }
4537 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4538             }
4539              
4540             # split ""
4541             elsif ($string =~ /\G (\") /oxgc) {
4542 0         0 my $qq_string = '';
4543 0         0 while ($string !~ /\G \z/oxgc) {
4544 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0 0       0  
    0          
    0          
4545 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4546 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
  0         0  
4547 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4548             }
4549 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4550             }
4551              
4552             # split //
4553             elsif ($string =~ /\G (\/) /oxgc) {
4554 0         0 my $regexp = '';
4555 0         0 while ($string !~ /\G \z/oxgc) {
4556 0 0       0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0 0       0  
    0          
    0          
4557 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4558 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
  0         0  
4559 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4560             }
4561 0         0 die __FILE__, ": Search pattern not terminated\n";
4562             }
4563             }
4564              
4565             # qq//
4566             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4567 0         0 my $ope = $1;
4568 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4569 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4570             }
4571             else {
4572 0         0 my $e = '';
4573 0         0 while ($string !~ /\G \z/oxgc) {
4574 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4575 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4576 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4577 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4578 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
  0         0  
4579 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
  0         0  
4580             }
4581 0         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         0 my $ope = $1;
4588 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4589 0         0 $e_string .= e_qq($ope,$1,$3,$2);
4590             }
4591             else {
4592 0         0 my $e = '';
4593 0         0 while ($string !~ /\G \z/oxgc) {
4594 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4595 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4596 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4597 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4598 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4599 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
  0         0  
4600 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
  0         0  
4601             }
4602 0         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         0 my $ope = $1;
4609 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4610 0         0 $e_string .= e_q($ope,$1,$3,$2);
4611             }
4612             else {
4613 0         0 my $e = '';
4614 0         0 while ($string !~ /\G \z/oxgc) {
4615 0 0       0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0 0       0  
    0          
    0          
    0          
    0          
4616 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4617 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4618 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4619 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
  0         0  
4620 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
  0         0  
4621             }
4622 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4623             }
4624             }
4625              
4626             # ''
4627 0         0 elsif ($string =~ /\G (?
4628              
4629             # ""
4630 0         0 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4631              
4632             # ``
4633 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4634              
4635             # <<>> (a safer ARGV)
4636 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4637              
4638             # <<= <=> <= < operator
4639 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4640              
4641             #
4642 0         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         0 $e_string .= 'Ehebrew::glob("' . $1 . '")';
4647             }
4648              
4649             # << (bit shift) --- not here document
4650 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  0         0  
4651              
4652             # <<'HEREDOC'
4653             elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4654 0         0 $slash = 'm//';
4655 0         0 my $here_quote = $1;
4656 0         0 my $delimiter = $2;
4657              
4658             # get here document
4659 0 0       0 if ($here_script eq '') {
4660 0         0 $here_script = CORE::substr $_, pos $_;
4661 0         0 $here_script =~ s/.*?\n//oxm;
4662             }
4663 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4664 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4665 0         0 push @heredoc_delimiter, $delimiter;
4666             }
4667             else {
4668 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4669             }
4670 0         0 $e_string .= $here_quote;
4671             }
4672              
4673             # <<\HEREDOC
4674             elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4675 0         0 $slash = 'm//';
4676 0         0 my $here_quote = $1;
4677 0         0 my $delimiter = $2;
4678              
4679             # get here document
4680 0 0       0 if ($here_script eq '') {
4681 0         0 $here_script = CORE::substr $_, pos $_;
4682 0         0 $here_script =~ s/.*?\n//oxm;
4683             }
4684 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4685 0         0 push @heredoc, $1 . qq{\n$delimiter\n};
4686 0         0 push @heredoc_delimiter, $delimiter;
4687             }
4688             else {
4689 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4690             }
4691 0         0 $e_string .= $here_quote;
4692             }
4693              
4694             # <<"HEREDOC"
4695             elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4696 0         0 $slash = 'm//';
4697 0         0 my $here_quote = $1;
4698 0         0 my $delimiter = $2;
4699              
4700             # get here document
4701 0 0       0 if ($here_script eq '') {
4702 0         0 $here_script = CORE::substr $_, pos $_;
4703 0         0 $here_script =~ s/.*?\n//oxm;
4704             }
4705 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4706 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4707 0         0 push @heredoc_delimiter, $delimiter;
4708             }
4709             else {
4710 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4711             }
4712 0         0 $e_string .= $here_quote;
4713             }
4714              
4715             # <
4716             elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4717 0         0 $slash = 'm//';
4718 0         0 my $here_quote = $1;
4719 0         0 my $delimiter = $2;
4720              
4721             # get here document
4722 0 0       0 if ($here_script eq '') {
4723 0         0 $here_script = CORE::substr $_, pos $_;
4724 0         0 $here_script =~ s/.*?\n//oxm;
4725             }
4726 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4727 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4728 0         0 push @heredoc_delimiter, $delimiter;
4729             }
4730             else {
4731 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4732             }
4733 0         0 $e_string .= $here_quote;
4734             }
4735              
4736             # <<`HEREDOC`
4737             elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4738 0         0 $slash = 'm//';
4739 0         0 my $here_quote = $1;
4740 0         0 my $delimiter = $2;
4741              
4742             # get here document
4743 0 0       0 if ($here_script eq '') {
4744 0         0 $here_script = CORE::substr $_, pos $_;
4745 0         0 $here_script =~ s/.*?\n//oxm;
4746             }
4747 0 0       0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4748 0         0 push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4749 0         0 push @heredoc_delimiter, $delimiter;
4750             }
4751             else {
4752 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4753             }
4754 0         0 $e_string .= $here_quote;
4755             }
4756              
4757             # any operator before div
4758             elsif ($string =~ /\G (
4759             -- | \+\+ |
4760             [\)\}\]]
4761              
4762 17         19 ) /oxgc) { $slash = 'div'; $e_string .= $1; }
  17         50  
4763              
4764             # yada-yada or triple-dot operator
4765             elsif ($string =~ /\G (
4766             \.\.\.
4767              
4768 0         0 ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
  0         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 30         35 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
  30         91  
4800              
4801             # other any character
4802 129         306 elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
4803              
4804             # system error
4805             else {
4806 0         0 die __FILE__, ": Oops, this shouldn't happen!\n";
4807             }
4808             }
4809              
4810 16         59 return $e_string;
4811             }
4812              
4813             #
4814             # character class
4815             #
4816             sub character_class {
4817 1874     1874 0 2136 my($char,$modifier) = @_;
4818              
4819 1874 100       2509 if ($char eq '.') {
4820 52 100       90 if ($modifier =~ /s/) {
4821 17         33 return '${Ehebrew::dot_s}';
4822             }
4823             else {
4824 35         63 return '${Ehebrew::dot}';
4825             }
4826             }
4827             else {
4828 1822         2721 return Ehebrew::classic_character_class($char);
4829             }
4830             }
4831              
4832             #
4833             # escape capture ($1, $2, $3, ...)
4834             #
4835             sub e_capture {
4836              
4837 212     212 0 805 return join '', '${', $_[0], '}';
4838             }
4839              
4840             #
4841             # escape transliteration (tr/// or y///)
4842             #
4843             sub e_tr {
4844 3     3 0 6 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
4845 3         4 my $e_tr = '';
4846 3   50     5 $modifier ||= '';
4847              
4848 3         4 $slash = 'div';
4849              
4850             # quote character class 1
4851 3         4 $charclass = q_tr($charclass);
4852              
4853             # quote character class 2
4854 3         5 $charclass2 = q_tr($charclass2);
4855              
4856             # /b /B modifier
4857 3 50       8 if ($modifier =~ tr/bB//d) {
4858 0 0       0 if ($variable eq '') {
4859 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
4860             }
4861             else {
4862 0         0 $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
4863             }
4864             }
4865             else {
4866 3 100       5 if ($variable eq '') {
4867 2         9 $e_tr = qq{Ehebrew::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
4868             }
4869             else {
4870 1         4 $e_tr = qq{Ehebrew::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
4871             }
4872             }
4873              
4874             # clear tr/// variable
4875 3         4 $tr_variable = '';
4876 3         3 $bind_operator = '';
4877              
4878 3         13 return $e_tr;
4879             }
4880              
4881             #
4882             # quote for escape transliteration (tr/// or y///)
4883             #
4884             sub q_tr {
4885 6     6 0 5 my($charclass) = @_;
4886              
4887             # quote character class
4888 6 50       9 if ($charclass !~ /'/oxms) {
    0          
    0          
    0          
    0          
    0          
4889 6         6 return e_q('', "'", "'", $charclass); # --> q' '
4890             }
4891             elsif ($charclass !~ /\//oxms) {
4892 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
4893             }
4894             elsif ($charclass !~ /\#/oxms) {
4895 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
4896             }
4897             elsif ($charclass !~ /[\<\>]/oxms) {
4898 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
4899             }
4900             elsif ($charclass !~ /[\(\)]/oxms) {
4901 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
4902             }
4903             elsif ($charclass !~ /[\{\}]/oxms) {
4904 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
4905             }
4906             else {
4907 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
4908 0 0       0 if ($charclass !~ /\Q$char\E/xms) {
4909 0         0 return e_q('q', $char, $char, $charclass);
4910             }
4911             }
4912             }
4913              
4914 0         0 return e_q('q', '{', '}', $charclass);
4915             }
4916              
4917             #
4918             # escape q string (q//, '')
4919             #
4920             sub e_q {
4921 1092     1092 0 1938 my($ope,$delimiter,$end_delimiter,$string) = @_;
4922              
4923 1092         1159 $slash = 'div';
4924              
4925 1092         5362 return join '', $ope, $delimiter, $string, $end_delimiter;
4926             }
4927              
4928             #
4929             # escape qq string (qq//, "", qx//, ``)
4930             #
4931             sub e_qq {
4932 3679     3679 0 5722 my($ope,$delimiter,$end_delimiter,$string) = @_;
4933              
4934 3679         3515 $slash = 'div';
4935              
4936 3679         3133 my $left_e = 0;
4937 3679         2660 my $right_e = 0;
4938              
4939             # split regexp
4940 3679         131934 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 3679         12384 for (my $i=0; $i <= $#char; $i++) {
4957              
4958             # "\L\u" --> "\u\L"
4959 112354 50 33     414247 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
4960 0         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         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 1         3 $char[$i] = Ehebrew::octchr($1);
4971             }
4972              
4973             # hexadecimal escape sequence
4974             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
4975 1         3 $char[$i] = Ehebrew::hexchr($1);
4976             }
4977              
4978             # \N{CHARNAME} --> N{CHARNAME}
4979             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
4980 0         0 $char[$i] = $1;
4981             }
4982              
4983 112354 100       1125821 if (0) {
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
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         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
4995 484 50       1071 if ($right_e < $left_e) {
4996 0         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         0 $char[$i] = '@{[Ehebrew::ucfirst qq<';
5014 0         0 $left_e++;
5015             }
5016             elsif ($char[$i] eq '\l') {
5017 0         0 $char[$i] = '@{[Ehebrew::lcfirst qq<';
5018 0         0 $left_e++;
5019             }
5020             elsif ($char[$i] eq '\U') {
5021 0         0 $char[$i] = '@{[Ehebrew::uc qq<';
5022 0         0 $left_e++;
5023             }
5024             elsif ($char[$i] eq '\L') {
5025 0         0 $char[$i] = '@{[Ehebrew::lc qq<';
5026 0         0 $left_e++;
5027             }
5028             elsif ($char[$i] eq '\F') {
5029 8         7 $char[$i] = '@{[Ehebrew::fc qq<';
5030 8         14 $left_e++;
5031             }
5032             elsif ($char[$i] eq '\Q') {
5033 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5034 0         0 $left_e++;
5035             }
5036             elsif ($char[$i] eq '\E') {
5037 8 50       17 if ($right_e < $left_e) {
5038 8         9 $char[$i] = '>]}';
5039 8         11 $right_e++;
5040             }
5041             else {
5042 0         0 $char[$i] = '';
5043             }
5044             }
5045             elsif ($char[$i] eq '\Q') {
5046 0         0 while (1) {
5047 0 0       0 if (++$i > $#char) {
5048 0         0 last;
5049             }
5050 0 0       0 if ($char[$i] eq '\E') {
5051 0         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 205         360 $char[$i] = e_capture($1);
5072             }
5073             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5074 0         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         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         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         0 $char[$i] = e_capture($1);
5090             }
5091              
5092             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ehebrew::PREMATCH()
5093             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5094 44         110 $char[$i] = '@{[Ehebrew::PREMATCH()]}';
5095             }
5096              
5097             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ehebrew::MATCH()
5098             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5099 45         107 $char[$i] = '@{[Ehebrew::MATCH()]}';
5100             }
5101              
5102             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ehebrew::POSTMATCH()
5103             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5104 33         92 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
5114             }
5115             }
5116              
5117             # return string
5118 3679 50       5934 if ($left_e > $right_e) {
5119 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5120             }
5121 3679         31661 return join '', $ope, $delimiter, @char, $end_delimiter;
5122             }
5123              
5124             #
5125             # escape qw string (qw//)
5126             #
5127             sub e_qw {
5128 14     14 0 79 my($ope,$delimiter,$end_delimiter,$string) = @_;
5129              
5130 14         19 $slash = 'div';
5131              
5132             # choice again delimiter
5133 14         166 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
  381         424  
5134 14 50       72 if (not $octet{$end_delimiter}) {
    0          
    0          
    0          
    0          
5135 14         96 return join '', $ope, $delimiter, $string, $end_delimiter;
5136             }
5137             elsif (not $octet{')'}) {
5138 0         0 return join '', $ope, '(', $string, ')';
5139             }
5140             elsif (not $octet{'}'}) {
5141 0         0 return join '', $ope, '{', $string, '}';
5142             }
5143             elsif (not $octet{']'}) {
5144 0         0 return join '', $ope, '[', $string, ']';
5145             }
5146             elsif (not $octet{'>'}) {
5147 0         0 return join '', $ope, '<', $string, '>';
5148             }
5149             else {
5150 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5151 0 0       0 if (not $octet{$char}) {
5152 0         0 return join '', $ope, $char, $string, $char;
5153             }
5154             }
5155             }
5156              
5157             # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5158 0         0 my @string = CORE::split(/\s+/, $string);
5159 0         0 for my $string (@string) {
5160 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5161 0         0 for my $octet (@octet) {
5162 0 0       0 if ($octet =~ /\A (['\\]) \z/oxms) {
5163 0         0 $octet = '\\' . $1;
5164             }
5165             }
5166 0         0 $string = join '', @octet;
5167             }
5168 0         0 return join '', '(', (join ', ', map { "'$_'" } @string), ')';
  0         0  
5169             }
5170              
5171             #
5172             # escape here document (<<"HEREDOC", <
5173             #
5174             sub e_heredoc {
5175 78     78 0 176 my($string) = @_;
5176              
5177 78         103 $slash = 'm//';
5178              
5179 78         283 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5180              
5181 78         90 my $left_e = 0;
5182 78         83 my $right_e = 0;
5183              
5184             # split regexp
5185 78         8044 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 78         447 for (my $i=0; $i <= $#char; $i++) {
5202              
5203             # "\L\u" --> "\u\L"
5204 5154 50 33     18687 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
5205 0         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         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 1         2 $char[$i] = Ehebrew::octchr($1);
5216             }
5217              
5218             # hexadecimal escape sequence
5219             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5220 1         2 $char[$i] = Ehebrew::hexchr($1);
5221             }
5222              
5223             # \N{CHARNAME} --> N{CHARNAME}
5224             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5225 0         0 $char[$i] = $1;
5226             }
5227              
5228 5154 50       51280 if (0) {
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5229             }
5230              
5231             # \u \l \U \L \F \Q \E
5232 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5233 0 0       0 if ($right_e < $left_e) {
5234 0         0 $char[$i] = '\\' . $char[$i];
5235             }
5236             }
5237             elsif ($char[$i] eq '\u') {
5238 0         0 $char[$i] = '@{[Ehebrew::ucfirst qq<';
5239 0         0 $left_e++;
5240             }
5241             elsif ($char[$i] eq '\l') {
5242 0         0 $char[$i] = '@{[Ehebrew::lcfirst qq<';
5243 0         0 $left_e++;
5244             }
5245             elsif ($char[$i] eq '\U') {
5246 0         0 $char[$i] = '@{[Ehebrew::uc qq<';
5247 0         0 $left_e++;
5248             }
5249             elsif ($char[$i] eq '\L') {
5250 0         0 $char[$i] = '@{[Ehebrew::lc qq<';
5251 0         0 $left_e++;
5252             }
5253             elsif ($char[$i] eq '\F') {
5254 0         0 $char[$i] = '@{[Ehebrew::fc qq<';
5255 0         0 $left_e++;
5256             }
5257             elsif ($char[$i] eq '\Q') {
5258 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
5259 0         0 $left_e++;
5260             }
5261             elsif ($char[$i] eq '\E') {
5262 0 0       0 if ($right_e < $left_e) {
5263 0         0 $char[$i] = '>]}';
5264 0         0 $right_e++;
5265             }
5266             else {
5267 0         0 $char[$i] = '';
5268             }
5269             }
5270             elsif ($char[$i] eq '\Q') {
5271 0         0 while (1) {
5272 0 0       0 if (++$i > $#char) {
5273 0         0 last;
5274             }
5275 0 0       0 if ($char[$i] eq '\E') {
5276 0         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         0 $char[$i] = e_capture($1);
5297             }
5298             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5299 0         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         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         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         0 $char[$i] = e_capture($1);
5315             }
5316              
5317             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ehebrew::PREMATCH()
5318             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5319 8         35 $char[$i] = '@{[Ehebrew::PREMATCH()]}';
5320             }
5321              
5322             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ehebrew::MATCH()
5323             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5324 8         43 $char[$i] = '@{[Ehebrew::MATCH()]}';
5325             }
5326              
5327             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ehebrew::POSTMATCH()
5328             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5329 6         27 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
5339             }
5340             }
5341              
5342             # return string
5343 78 50       180 if ($left_e > $right_e) {
5344 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5345             }
5346 78         838 return join '', @char;
5347             }
5348              
5349             #
5350             # escape regexp (m//, qr//)
5351             #
5352             sub e_qr {
5353 623     623 0 1425 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5354 623   100     1967 $modifier ||= '';
5355              
5356 623         850 $modifier =~ tr/p//d;
5357 623 50       1295 if ($modifier =~ /([adlu])/oxms) {
5358 0         0 my $line = 0;
5359 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5360 0 0       0 if ($filename ne __FILE__) {
5361 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5362 0         0 last;
5363             }
5364             }
5365 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5366             }
5367              
5368 623         731 $slash = 'div';
5369              
5370             # literal null string pattern
5371 623 100       1824 if ($string eq '') {
    100          
5372 8         7 $modifier =~ tr/bB//d;
5373 8         7 $modifier =~ tr/i//d;
5374 8         36 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 2 50       16 if ($delimiter =~ / [\@:] /oxms) {
5382 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5383 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5384 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5385 0         0 $delimiter = '(';
5386 0         0 $end_delimiter = ')';
5387             }
5388             elsif (not $octet{'}'}) {
5389 0         0 $delimiter = '{';
5390 0         0 $end_delimiter = '}';
5391             }
5392             elsif (not $octet{']'}) {
5393 0         0 $delimiter = '[';
5394 0         0 $end_delimiter = ']';
5395             }
5396             elsif (not $octet{'>'}) {
5397 0         0 $delimiter = '<';
5398 0         0 $end_delimiter = '>';
5399             }
5400             else {
5401 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5402 0 0       0 if (not $octet{$char}) {
5403 0         0 $delimiter = $char;
5404 0         0 $end_delimiter = $char;
5405 0         0 last;
5406             }
5407             }
5408             }
5409             }
5410              
5411 2 50 33     13 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5412 0         0 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5413             }
5414             else {
5415 2         10 return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5416             }
5417             }
5418              
5419 613 100       1209 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5420 613         1959 my $metachar = qr/[\@\\|[\]{^]/oxms;
5421              
5422             # split regexp
5423 613         60039 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 613 50       2695 if ($delimiter =~ / [\@:] /oxms) {
5449 0         0 my %octet = map {$_ => 1} @char;
  0         0  
5450 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
5451 0         0 $delimiter = '(';
5452 0         0 $end_delimiter = ')';
5453             }
5454             elsif (not $octet{'}'}) {
5455 0         0 $delimiter = '{';
5456 0         0 $end_delimiter = '}';
5457             }
5458             elsif (not $octet{']'}) {
5459 0         0 $delimiter = '[';
5460 0         0 $end_delimiter = ']';
5461             }
5462             elsif (not $octet{'>'}) {
5463 0         0 $delimiter = '<';
5464 0         0 $end_delimiter = '>';
5465             }
5466             else {
5467 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5468 0 0       0 if (not $octet{$char}) {
5469 0         0 $delimiter = $char;
5470 0         0 $end_delimiter = $char;
5471 0         0 last;
5472             }
5473             }
5474             }
5475             }
5476              
5477 613         656 my $left_e = 0;
5478 613         587 my $right_e = 0;
5479 613         1468 for (my $i=0; $i <= $#char; $i++) {
5480              
5481             # "\L\u" --> "\u\L"
5482 1815 50 66     10171 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 66        
    100          
    100          
    100          
    100          
5483 0         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         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 1         2 $char[$i] = Ehebrew::octchr($1);
5494             }
5495              
5496             # hexadecimal escape sequence
5497             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5498 1         2 $char[$i] = Ehebrew::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 6         25 $char[$i] = $1 . '\\' . $2;
5508             }
5509              
5510             # \p, \P, \X --> p, P, X
5511             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5512 4         11 $char[$i] = $1;
5513             }
5514              
5515 1815 100 100     5241 if (0) {
    100 100        
    100 100        
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
5516             }
5517              
5518             # join separated multiple-octet
5519 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5520 6 50 33     86 if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    50 33        
    50 33        
      33        
      66        
      33        
5521 0         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         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         0 $char[$i] .= join '', splice @char, $i+1, 1;
5528             }
5529             }
5530              
5531             # open character class [...]
5532             elsif ($char[$i] eq '[') {
5533 316         350 my $left = $i;
5534              
5535             # [] make die "Unmatched [] in regexp ...\n"
5536             # (and so on)
5537              
5538 316 100       733 if ($char[$i+1] eq ']') {
5539 3         4 $i++;
5540             }
5541              
5542 316         280 while (1) {
5543 1343 50       1636 if (++$i > $#char) {
5544 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5545             }
5546 1343 100       1901 if ($char[$i] eq ']') {
5547 316         269 my $right = $i;
5548              
5549             # [...]
5550 316 100       1583 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5551 30         47 splice @char, $left, $right-$left+1, sprintf(q{@{[Ehebrew::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         95  
5552             }
5553             else {
5554 286         979 splice @char, $left, $right-$left+1, Ehebrew::charlist_qr(@char[$left+1..$right-1], $modifier);
5555             }
5556              
5557 316         389 $i = $left;
5558 316         819 last;
5559             }
5560             }
5561             }
5562              
5563             # open character class [^...]
5564             elsif ($char[$i] eq '[^') {
5565 74         66 my $left = $i;
5566              
5567             # [^] make die "Unmatched [] in regexp ...\n"
5568             # (and so on)
5569              
5570 74 100       157 if ($char[$i+1] eq ']') {
5571 4         6 $i++;
5572             }
5573              
5574 74         56 while (1) {
5575 272 50       321 if (++$i > $#char) {
5576 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5577             }
5578 272 100       415 if ($char[$i] eq ']') {
5579 74         55 my $right = $i;
5580              
5581             # [^...]
5582 74 100       321 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5583 30         51 splice @char, $left, $right-$left+1, sprintf(q{@{[Ehebrew::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  90         99  
5584             }
5585             else {
5586 44         132 splice @char, $left, $right-$left+1, Ehebrew::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5587             }
5588              
5589 74         98 $i = $left;
5590 74         180 last;
5591             }
5592             }
5593             }
5594              
5595             # rewrite character class or escape character
5596             elsif (my $char = character_class($char[$i],$modifier)) {
5597 139         467 $char[$i] = $char;
5598             }
5599              
5600             # /i modifier
5601             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ehebrew::uc($char[$i]) ne Ehebrew::fc($char[$i]))) {
5602 20 50       28 if (CORE::length(Ehebrew::fc($char[$i])) == 1) {
5603 20         31 $char[$i] = '[' . Ehebrew::uc($char[$i]) . Ehebrew::fc($char[$i]) . ']';
5604             }
5605             else {
5606 0         0 $char[$i] = '(?:' . Ehebrew::uc($char[$i]) . '|' . Ehebrew::fc($char[$i]) . ')';
5607             }
5608             }
5609              
5610             # \u \l \U \L \F \Q \E
5611             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5612 1 50       5 if ($right_e < $left_e) {
5613 0         0 $char[$i] = '\\' . $char[$i];
5614             }
5615             }
5616             elsif ($char[$i] eq '\u') {
5617 0         0 $char[$i] = '@{[Ehebrew::ucfirst qq<';
5618 0         0 $left_e++;
5619             }
5620             elsif ($char[$i] eq '\l') {
5621 0         0 $char[$i] = '@{[Ehebrew::lcfirst qq<';
5622 0         0 $left_e++;
5623             }
5624             elsif ($char[$i] eq '\U') {
5625 1         1 $char[$i] = '@{[Ehebrew::uc qq<';
5626 1         4 $left_e++;
5627             }
5628             elsif ($char[$i] eq '\L') {
5629 1         2 $char[$i] = '@{[Ehebrew::lc qq<';
5630 1         4 $left_e++;
5631             }
5632             elsif ($char[$i] eq '\F') {
5633 6         9 $char[$i] = '@{[Ehebrew::fc qq<';
5634 6         24 $left_e++;
5635             }
5636             elsif ($char[$i] eq '\Q') {
5637 1         1 $char[$i] = '@{[CORE::quotemeta qq<';
5638 1         5 $left_e++;
5639             }
5640             elsif ($char[$i] eq '\E') {
5641 9 50       13 if ($right_e < $left_e) {
5642 9         9 $char[$i] = '>]}';
5643 9         29 $right_e++;
5644             }
5645             else {
5646 0         0 $char[$i] = '';
5647             }
5648             }
5649             elsif ($char[$i] eq '\Q') {
5650 0         0 while (1) {
5651 0 0       0 if (++$i > $#char) {
5652 0         0 last;
5653             }
5654 0 0       0 if ($char[$i] eq '\E') {
5655 0         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       0 if ($ignorecase) {
5665 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
5666             }
5667             }
5668             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5669 0 0       0 if ($ignorecase) {
5670 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
5682 0 0       0 if ($ignorecase) {
5683 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
5684             }
5685             }
5686             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5687 0         0 $char[$i] = e_capture($1);
5688 0 0       0 if ($ignorecase) {
5689 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1.'->'.$2);
5696 0 0       0 if ($ignorecase) {
5697 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1.'->'.$2);
5704 0 0       0 if ($ignorecase) {
5705 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
5712 0 0       0 if ($ignorecase) {
5713 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
5714             }
5715             }
5716              
5717             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ehebrew::PREMATCH()
5718             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5719 8 50       28 if ($ignorecase) {
5720 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::PREMATCH())]}';
5721             }
5722             else {
5723 8         40 $char[$i] = '@{[Ehebrew::PREMATCH()]}';
5724             }
5725             }
5726              
5727             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ehebrew::MATCH()
5728             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5729 8 50       18 if ($ignorecase) {
5730 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::MATCH())]}';
5731             }
5732             else {
5733 8         38 $char[$i] = '@{[Ehebrew::MATCH()]}';
5734             }
5735             }
5736              
5737             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ehebrew::POSTMATCH()
5738             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5739 6 50       16 if ($ignorecase) {
5740 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::POSTMATCH())]}';
5741             }
5742             else {
5743 6         33 $char[$i] = '@{[Ehebrew::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       0 if ($ignorecase) {
5750 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
5751             }
5752             }
5753              
5754             # ${ ... }
5755             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5756 0         0 $char[$i] = e_capture($1);
5757 0 0       0 if ($ignorecase) {
5758 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
5759             }
5760             }
5761              
5762             # $scalar or @array
5763             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
5764 5         12 $char[$i] = e_string($char[$i]);
5765 5 100       24 if ($ignorecase) {
5766 3         23 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
5767             }
5768             }
5769              
5770             # quote character before ? + * {
5771             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5772 138 100 33     1106 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
    50          
5773             }
5774             elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5775 0         0 my $char = $char[$i-1];
5776 0 0       0 if ($char[$i] eq '{') {
5777 0         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         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 127         824 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5785             }
5786             }
5787             }
5788              
5789             # make regexp string
5790 613         777 $modifier =~ tr/i//d;
5791 613 50       1152 if ($left_e > $right_e) {
5792 0 0 0     0 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5793 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
5794             }
5795             else {
5796 0         0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
5797             }
5798             }
5799 613 50 33     3299 if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5800 0         0 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
5801             }
5802             else {
5803 613         4629 return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
5804             }
5805             }
5806              
5807             #
5808             # double quote stuff
5809             #
5810             sub qq_stuff {
5811 180     180 0 161 my($delimiter,$end_delimiter,$stuff) = @_;
5812              
5813             # scalar variable or array variable
5814 180 100       283 if ($stuff =~ /\A [\$\@] /oxms) {
5815 100         293 return $stuff;
5816             }
5817              
5818             # quote by delimiter
5819 80         134 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
  80         193  
5820 80         162 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5821 80 50       109 next if $char eq $delimiter;
5822 80 50       92 next if $char eq $end_delimiter;
5823 80 50       122 if (not $octet{$char}) {
5824 80         274 return join '', 'qq', $char, $stuff, $char;
5825             }
5826             }
5827 0         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 10     10 0 27 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5835 10   50     36 $modifier ||= '';
5836              
5837 10         14 $modifier =~ tr/p//d;
5838 10 50       22 if ($modifier =~ /([adlu])/oxms) {
5839 0         0 my $line = 0;
5840 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5841 0 0       0 if ($filename ne __FILE__) {
5842 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5843 0         0 last;
5844             }
5845             }
5846 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
5847             }
5848              
5849 10         11 $slash = 'div';
5850              
5851             # literal null string pattern
5852 10 100       26 if ($string eq '') {
    50          
5853 8         7 $modifier =~ tr/bB//d;
5854 8         9 $modifier =~ tr/i//d;
5855 8         42 return join '', $ope, $delimiter, $end_delimiter, $modifier;
5856             }
5857              
5858             # with /b /B modifier
5859             elsif ($modifier =~ tr/bB//d) {
5860 0         0 return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
5861             }
5862              
5863             # without /b /B modifier
5864             else {
5865 2         7 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 2     2 0 4 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5874              
5875 2 50       8 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5876              
5877             # split regexp
5878 2         103 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 2         14 for (my $i=0; $i <= $#char; $i++) {
5891 2 50 33     21 if (0) {
    50 33        
    50 33        
    50          
    50          
    50          
5892             }
5893              
5894             # open character class [...]
5895 0         0 elsif ($char[$i] eq '[') {
5896 0         0 my $left = $i;
5897 0 0       0 if ($char[$i+1] eq ']') {
5898 0         0 $i++;
5899             }
5900 0         0 while (1) {
5901 0 0       0 if (++$i > $#char) {
5902 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5903             }
5904 0 0       0 if ($char[$i] eq ']') {
5905 0         0 my $right = $i;
5906              
5907             # [...]
5908 0         0 splice @char, $left, $right-$left+1, Ehebrew::charlist_qr(@char[$left+1..$right-1], $modifier);
5909              
5910 0         0 $i = $left;
5911 0         0 last;
5912             }
5913             }
5914             }
5915              
5916             # open character class [^...]
5917             elsif ($char[$i] eq '[^') {
5918 0         0 my $left = $i;
5919 0 0       0 if ($char[$i+1] eq ']') {
5920 0         0 $i++;
5921             }
5922 0         0 while (1) {
5923 0 0       0 if (++$i > $#char) {
5924 0         0 die __FILE__, ": Unmatched [] in regexp\n";
5925             }
5926 0 0       0 if ($char[$i] eq ']') {
5927 0         0 my $right = $i;
5928              
5929             # [^...]
5930 0         0 splice @char, $left, $right-$left+1, Ehebrew::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5931              
5932 0         0 $i = $left;
5933 0         0 last;
5934             }
5935             }
5936             }
5937              
5938             # escape $ @ / and \
5939             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5940 0         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         0 $char[$i] = $char;
5946             }
5947              
5948             # /i modifier
5949             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ehebrew::uc($char[$i]) ne Ehebrew::fc($char[$i]))) {
5950 0 0       0 if (CORE::length(Ehebrew::fc($char[$i])) == 1) {
5951 0         0 $char[$i] = '[' . Ehebrew::uc($char[$i]) . Ehebrew::fc($char[$i]) . ']';
5952             }
5953             else {
5954 0         0 $char[$i] = '(?:' . Ehebrew::uc($char[$i]) . '|' . Ehebrew::fc($char[$i]) . ')';
5955             }
5956             }
5957              
5958             # quote character before ? + * {
5959             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
5960 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
5961             }
5962             else {
5963 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
5964             }
5965             }
5966             }
5967              
5968 2         5 $delimiter = '/';
5969 2         2 $end_delimiter = '/';
5970              
5971 2         3 $modifier =~ tr/i//d;
5972 2         17 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 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5980              
5981             # split regexp
5982 0         0 my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
5983              
5984             # unescape character
5985 0         0 for (my $i=0; $i <= $#char; $i++) {
5986 0 0       0 if (0) {
    0          
5987             }
5988              
5989             # remain \\
5990 0         0 elsif ($char[$i] eq '\\\\') {
5991             }
5992              
5993             # escape $ @ / and \
5994             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
5995 0         0 $char[$i] = '\\' . $char[$i];
5996             }
5997             }
5998              
5999 0         0 $delimiter = '/';
6000 0         0 $end_delimiter = '/';
6001 0         0 return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6002             }
6003              
6004             #
6005             # escape regexp (s/here//)
6006             #
6007             sub e_s1 {
6008 76     76 0 169 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6009 76   100     255 $modifier ||= '';
6010              
6011 76         96 $modifier =~ tr/p//d;
6012 76 50       198 if ($modifier =~ /([adlu])/oxms) {
6013 0         0 my $line = 0;
6014 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6015 0 0       0 if ($filename ne __FILE__) {
6016 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6017 0         0 last;
6018             }
6019             }
6020 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6021             }
6022              
6023 76         110 $slash = 'div';
6024              
6025             # literal null string pattern
6026 76 100       280 if ($string eq '') {
    50          
6027 8         8 $modifier =~ tr/bB//d;
6028 8         5 $modifier =~ tr/i//d;
6029 8         50 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       0 if ($delimiter =~ / [\@:] /oxms) {
6037 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
6038 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6039 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6040 0         0 $delimiter = '(';
6041 0         0 $end_delimiter = ')';
6042             }
6043             elsif (not $octet{'}'}) {
6044 0         0 $delimiter = '{';
6045 0         0 $end_delimiter = '}';
6046             }
6047             elsif (not $octet{']'}) {
6048 0         0 $delimiter = '[';
6049 0         0 $end_delimiter = ']';
6050             }
6051             elsif (not $octet{'>'}) {
6052 0         0 $delimiter = '<';
6053 0         0 $end_delimiter = '>';
6054             }
6055             else {
6056 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6057 0 0       0 if (not $octet{$char}) {
6058 0         0 $delimiter = $char;
6059 0         0 $end_delimiter = $char;
6060 0         0 last;
6061             }
6062             }
6063             }
6064             }
6065              
6066 0         0 my $prematch = '';
6067 0         0 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6068             }
6069              
6070 68 100       187 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6071 68         270 my $metachar = qr/[\@\\|[\]{^]/oxms;
6072              
6073             # split regexp
6074 68         16108 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 68 50       528 if ($delimiter =~ / [\@:] /oxms) {
6104 0         0 my %octet = map {$_ => 1} @char;
  0         0  
6105 0 0       0 if (not $octet{')'}) {
    0          
    0          
    0          
6106 0         0 $delimiter = '(';
6107 0         0 $end_delimiter = ')';
6108             }
6109             elsif (not $octet{'}'}) {
6110 0         0 $delimiter = '{';
6111 0         0 $end_delimiter = '}';
6112             }
6113             elsif (not $octet{']'}) {
6114 0         0 $delimiter = '[';
6115 0         0 $end_delimiter = ']';
6116             }
6117             elsif (not $octet{'>'}) {
6118 0         0 $delimiter = '<';
6119 0         0 $end_delimiter = '>';
6120             }
6121             else {
6122 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6123 0 0       0 if (not $octet{$char}) {
6124 0         0 $delimiter = $char;
6125 0         0 $end_delimiter = $char;
6126 0         0 last;
6127             }
6128             }
6129             }
6130             }
6131              
6132             # count '('
6133 68         112 my $parens = grep { $_ eq '(' } @char;
  253         377  
6134              
6135 68         83 my $left_e = 0;
6136 68         74 my $right_e = 0;
6137 68         198 for (my $i=0; $i <= $#char; $i++) {
6138              
6139             # "\L\u" --> "\u\L"
6140 195 50 33     1318 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6141 0         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         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 1         2 $char[$i] = Ehebrew::octchr($1);
6152             }
6153              
6154             # hexadecimal escape sequence
6155             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6156 1         2 $char[$i] = Ehebrew::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         0 $char[$i] = $1 . '\\' . $2;
6166             }
6167              
6168             # \p, \P, \X --> p, P, X
6169             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6170 0         0 $char[$i] = $1;
6171             }
6172              
6173 195 50 66     742 if (0) {
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6174             }
6175              
6176             # join separated multiple-octet
6177 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6178 0 0 0     0 if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6179 0         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         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         0 $char[$i] .= join '', splice @char, $i+1, 1;
6186             }
6187             }
6188              
6189             # open character class [...]
6190             elsif ($char[$i] eq '[') {
6191 13         20 my $left = $i;
6192 13 50       44 if ($char[$i+1] eq ']') {
6193 0         0 $i++;
6194             }
6195 13         14 while (1) {
6196 58 50       107 if (++$i > $#char) {
6197 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6198             }
6199 58 100       90 if ($char[$i] eq ']') {
6200 13         16 my $right = $i;
6201              
6202             # [...]
6203 13 50       92 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6204 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ehebrew::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6205             }
6206             else {
6207 13         133 splice @char, $left, $right-$left+1, Ehebrew::charlist_qr(@char[$left+1..$right-1], $modifier);
6208             }
6209              
6210 13         25 $i = $left;
6211 13         41 last;
6212             }
6213             }
6214             }
6215              
6216             # open character class [^...]
6217             elsif ($char[$i] eq '[^') {
6218 0         0 my $left = $i;
6219 0 0       0 if ($char[$i+1] eq ']') {
6220 0         0 $i++;
6221             }
6222 0         0 while (1) {
6223 0 0       0 if (++$i > $#char) {
6224 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6225             }
6226 0 0       0 if ($char[$i] eq ']') {
6227 0         0 my $right = $i;
6228              
6229             # [^...]
6230 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6231 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ehebrew::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6232             }
6233             else {
6234 0         0 splice @char, $left, $right-$left+1, Ehebrew::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6235             }
6236              
6237 0         0 $i = $left;
6238 0         0 last;
6239             }
6240             }
6241             }
6242              
6243             # rewrite character class or escape character
6244             elsif (my $char = character_class($char[$i],$modifier)) {
6245 7         13 $char[$i] = $char;
6246             }
6247              
6248             # /i modifier
6249             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ehebrew::uc($char[$i]) ne Ehebrew::fc($char[$i]))) {
6250 3 50       6 if (CORE::length(Ehebrew::fc($char[$i])) == 1) {
6251 3         4 $char[$i] = '[' . Ehebrew::uc($char[$i]) . Ehebrew::fc($char[$i]) . ']';
6252             }
6253             else {
6254 0         0 $char[$i] = '(?:' . Ehebrew::uc($char[$i]) . '|' . Ehebrew::fc($char[$i]) . ')';
6255             }
6256             }
6257              
6258             # \u \l \U \L \F \Q \E
6259             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6260 0 0       0 if ($right_e < $left_e) {
6261 0         0 $char[$i] = '\\' . $char[$i];
6262             }
6263             }
6264             elsif ($char[$i] eq '\u') {
6265 0         0 $char[$i] = '@{[Ehebrew::ucfirst qq<';
6266 0         0 $left_e++;
6267             }
6268             elsif ($char[$i] eq '\l') {
6269 0         0 $char[$i] = '@{[Ehebrew::lcfirst qq<';
6270 0         0 $left_e++;
6271             }
6272             elsif ($char[$i] eq '\U') {
6273 0         0 $char[$i] = '@{[Ehebrew::uc qq<';
6274 0         0 $left_e++;
6275             }
6276             elsif ($char[$i] eq '\L') {
6277 0         0 $char[$i] = '@{[Ehebrew::lc qq<';
6278 0         0 $left_e++;
6279             }
6280             elsif ($char[$i] eq '\F') {
6281 0         0 $char[$i] = '@{[Ehebrew::fc qq<';
6282 0         0 $left_e++;
6283             }
6284             elsif ($char[$i] eq '\Q') {
6285 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
6286 0         0 $left_e++;
6287             }
6288             elsif ($char[$i] eq '\E') {
6289 0 0       0 if ($right_e < $left_e) {
6290 0         0 $char[$i] = '>]}';
6291 0         0 $right_e++;
6292             }
6293             else {
6294 0         0 $char[$i] = '';
6295             }
6296             }
6297             elsif ($char[$i] eq '\Q') {
6298 0         0 while (1) {
6299 0 0       0 if (++$i > $#char) {
6300 0         0 last;
6301             }
6302 0 0       0 if ($char[$i] eq '\E') {
6303 0         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       0 if ($ignorecase) {
6343 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
6344             }
6345             }
6346             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6347 0 0       0 if ($ignorecase) {
6348 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
6360 0 0       0 if ($ignorecase) {
6361 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
6362             }
6363             }
6364             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6365 0         0 $char[$i] = e_capture($1);
6366 0 0       0 if ($ignorecase) {
6367 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1.'->'.$2);
6374 0 0       0 if ($ignorecase) {
6375 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1.'->'.$2);
6382 0 0       0 if ($ignorecase) {
6383 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
6390 0 0       0 if ($ignorecase) {
6391 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
6392             }
6393             }
6394              
6395             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ehebrew::PREMATCH()
6396             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6397 4 50       12 if ($ignorecase) {
6398 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::PREMATCH())]}';
6399             }
6400             else {
6401 4         21 $char[$i] = '@{[Ehebrew::PREMATCH()]}';
6402             }
6403             }
6404              
6405             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ehebrew::MATCH()
6406             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6407 4 50       12 if ($ignorecase) {
6408 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::MATCH())]}';
6409             }
6410             else {
6411 4         23 $char[$i] = '@{[Ehebrew::MATCH()]}';
6412             }
6413             }
6414              
6415             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ehebrew::POSTMATCH()
6416             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6417 3 50       10 if ($ignorecase) {
6418 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::POSTMATCH())]}';
6419             }
6420             else {
6421 3         16 $char[$i] = '@{[Ehebrew::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       0 if ($ignorecase) {
6428 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
6429             }
6430             }
6431              
6432             # ${ ... }
6433             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6434 0         0 $char[$i] = e_capture($1);
6435 0 0       0 if ($ignorecase) {
6436 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
6437             }
6438             }
6439              
6440             # $scalar or @array
6441             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6442 4         12 $char[$i] = e_string($char[$i]);
6443 4 50       34 if ($ignorecase) {
6444 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
6445             }
6446             }
6447              
6448             # quote character before ? + * {
6449             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6450 13 50       70 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 13         105 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6454             }
6455             }
6456             }
6457              
6458             # make regexp string
6459 68         112 my $prematch = '';
6460 68         99 $modifier =~ tr/i//d;
6461 68 50       198 if ($left_e > $right_e) {
6462 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6463             }
6464 68         767 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 21     21 0 30 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6472 21   100     58 $modifier ||= '';
6473              
6474 21         19 $modifier =~ tr/p//d;
6475 21 50       40 if ($modifier =~ /([adlu])/oxms) {
6476 0         0 my $line = 0;
6477 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6478 0 0       0 if ($filename ne __FILE__) {
6479 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6480 0         0 last;
6481             }
6482             }
6483 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6484             }
6485              
6486 21         22 $slash = 'div';
6487              
6488             # literal null string pattern
6489 21 100       44 if ($string eq '') {
    50          
6490 8         8 $modifier =~ tr/bB//d;
6491 8         6 $modifier =~ tr/i//d;
6492 8         48 return join '', $ope, $delimiter, $end_delimiter, $modifier;
6493             }
6494              
6495             # with /b /B modifier
6496             elsif ($modifier =~ tr/bB//d) {
6497 0         0 return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6498             }
6499              
6500             # without /b /B modifier
6501             else {
6502 13         26 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 13     13 0 21 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6511              
6512 13 50       38 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6513              
6514             # split regexp
6515 13         224 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 13         39 for (my $i=0; $i <= $#char; $i++) {
6528 25 50 33     102 if (0) {
    50 33        
    50 66        
    100          
    50          
    50          
6529             }
6530              
6531             # open character class [...]
6532 0         0 elsif ($char[$i] eq '[') {
6533 0         0 my $left = $i;
6534 0 0       0 if ($char[$i+1] eq ']') {
6535 0         0 $i++;
6536             }
6537 0         0 while (1) {
6538 0 0       0 if (++$i > $#char) {
6539 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6540             }
6541 0 0       0 if ($char[$i] eq ']') {
6542 0         0 my $right = $i;
6543              
6544             # [...]
6545 0         0 splice @char, $left, $right-$left+1, Ehebrew::charlist_qr(@char[$left+1..$right-1], $modifier);
6546              
6547 0         0 $i = $left;
6548 0         0 last;
6549             }
6550             }
6551             }
6552              
6553             # open character class [^...]
6554             elsif ($char[$i] eq '[^') {
6555 0         0 my $left = $i;
6556 0 0       0 if ($char[$i+1] eq ']') {
6557 0         0 $i++;
6558             }
6559 0         0 while (1) {
6560 0 0       0 if (++$i > $#char) {
6561 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6562             }
6563 0 0       0 if ($char[$i] eq ']') {
6564 0         0 my $right = $i;
6565              
6566             # [^...]
6567 0         0 splice @char, $left, $right-$left+1, Ehebrew::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6568              
6569 0         0 $i = $left;
6570 0         0 last;
6571             }
6572             }
6573             }
6574              
6575             # escape $ @ / and \
6576             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6577 0         0 $char[$i] = '\\' . $char[$i];
6578             }
6579              
6580             # rewrite character class or escape character
6581             elsif (my $char = character_class($char[$i],$modifier)) {
6582 6         11 $char[$i] = $char;
6583             }
6584              
6585             # /i modifier
6586             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ehebrew::uc($char[$i]) ne Ehebrew::fc($char[$i]))) {
6587 0 0       0 if (CORE::length(Ehebrew::fc($char[$i])) == 1) {
6588 0         0 $char[$i] = '[' . Ehebrew::uc($char[$i]) . Ehebrew::fc($char[$i]) . ']';
6589             }
6590             else {
6591 0         0 $char[$i] = '(?:' . Ehebrew::uc($char[$i]) . '|' . Ehebrew::fc($char[$i]) . ')';
6592             }
6593             }
6594              
6595             # quote character before ? + * {
6596             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6597 0 0       0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6598             }
6599             else {
6600 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
6601             }
6602             }
6603             }
6604              
6605 13         16 $modifier =~ tr/i//d;
6606 13         13 $delimiter = '/';
6607 13         13 $end_delimiter = '/';
6608 13         14 my $prematch = '';
6609 13         83 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 0 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6617              
6618             # split regexp
6619 0         0 my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6620              
6621             # unescape character
6622 0         0 for (my $i=0; $i <= $#char; $i++) {
6623 0 0       0 if (0) {
    0          
6624             }
6625              
6626             # remain \\
6627 0         0 elsif ($char[$i] eq '\\\\') {
6628             }
6629              
6630             # escape $ @ / and \
6631             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6632 0         0 $char[$i] = '\\' . $char[$i];
6633             }
6634             }
6635              
6636 0         0 $delimiter = '/';
6637 0         0 $end_delimiter = '/';
6638 0         0 my $prematch = '';
6639 0         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 16     16 0 19 my($ope,$delimiter,$end_delimiter,$string) = @_;
6647              
6648 16         18 $slash = 'div';
6649              
6650 16         100 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
6651 16         44 for (my $i=0; $i <= $#char; $i++) {
6652 9 100       29 if (0) {
    100          
6653             }
6654              
6655             # not escape \\
6656 0         0 elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6657             }
6658              
6659             # escape $ @ / and \
6660             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6661 5         13 $char[$i] = '\\' . $char[$i];
6662             }
6663             }
6664              
6665 16         45 return join '', $ope, $delimiter, @char, $end_delimiter;
6666             }
6667              
6668             #
6669             # escape regexp (s/here/and here/modifier)
6670             #
6671             sub e_sub {
6672 97     97 0 398 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6673 97   100     327 $modifier ||= '';
6674              
6675 97         157 $modifier =~ tr/p//d;
6676 97 50       279 if ($modifier =~ /([adlu])/oxms) {
6677 0         0 my $line = 0;
6678 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6679 0 0       0 if ($filename ne __FILE__) {
6680 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6681 0         0 last;
6682             }
6683             }
6684 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6685             }
6686              
6687 97 100       216 if ($variable eq '') {
6688 36         31 $variable = '$_';
6689 36         32 $bind_operator = ' =~ ';
6690             }
6691              
6692 97         115 $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 97         120 my $e_modifier = $modifier =~ tr/e//d;
6710 97         106 my $r_modifier = $modifier =~ tr/r//d;
6711              
6712 97         107 my $my = '';
6713 97 50       232 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6714 0         0 $my = $variable;
6715 0         0 $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6716 0         0 $variable =~ s/ = .+ \z//oxms;
6717             }
6718              
6719 97         191 (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6720 97         151 $variable_basename =~ s/ \s+ \z//oxms;
6721              
6722             # quote replacement string
6723 97         109 my $e_replacement = '';
6724 97 100       210 if ($e_modifier >= 1) {
6725 17         26 $e_replacement = e_qq('', '', '', $replacement);
6726 17         16 $e_modifier--;
6727             }
6728             else {
6729 80 100       160 if ($delimiter2 eq "'") {
6730 16         31 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6731             }
6732             else {
6733 64         135 $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6734             }
6735             }
6736              
6737 97         131 my $sub = '';
6738              
6739             # with /r
6740 97 100       181 if ($r_modifier) {
6741 8 100       27 if (0) {
6742             }
6743              
6744             # s///gr without multibyte anchoring
6745 0         0 elsif ($modifier =~ /g/oxms) {
6746 4 50       27 $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             '$Hebrew::re_r=CORE::eval $Hebrew::re_r; ' x $e_modifier, # 5
6757             );
6758             }
6759              
6760             # s///r
6761             else {
6762              
6763 4         5 my $prematch = q{$`};
6764              
6765 4 50       17 $sub = sprintf(
6766             # 1 2 3 4 5 6 7
6767             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Hebrew::re_r=%s; %s"%s$Hebrew::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             '$Hebrew::re_r=CORE::eval $Hebrew::re_r; ' x $e_modifier, # 5
6776             $prematch, # 6
6777             $variable, # 7
6778             );
6779             }
6780              
6781             # $var !~ s///r doesn't make sense
6782 8 50       28 if ($bind_operator =~ / !~ /oxms) {
6783 0         0 $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
6784             }
6785             }
6786              
6787             # without /r
6788             else {
6789 89 100       177 if (0) {
6790             }
6791              
6792             # s///g without multibyte anchoring
6793 0         0 elsif ($modifier =~ /g/oxms) {
6794 22 100       75 $sub = sprintf(
    100          
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             '$Hebrew::re_r=CORE::eval $Hebrew::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 67         73 my $prematch = q{$`};
6815              
6816 67 100       330 $sub = sprintf(
    100          
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 $Hebrew::re_r=%s; %s%s="%s$Hebrew::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 $Hebrew::re_r=%s; %s%s="%s$Hebrew::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             '$Hebrew::re_r=CORE::eval $Hebrew::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 97 50       232 if ($my ne '') {
6842 0         0 $sub = "($my, $sub)[1]";
6843             }
6844              
6845             # clear s/// variable
6846 97         115 $sub_variable = '';
6847 97         95 $bind_operator = '';
6848              
6849 97         634 return $sub;
6850             }
6851              
6852             #
6853             # escape regexp of split qr//
6854             #
6855             sub e_split {
6856 74     74 0 237 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6857 74   100     361 $modifier ||= '';
6858              
6859 74         114 $modifier =~ tr/p//d;
6860 74 50       342 if ($modifier =~ /([adlu])/oxms) {
6861 0         0 my $line = 0;
6862 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6863 0 0       0 if ($filename ne __FILE__) {
6864 0         0 $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6865 0         0 last;
6866             }
6867             }
6868 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
6869             }
6870              
6871 74         117 $slash = 'div';
6872              
6873             # /b /B modifier
6874 74 50       160 if ($modifier =~ tr/bB//d) {
6875 0         0 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
6876             }
6877              
6878 74 50       174 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6879 74         274 my $metachar = qr/[\@\\|[\]{^]/oxms;
6880              
6881             # split regexp
6882 74         10128 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 74         245 my $left_e = 0;
6907 74         137 my $right_e = 0;
6908 74         249 for (my $i=0; $i <= $#char; $i++) {
6909              
6910             # "\L\u" --> "\u\L"
6911 249 50 33     1864 if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
    50 33        
    100          
    100          
    50          
    50          
6912 0         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         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 1         3 $char[$i] = Ehebrew::octchr($1);
6923             }
6924              
6925             # hexadecimal escape sequence
6926             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6927 1         2 $char[$i] = Ehebrew::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         0 $char[$i] = $1 . '\\' . $2;
6937             }
6938              
6939             # \p, \P, \X --> p, P, X
6940             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6941 0         0 $char[$i] = $1;
6942             }
6943              
6944 249 50 100     1121 if (0) {
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6945             }
6946              
6947             # join separated multiple-octet
6948 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6949 0 0 0     0 if ( ($i+3 <= $#char) and (grep(/\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms, @char[$i+1..$i+3]) == 3) and (CORE::eval(sprintf '"%s%s%s%s"', @char[$i..$i+3]) =~ /\A $q_char \z/oxms)) {
    0 0        
    0 0        
      0        
      0        
      0        
6950 0         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         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         0 $char[$i] .= join '', splice @char, $i+1, 1;
6957             }
6958             }
6959              
6960             # open character class [...]
6961             elsif ($char[$i] eq '[') {
6962 3         8 my $left = $i;
6963 3 50       15 if ($char[$i+1] eq ']') {
6964 0         0 $i++;
6965             }
6966 3         6 while (1) {
6967 7 50       31 if (++$i > $#char) {
6968 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6969             }
6970 7 100       20 if ($char[$i] eq ']') {
6971 3         7 my $right = $i;
6972              
6973             # [...]
6974 3 50       29 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6975 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ehebrew::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
6976             }
6977             else {
6978 3         19 splice @char, $left, $right-$left+1, Ehebrew::charlist_qr(@char[$left+1..$right-1], $modifier);
6979             }
6980              
6981 3         7 $i = $left;
6982 3         13 last;
6983             }
6984             }
6985             }
6986              
6987             # open character class [^...]
6988             elsif ($char[$i] eq '[^') {
6989 0         0 my $left = $i;
6990 0 0       0 if ($char[$i+1] eq ']') {
6991 0         0 $i++;
6992             }
6993 0         0 while (1) {
6994 0 0       0 if (++$i > $#char) {
6995 0         0 die __FILE__, ": Unmatched [] in regexp\n";
6996             }
6997 0 0       0 if ($char[$i] eq ']') {
6998 0         0 my $right = $i;
6999              
7000             # [^...]
7001 0 0       0 if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7002 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Ehebrew::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
  0         0  
7003             }
7004             else {
7005 0         0 splice @char, $left, $right-$left+1, Ehebrew::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7006             }
7007              
7008 0         0 $i = $left;
7009 0         0 last;
7010             }
7011             }
7012             }
7013              
7014             # rewrite character class or escape character
7015             elsif (my $char = character_class($char[$i],$modifier)) {
7016 1         2 $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 7         40 $modifier .= 'm';
7034             }
7035              
7036             # /i modifier
7037             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Ehebrew::uc($char[$i]) ne Ehebrew::fc($char[$i]))) {
7038 0 0       0 if (CORE::length(Ehebrew::fc($char[$i])) == 1) {
7039 0         0 $char[$i] = '[' . Ehebrew::uc($char[$i]) . Ehebrew::fc($char[$i]) . ']';
7040             }
7041             else {
7042 0         0 $char[$i] = '(?:' . Ehebrew::uc($char[$i]) . '|' . Ehebrew::fc($char[$i]) . ')';
7043             }
7044             }
7045              
7046             # \u \l \U \L \F \Q \E
7047             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7048 0 0       0 if ($right_e < $left_e) {
7049 0         0 $char[$i] = '\\' . $char[$i];
7050             }
7051             }
7052             elsif ($char[$i] eq '\u') {
7053 0         0 $char[$i] = '@{[Ehebrew::ucfirst qq<';
7054 0         0 $left_e++;
7055             }
7056             elsif ($char[$i] eq '\l') {
7057 0         0 $char[$i] = '@{[Ehebrew::lcfirst qq<';
7058 0         0 $left_e++;
7059             }
7060             elsif ($char[$i] eq '\U') {
7061 0         0 $char[$i] = '@{[Ehebrew::uc qq<';
7062 0         0 $left_e++;
7063             }
7064             elsif ($char[$i] eq '\L') {
7065 0         0 $char[$i] = '@{[Ehebrew::lc qq<';
7066 0         0 $left_e++;
7067             }
7068             elsif ($char[$i] eq '\F') {
7069 0         0 $char[$i] = '@{[Ehebrew::fc qq<';
7070 0         0 $left_e++;
7071             }
7072             elsif ($char[$i] eq '\Q') {
7073 0         0 $char[$i] = '@{[CORE::quotemeta qq<';
7074 0         0 $left_e++;
7075             }
7076             elsif ($char[$i] eq '\E') {
7077 0 0       0 if ($right_e < $left_e) {
7078 0         0 $char[$i] = '>]}';
7079 0         0 $right_e++;
7080             }
7081             else {
7082 0         0 $char[$i] = '';
7083             }
7084             }
7085             elsif ($char[$i] eq '\Q') {
7086 0         0 while (1) {
7087 0 0       0 if (++$i > $#char) {
7088 0         0 last;
7089             }
7090 0 0       0 if ($char[$i] eq '\E') {
7091 0         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       0 if ($ignorecase) {
7101 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
7102             }
7103             }
7104             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7105 0 0       0 if ($ignorecase) {
7106 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
7118 0 0       0 if ($ignorecase) {
7119 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
7120             }
7121             }
7122             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7123 0         0 $char[$i] = e_capture($1);
7124 0 0       0 if ($ignorecase) {
7125 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1.'->'.$2);
7132 0 0       0 if ($ignorecase) {
7133 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1.'->'.$2);
7140 0 0       0 if ($ignorecase) {
7141 0         0 $char[$i] = '@{[Ehebrew::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         0 $char[$i] = e_capture($1);
7148 0 0       0 if ($ignorecase) {
7149 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
7150             }
7151             }
7152              
7153             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Ehebrew::PREMATCH()
7154             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7155 12 50       23 if ($ignorecase) {
7156 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::PREMATCH())]}';
7157             }
7158             else {
7159 12         83 $char[$i] = '@{[Ehebrew::PREMATCH()]}';
7160             }
7161             }
7162              
7163             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Ehebrew::MATCH()
7164             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7165 12 50       30 if ($ignorecase) {
7166 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::MATCH())]}';
7167             }
7168             else {
7169 12         82 $char[$i] = '@{[Ehebrew::MATCH()]}';
7170             }
7171             }
7172              
7173             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Ehebrew::POSTMATCH()
7174             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7175 9 50       16 if ($ignorecase) {
7176 0         0 $char[$i] = '@{[Ehebrew::ignorecase(Ehebrew::POSTMATCH())]}';
7177             }
7178             else {
7179 9         60 $char[$i] = '@{[Ehebrew::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       0 if ($ignorecase) {
7186 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $1 . ')]}';
7187             }
7188             }
7189              
7190             # ${ ... }
7191             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7192 0         0 $char[$i] = e_capture($1);
7193 0 0       0 if ($ignorecase) {
7194 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
7195             }
7196             }
7197              
7198             # $scalar or @array
7199             elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7200 3         13 $char[$i] = e_string($char[$i]);
7201 3 50       19 if ($ignorecase) {
7202 0         0 $char[$i] = '@{[Ehebrew::ignorecase(' . $char[$i] . ')]}';
7203             }
7204             }
7205              
7206             # quote character before ? + * {
7207             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7208 1 50       13 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         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
7212             }
7213             }
7214             }
7215              
7216             # make regexp string
7217 74         109 $modifier =~ tr/i//d;
7218 74 50       192 if ($left_e > $right_e) {
7219 0         0 return join '', 'Ehebrew::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7220             }
7221 74         814 return join '', 'Ehebrew::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, Ehebrew::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, Ehebrew::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 (Ehebrew::uc($char[$i]) ne Ehebrew::fc($char[$i]))) {
7324 0 0         if (CORE::length(Ehebrew::fc($char[$i])) == 1) {
7325 0           $char[$i] = '[' . Ehebrew::uc($char[$i]) . Ehebrew::fc($char[$i]) . ']';
7326             }
7327             else {
7328 0           $char[$i] = '(?:' . Ehebrew::uc($char[$i]) . '|' . Ehebrew::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 '', 'Ehebrew::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__