File Coverage

blib/lib/Etis620.pm
Criterion Covered Total %
statement 896 3194 28.0
branch 962 2740 35.1
condition 97 355 27.3
subroutine 52 110 47.2
pod 7 74 9.4
total 2014 6473 31.1


line stmt bran cond sub pod time code
1             package Etis620;
2 204     204   1257 use strict;
  204         329  
  204         7003  
3             ######################################################################
4             #
5             # Etis620 - Run-time routines for TIS620.pm
6             #
7             # http://search.cpan.org/dist/Char-TIS620/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 204     204   4397 use 5.00503; # Galapagos Consensus 1998 for primetools
  204         614  
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             # 12.3. Delaying use Until Runtime
16             # in Chapter 12. Packages, Libraries, and Modules
17             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
18             # (and so on)
19              
20             # Version numbers should be boring
21             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
22             # For the impatient, the disinterested or those who just want to follow
23             # a recipe, my advice for all modules is this:
24             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
25             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
26              
27 204     204   1136 use vars qw($VERSION);
  204         364  
  204         30678  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 204 50   204   2940 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 204         342 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 204         38763 if (CORE::ord('A') != 0x41) {
39             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
40             }
41             }
42              
43             BEGIN {
44              
45             # instead of utf8.pm
46 204     204   19127 CORE::eval q{
  204     204   1428  
  204     70   796  
  204         23625  
  0         0  
  0         0  
  0         0  
  0         0  
47             no warnings qw(redefine);
48             *utf8::upgrade = sub { CORE::length $_[0] };
49             *utf8::downgrade = sub { 1 };
50             *utf8::encode = sub { };
51             *utf8::decode = sub { 1 };
52             *utf8::is_utf8 = sub { };
53             *utf8::valid = sub { 1 };
54             };
55 204 50       90625 if ($@) {
56 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
57 0         0 *utf8::downgrade = sub { 1 };
  0         0  
58 0         0 *utf8::encode = sub { };
59 0         0 *utf8::decode = sub { 1 };
  0         0  
60 0         0 *utf8::is_utf8 = sub { };
61 0         0 *utf8::valid = sub { 1 };
  0         0  
62             }
63             }
64              
65             # instead of Symbol.pm
66 0         0 BEGIN {
67             sub gensym () {
68 0     0 0 0 return \do { local *_ };
  0         0  
69             }
70              
71             sub qualify ($$) {
72 0     0 0 0 my($name) = @_;
73              
74 0 0       0 if (ref $name) {
    0          
    0          
    0          
    0          
    0          
    0          
75 0         0 return $name;
76             }
77             elsif (Etis620::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Etis620::index($name,"'") >= 0) {
81 0         0 return $name;
82             }
83              
84             # special character, "^xyz"
85             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
86              
87             # RGS 2001-11-05 : translate leading ^X to control-char
88 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
89 0         0 return 'main::' . $name;
90             }
91              
92             # Global names
93             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
94 0         0 return 'main::' . $name;
95             }
96              
97             # or other
98             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
99 0         0 return 'main::' . $name;
100             }
101              
102             elsif (defined $_[1]) {
103 0         0 return $_[1] . '::' . $name;
104             }
105             else {
106 0         0 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 0   0 0 0 if (defined $_[1]) {
112 204     204   1448 no strict qw(refs);
  204         376  
  204         16366  
113 0         0 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 204     204   1251 no strict qw(refs);
  204     0   744  
  204         46978  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  0         0  
118             }
119             }
120             }
121              
122             # P.714 29.2.39. flock
123             # in Chapter 29: Functions
124             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
125              
126             # P.863 flock
127             # in Chapter 27: Functions
128             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
129              
130             sub LOCK_SH() {1}
131             sub LOCK_EX() {2}
132             sub LOCK_UN() {8}
133             sub LOCK_NB() {4}
134              
135             # instead of Carp.pm
136             sub carp;
137             sub croak;
138             sub cluck;
139             sub confess;
140              
141             # 6.18. Matching Multiple-Byte Characters
142             # in Chapter 6. Pattern Matching
143             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
144             # (and so on)
145              
146             # regexp of character
147             my $your_char = q{[\x00-\xFF]};
148 204     204   1379 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  204         791  
  204         24519  
149 204     204   1378 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  204         413  
  204         191630  
150              
151             #
152             # TIS-620 character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # TIS-620 case conversion
158             #
159             my %lc = ();
160             @lc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
161             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
162             my %uc = ();
163             @uc{qw(a b c d e f g h i j k l m n o p q r s t u v w x y z)} =
164             qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
165             my %fc = ();
166             @fc{qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z)} =
167             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
168              
169             if (0) {
170             }
171              
172             elsif (__PACKAGE__ =~ / \b Etis620 \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0xFF],
175             ],
176             );
177             }
178              
179             else {
180             croak "Don't know my package name '@{[__PACKAGE__]}'";
181             }
182              
183             #
184             # @ARGV wildcard globbing
185             #
186             sub import {
187              
188 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
189 0         0 my @argv = ();
190 0         0 for (@ARGV) {
191              
192             # has space
193 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
194 0 0       0 if (my @glob = Etis620::glob(qq{"$_"})) {
195 0         0 push @argv, @glob;
196             }
197             else {
198 0         0 push @argv, $_;
199             }
200             }
201              
202             # has wildcard metachar
203             elsif (/\A (?:$q_char)*? [*?] /oxms) {
204 0 0       0 if (my @glob = Etis620::glob($_)) {
205 0         0 push @argv, @glob;
206             }
207             else {
208 0         0 push @argv, $_;
209             }
210             }
211              
212             # no wildcard globbing
213             else {
214 0         0 push @argv, $_;
215             }
216             }
217 0         0 @ARGV = @argv;
218             }
219              
220 0         0 *Char::ord = \&TIS620::ord;
221 0         0 *Char::ord_ = \&TIS620::ord_;
222 0         0 *Char::reverse = \&TIS620::reverse;
223 0         0 *Char::getc = \&TIS620::getc;
224 0         0 *Char::length = \&TIS620::length;
225 0         0 *Char::substr = \&TIS620::substr;
226 0         0 *Char::index = \&TIS620::index;
227 0         0 *Char::rindex = \&TIS620::rindex;
228 0         0 *Char::eval = \&TIS620::eval;
229 0         0 *Char::escape = \&TIS620::escape;
230 0         0 *Char::escape_token = \&TIS620::escape_token;
231 0         0 *Char::escape_script = \&TIS620::escape_script;
232             }
233              
234             # P.230 Care with Prototypes
235             # in Chapter 6: Subroutines
236             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
237             #
238             # If you aren't careful, you can get yourself into trouble with prototypes.
239             # But if you are careful, you can do a lot of neat things with them. This is
240             # all very powerful, of course, and should only be used in moderation to make
241             # the world a better place.
242              
243             # P.332 Care with Prototypes
244             # in Chapter 7: Subroutines
245             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
246             #
247             # If you aren't careful, you can get yourself into trouble with prototypes.
248             # But if you are careful, you can do a lot of neat things with them. This is
249             # all very powerful, of course, and should only be used in moderation to make
250             # the world a better place.
251              
252             #
253             # Prototypes of subroutines
254             #
255       0     sub unimport {}
256             sub Etis620::split(;$$$);
257             sub Etis620::tr($$$$;$);
258             sub Etis620::chop(@);
259             sub Etis620::index($$;$);
260             sub Etis620::rindex($$;$);
261             sub Etis620::lcfirst(@);
262             sub Etis620::lcfirst_();
263             sub Etis620::lc(@);
264             sub Etis620::lc_();
265             sub Etis620::ucfirst(@);
266             sub Etis620::ucfirst_();
267             sub Etis620::uc(@);
268             sub Etis620::uc_();
269             sub Etis620::fc(@);
270             sub Etis620::fc_();
271             sub Etis620::ignorecase;
272             sub Etis620::classic_character_class;
273             sub Etis620::capture;
274             sub Etis620::chr(;$);
275             sub Etis620::chr_();
276             sub Etis620::glob($);
277             sub Etis620::glob_();
278              
279             sub TIS620::ord(;$);
280             sub TIS620::ord_();
281             sub TIS620::reverse(@);
282             sub TIS620::getc(;*@);
283             sub TIS620::length(;$);
284             sub TIS620::substr($$;$$);
285             sub TIS620::index($$;$);
286             sub TIS620::rindex($$;$);
287             sub TIS620::escape(;$);
288              
289             #
290             # Regexp work
291             #
292 204         21775 use vars qw(
293             $re_a
294             $re_t
295             $re_n
296             $re_r
297 204     204   1341 );
  204         476  
298              
299             #
300             # Character class
301             #
302 204         2106060 use vars qw(
303             $dot
304             $dot_s
305             $eD
306             $eS
307             $eW
308             $eH
309             $eV
310             $eR
311             $eN
312             $not_alnum
313             $not_alpha
314             $not_ascii
315             $not_blank
316             $not_cntrl
317             $not_digit
318             $not_graph
319             $not_lower
320             $not_lower_i
321             $not_print
322             $not_punct
323             $not_space
324             $not_upper
325             $not_upper_i
326             $not_word
327             $not_xdigit
328             $eb
329             $eB
330 204     204   1443 );
  204         373  
331              
332             ${Etis620::dot} = qr{(?>[^\x0A])};
333             ${Etis620::dot_s} = qr{(?>[\x00-\xFF])};
334             ${Etis620::eD} = qr{(?>[^0-9])};
335              
336             # Vertical tabs are now whitespace
337             # \s in a regex now matches a vertical tab in all circumstances.
338             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
339             # ${Etis620::eS} = qr{(?>[^\x09\x0A \x0C\x0D\x20])};
340             # ${Etis620::eS} = qr{(?>[^\x09\x0A\x0B\x0C\x0D\x20])};
341             ${Etis620::eS} = qr{(?>[^\s])};
342              
343             ${Etis620::eW} = qr{(?>[^0-9A-Z_a-z])};
344             ${Etis620::eH} = qr{(?>[^\x09\x20])};
345             ${Etis620::eV} = qr{(?>[^\x0A\x0B\x0C\x0D])};
346             ${Etis620::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
347             ${Etis620::eN} = qr{(?>[^\x0A])};
348             ${Etis620::not_alnum} = qr{(?>[^\x30-\x39\x41-\x5A\x61-\x7A])};
349             ${Etis620::not_alpha} = qr{(?>[^\x41-\x5A\x61-\x7A])};
350             ${Etis620::not_ascii} = qr{(?>[^\x00-\x7F])};
351             ${Etis620::not_blank} = qr{(?>[^\x09\x20])};
352             ${Etis620::not_cntrl} = qr{(?>[^\x00-\x1F\x7F])};
353             ${Etis620::not_digit} = qr{(?>[^\x30-\x39])};
354             ${Etis620::not_graph} = qr{(?>[^\x21-\x7F])};
355             ${Etis620::not_lower} = qr{(?>[^\x61-\x7A])};
356             ${Etis620::not_lower_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
357             # ${Etis620::not_lower_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
358             ${Etis620::not_print} = qr{(?>[^\x20-\x7F])};
359             ${Etis620::not_punct} = qr{(?>[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
360             ${Etis620::not_space} = qr{(?>[^\s\x0B])};
361             ${Etis620::not_upper} = qr{(?>[^\x41-\x5A])};
362             ${Etis620::not_upper_i} = qr{(?>[^\x41-\x5A\x61-\x7A])}; # Perl 5.16 compatible
363             # ${Etis620::not_upper_i} = qr{(?>[\x00-\xFF])}; # older Perl compatible
364             ${Etis620::not_word} = qr{(?>[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
365             ${Etis620::not_xdigit} = qr{(?>[^\x30-\x39\x41-\x46\x61-\x66])};
366             ${Etis620::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))};
367             ${Etis620::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]))};
368              
369             # avoid: Name "Etis620::foo" used only once: possible typo at here.
370             ${Etis620::dot} = ${Etis620::dot};
371             ${Etis620::dot_s} = ${Etis620::dot_s};
372             ${Etis620::eD} = ${Etis620::eD};
373             ${Etis620::eS} = ${Etis620::eS};
374             ${Etis620::eW} = ${Etis620::eW};
375             ${Etis620::eH} = ${Etis620::eH};
376             ${Etis620::eV} = ${Etis620::eV};
377             ${Etis620::eR} = ${Etis620::eR};
378             ${Etis620::eN} = ${Etis620::eN};
379             ${Etis620::not_alnum} = ${Etis620::not_alnum};
380             ${Etis620::not_alpha} = ${Etis620::not_alpha};
381             ${Etis620::not_ascii} = ${Etis620::not_ascii};
382             ${Etis620::not_blank} = ${Etis620::not_blank};
383             ${Etis620::not_cntrl} = ${Etis620::not_cntrl};
384             ${Etis620::not_digit} = ${Etis620::not_digit};
385             ${Etis620::not_graph} = ${Etis620::not_graph};
386             ${Etis620::not_lower} = ${Etis620::not_lower};
387             ${Etis620::not_lower_i} = ${Etis620::not_lower_i};
388             ${Etis620::not_print} = ${Etis620::not_print};
389             ${Etis620::not_punct} = ${Etis620::not_punct};
390             ${Etis620::not_space} = ${Etis620::not_space};
391             ${Etis620::not_upper} = ${Etis620::not_upper};
392             ${Etis620::not_upper_i} = ${Etis620::not_upper_i};
393             ${Etis620::not_word} = ${Etis620::not_word};
394             ${Etis620::not_xdigit} = ${Etis620::not_xdigit};
395             ${Etis620::eb} = ${Etis620::eb};
396             ${Etis620::eB} = ${Etis620::eB};
397              
398             #
399             # TIS-620 split
400             #
401             sub Etis620::split(;$$$) {
402              
403             # P.794 29.2.161. split
404             # in Chapter 29: Functions
405             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
406              
407             # P.951 split
408             # in Chapter 27: Functions
409             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
410              
411 0     0 0 0 my $pattern = $_[0];
412 0         0 my $string = $_[1];
413 0         0 my $limit = $_[2];
414              
415             # if $pattern is also omitted or is the literal space, " "
416 0 0       0 if (not defined $pattern) {
417 0         0 $pattern = ' ';
418             }
419              
420             # if $string is omitted, the function splits the $_ string
421 0 0       0 if (not defined $string) {
422 0 0       0 if (defined $_) {
423 0         0 $string = $_;
424             }
425             else {
426 0         0 $string = '';
427             }
428             }
429              
430 0         0 my @split = ();
431              
432             # when string is empty
433 0 0       0 if ($string eq '') {
    0          
434              
435             # resulting list value in list context
436 0 0       0 if (wantarray) {
437 0         0 return @split;
438             }
439              
440             # count of substrings in scalar context
441             else {
442 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
443 0         0 @_ = @split;
444 0         0 return scalar @_;
445             }
446             }
447              
448             # split's first argument is more consistently interpreted
449             #
450             # After some changes earlier in v5.17, split's behavior has been simplified:
451             # if the PATTERN argument evaluates to a string containing one space, it is
452             # treated the way that a literal string containing one space once was.
453             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
454              
455             # if $pattern is also omitted or is the literal space, " ", the function splits
456             # on whitespace, /\s+/, after skipping any leading whitespace
457             # (and so on)
458              
459             elsif ($pattern eq ' ') {
460 0 0       0 if (not defined $limit) {
461 0         0 return CORE::split(' ', $string);
462             }
463             else {
464 0         0 return CORE::split(' ', $string, $limit);
465             }
466             }
467              
468             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
469 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
470              
471             # a pattern capable of matching either the null string or something longer than the
472             # null string will split the value of $string into separate characters wherever it
473             # matches the null string between characters
474             # (and so on)
475              
476 0 0       0 if ('' =~ / \A $pattern \z /xms) {
477 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
478 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
479              
480             # P.1024 Appendix W.10 Multibyte Processing
481             # of ISBN 1-56592-224-7 CJKV Information Processing
482             # (and so on)
483              
484             # the //m modifier is assumed when you split on the pattern /^/
485             # (and so on)
486              
487             # V
488 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
489              
490             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
491             # is included in the resulting list, interspersed with the fields that are ordinarily returned
492             # (and so on)
493              
494 0         0 local $@;
495 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
496 0         0 push @split, CORE::eval('$' . $digit);
497             }
498             }
499             }
500              
501             else {
502 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
503              
504             # V
505 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
506 0         0 local $@;
507 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
508 0         0 push @split, CORE::eval('$' . $digit);
509             }
510             }
511             }
512             }
513              
514             elsif ($limit > 0) {
515 0 0       0 if ('' =~ / \A $pattern \z /xms) {
516 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
517 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
518              
519             # V
520 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
521 0         0 local $@;
522 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
523 0         0 push @split, CORE::eval('$' . $digit);
524             }
525             }
526             }
527             }
528             else {
529 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
530 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
531              
532             # V
533 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
534 0         0 local $@;
535 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
536 0         0 push @split, CORE::eval('$' . $digit);
537             }
538             }
539             }
540             }
541             }
542              
543 0 0       0 if (CORE::length($string) > 0) {
544 0         0 push @split, $string;
545             }
546              
547             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
548 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
549 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
550 0         0 pop @split;
551             }
552             }
553              
554             # resulting list value in list context
555 0 0       0 if (wantarray) {
556 0         0 return @split;
557             }
558              
559             # count of substrings in scalar context
560             else {
561 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
562 0         0 @_ = @split;
563 0         0 return scalar @_;
564             }
565             }
566              
567             #
568             # get last subexpression offsets
569             #
570             sub _last_subexpression_offsets {
571 0     0   0 my $pattern = $_[0];
572              
573             # remove comment
574 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
575              
576 0         0 my $modifier = '';
577 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
578 0         0 $modifier = $1;
579 0         0 $modifier =~ s/-[A-Za-z]*//;
580             }
581              
582             # with /x modifier
583 0         0 my @char = ();
584 0 0       0 if ($modifier =~ /x/oxms) {
585 0         0 @char = $pattern =~ /\G((?>
586             [^\\\#\[\(] |
587             \\ $q_char |
588             \# (?>[^\n]*) $ |
589             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
590             \(\? |
591             $q_char
592             ))/oxmsg;
593             }
594              
595             # without /x modifier
596             else {
597 0         0 @char = $pattern =~ /\G((?>
598             [^\\\[\(] |
599             \\ $q_char |
600             \[ (?>(?:[^\\\]]|\\\\|\\\]|$q_char)+) \] |
601             \(\? |
602             $q_char
603             ))/oxmsg;
604             }
605              
606 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
607             }
608              
609             #
610             # TIS-620 transliteration (tr///)
611             #
612             sub Etis620::tr($$$$;$) {
613              
614 0     0 0 0 my $bind_operator = $_[1];
615 0         0 my $searchlist = $_[2];
616 0         0 my $replacementlist = $_[3];
617 0   0     0 my $modifier = $_[4] || '';
618              
619 0 0       0 if ($modifier =~ /r/oxms) {
620 0 0       0 if ($bind_operator =~ / !~ /oxms) {
621 0         0 croak "Using !~ with tr///r doesn't make sense";
622             }
623             }
624              
625 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
626 0         0 my @searchlist = _charlist_tr($searchlist);
627 0         0 my @replacementlist = _charlist_tr($replacementlist);
628              
629 0         0 my %tr = ();
630 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
631 0 0       0 if (not exists $tr{$searchlist[$i]}) {
632 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
633 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
634             }
635             elsif ($modifier =~ /d/oxms) {
636 0         0 $tr{$searchlist[$i]} = '';
637             }
638             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
639 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
640             }
641             else {
642 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
643             }
644             }
645             }
646              
647 0         0 my $tr = 0;
648 0         0 my $replaced = '';
649 0 0       0 if ($modifier =~ /c/oxms) {
650 0         0 while (defined(my $char = shift @char)) {
651 0 0       0 if (not exists $tr{$char}) {
652 0 0       0 if (defined $replacementlist[0]) {
653 0         0 $replaced .= $replacementlist[0];
654             }
655 0         0 $tr++;
656 0 0       0 if ($modifier =~ /s/oxms) {
657 0   0     0 while (@char and (not exists $tr{$char[0]})) {
658 0         0 shift @char;
659 0         0 $tr++;
660             }
661             }
662             }
663             else {
664 0         0 $replaced .= $char;
665             }
666             }
667             }
668             else {
669 0         0 while (defined(my $char = shift @char)) {
670 0 0       0 if (exists $tr{$char}) {
671 0         0 $replaced .= $tr{$char};
672 0         0 $tr++;
673 0 0       0 if ($modifier =~ /s/oxms) {
674 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
675 0         0 shift @char;
676 0         0 $tr++;
677             }
678             }
679             }
680             else {
681 0         0 $replaced .= $char;
682             }
683             }
684             }
685              
686 0 0       0 if ($modifier =~ /r/oxms) {
687 0         0 return $replaced;
688             }
689             else {
690 0         0 $_[0] = $replaced;
691 0 0       0 if ($bind_operator =~ / !~ /oxms) {
692 0         0 return not $tr;
693             }
694             else {
695 0         0 return $tr;
696             }
697             }
698             }
699              
700             #
701             # TIS-620 chop
702             #
703             sub Etis620::chop(@) {
704              
705 0     0 0 0 my $chop;
706 0 0       0 if (@_ == 0) {
707 0         0 my @char = /\G (?>$q_char) /oxmsg;
708 0         0 $chop = pop @char;
709 0         0 $_ = join '', @char;
710             }
711             else {
712 0         0 for (@_) {
713 0         0 my @char = /\G (?>$q_char) /oxmsg;
714 0         0 $chop = pop @char;
715 0         0 $_ = join '', @char;
716             }
717             }
718 0         0 return $chop;
719             }
720              
721             #
722             # TIS-620 index by octet
723             #
724             sub Etis620::index($$;$) {
725              
726 0     0 1 0 my($str,$substr,$position) = @_;
727 0   0     0 $position ||= 0;
728 0         0 my $pos = 0;
729              
730 0         0 while ($pos < CORE::length($str)) {
731 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
732 0 0       0 if ($pos >= $position) {
733 0         0 return $pos;
734             }
735             }
736 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
737 0         0 $pos += CORE::length($1);
738             }
739             else {
740 0         0 $pos += 1;
741             }
742             }
743 0         0 return -1;
744             }
745              
746             #
747             # TIS-620 reverse index
748             #
749             sub Etis620::rindex($$;$) {
750              
751 0     0 0 0 my($str,$substr,$position) = @_;
752 0   0     0 $position ||= CORE::length($str) - 1;
753 0         0 my $pos = 0;
754 0         0 my $rindex = -1;
755              
756 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
757 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
758 0         0 $rindex = $pos;
759             }
760 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
761 0         0 $pos += CORE::length($1);
762             }
763             else {
764 0         0 $pos += 1;
765             }
766             }
767 0         0 return $rindex;
768             }
769              
770             #
771             # TIS-620 lower case first with parameter
772             #
773             sub Etis620::lcfirst(@) {
774 0 0   0 0 0 if (@_) {
775 0         0 my $s = shift @_;
776 0 0 0     0 if (@_ and wantarray) {
777 0         0 return Etis620::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
778             }
779             else {
780 0         0 return Etis620::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
781             }
782             }
783             else {
784 0         0 return Etis620::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
785             }
786             }
787              
788             #
789             # TIS-620 lower case first without parameter
790             #
791             sub Etis620::lcfirst_() {
792 0     0 0 0 return Etis620::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
793             }
794              
795             #
796             # TIS-620 lower case with parameter
797             #
798             sub Etis620::lc(@) {
799 0 0   0 0 0 if (@_) {
800 0         0 my $s = shift @_;
801 0 0 0     0 if (@_ and wantarray) {
802 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
803             }
804             else {
805 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
806             }
807             }
808             else {
809 0         0 return Etis620::lc_();
810             }
811             }
812              
813             #
814             # TIS-620 lower case without parameter
815             #
816             sub Etis620::lc_() {
817 0     0 0 0 my $s = $_;
818 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
819             }
820              
821             #
822             # TIS-620 upper case first with parameter
823             #
824             sub Etis620::ucfirst(@) {
825 0 0   0 0 0 if (@_) {
826 0         0 my $s = shift @_;
827 0 0 0     0 if (@_ and wantarray) {
828 0         0 return Etis620::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
829             }
830             else {
831 0         0 return Etis620::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
832             }
833             }
834             else {
835 0         0 return Etis620::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
836             }
837             }
838              
839             #
840             # TIS-620 upper case first without parameter
841             #
842             sub Etis620::ucfirst_() {
843 0     0 0 0 return Etis620::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
844             }
845              
846             #
847             # TIS-620 upper case with parameter
848             #
849             sub Etis620::uc(@) {
850 0 50   114 0 0 if (@_) {
851 114         195 my $s = shift @_;
852 114 50 33     150 if (@_ and wantarray) {
853 114 0       1293 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
854             }
855             else {
856 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  114         611  
857             }
858             }
859             else {
860 114         509 return Etis620::uc_();
861             }
862             }
863              
864             #
865             # TIS-620 upper case without parameter
866             #
867             sub Etis620::uc_() {
868 0     0 0 0 my $s = $_;
869 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
870             }
871              
872             #
873             # TIS-620 fold case with parameter
874             #
875             sub Etis620::fc(@) {
876 0 50   137 0 0 if (@_) {
877 137         211 my $s = shift @_;
878 137 50 33     153 if (@_ and wantarray) {
879 137 0       236 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
880             }
881             else {
882 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  137         368  
883             }
884             }
885             else {
886 137         1253 return Etis620::fc_();
887             }
888             }
889              
890             #
891             # TIS-620 fold case without parameter
892             #
893             sub Etis620::fc_() {
894 0     0 0 0 my $s = $_;
895 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
896             }
897              
898             #
899             # TIS-620 regexp capture
900             #
901             {
902             sub Etis620::capture {
903 0     0 1 0 return $_[0];
904             }
905             }
906              
907             #
908             # TIS-620 regexp ignore case modifier
909             #
910             sub Etis620::ignorecase {
911              
912 0     0 0 0 my @string = @_;
913 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
914              
915             # ignore case of $scalar or @array
916 0         0 for my $string (@string) {
917              
918             # split regexp
919 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
920              
921             # unescape character
922 0         0 for (my $i=0; $i <= $#char; $i++) {
923 0 0       0 next if not defined $char[$i];
924              
925             # open character class [...]
926 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
927 0         0 my $left = $i;
928              
929             # [] make die "unmatched [] in regexp ...\n"
930              
931 0 0       0 if ($char[$i+1] eq ']') {
932 0         0 $i++;
933             }
934              
935 0         0 while (1) {
936 0 0       0 if (++$i > $#char) {
937 0         0 croak "Unmatched [] in regexp";
938             }
939 0 0       0 if ($char[$i] eq ']') {
940 0         0 my $right = $i;
941 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
942              
943             # escape character
944 0         0 for my $char (@charlist) {
945 0 0       0 if (0) {
946             }
947              
948 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
949 0         0 $char = '\\' . $char;
950             }
951             }
952              
953             # [...]
954 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
955              
956 0         0 $i = $left;
957 0         0 last;
958             }
959             }
960             }
961              
962             # open character class [^...]
963             elsif ($char[$i] eq '[^') {
964 0         0 my $left = $i;
965              
966             # [^] make die "unmatched [] in regexp ...\n"
967              
968 0 0       0 if ($char[$i+1] eq ']') {
969 0         0 $i++;
970             }
971              
972 0         0 while (1) {
973 0 0       0 if (++$i > $#char) {
974 0         0 croak "Unmatched [] in regexp";
975             }
976 0 0       0 if ($char[$i] eq ']') {
977 0         0 my $right = $i;
978 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
979              
980             # escape character
981 0         0 for my $char (@charlist) {
982 0 0       0 if (0) {
983             }
984              
985 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
986 0         0 $char = '\\' . $char;
987             }
988             }
989              
990             # [^...]
991 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
992              
993 0         0 $i = $left;
994 0         0 last;
995             }
996             }
997             }
998              
999             # rewrite classic character class or escape character
1000             elsif (my $char = classic_character_class($char[$i])) {
1001 0         0 $char[$i] = $char;
1002             }
1003              
1004             # with /i modifier
1005             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1006 0         0 my $uc = Etis620::uc($char[$i]);
1007 0         0 my $fc = Etis620::fc($char[$i]);
1008 0 0       0 if ($uc ne $fc) {
1009 0 0       0 if (CORE::length($fc) == 1) {
1010 0         0 $char[$i] = '[' . $uc . $fc . ']';
1011             }
1012             else {
1013 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1014             }
1015             }
1016             }
1017             }
1018              
1019             # characterize
1020 0         0 for (my $i=0; $i <= $#char; $i++) {
1021 0 0       0 next if not defined $char[$i];
1022              
1023 0 0       0 if (0) {
1024             }
1025              
1026             # quote character before ? + * {
1027 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1028 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1029 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1030             }
1031             }
1032             }
1033              
1034 0         0 $string = join '', @char;
1035             }
1036              
1037             # make regexp string
1038 0         0 return @string;
1039             }
1040              
1041             #
1042             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1043             #
1044             sub Etis620::classic_character_class {
1045 0     1827 0 0 my($char) = @_;
1046              
1047             return {
1048             '\D' => '${Etis620::eD}',
1049             '\S' => '${Etis620::eS}',
1050             '\W' => '${Etis620::eW}',
1051             '\d' => '[0-9]',
1052              
1053             # Before Perl 5.6, \s only matched the five whitespace characters
1054             # tab, newline, form-feed, carriage return, and the space character
1055             # itself, which, taken together, is the character class [\t\n\f\r ].
1056              
1057             # Vertical tabs are now whitespace
1058             # \s in a regex now matches a vertical tab in all circumstances.
1059             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1060             # \t \n \v \f \r space
1061             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1062             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1063             '\s' => '\s',
1064              
1065             '\w' => '[0-9A-Z_a-z]',
1066             '\C' => '[\x00-\xFF]',
1067             '\X' => 'X',
1068              
1069             # \h \v \H \V
1070              
1071             # P.114 Character Class Shortcuts
1072             # in Chapter 7: In the World of Regular Expressions
1073             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1074              
1075             # P.357 13.2.3 Whitespace
1076             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1077             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1078             #
1079             # 0x00009 CHARACTER TABULATION h s
1080             # 0x0000a LINE FEED (LF) vs
1081             # 0x0000b LINE TABULATION v
1082             # 0x0000c FORM FEED (FF) vs
1083             # 0x0000d CARRIAGE RETURN (CR) vs
1084             # 0x00020 SPACE h s
1085              
1086             # P.196 Table 5-9. Alphanumeric regex metasymbols
1087             # in Chapter 5. Pattern Matching
1088             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1089              
1090             # (and so on)
1091              
1092             '\H' => '${Etis620::eH}',
1093             '\V' => '${Etis620::eV}',
1094             '\h' => '[\x09\x20]',
1095             '\v' => '[\x0A\x0B\x0C\x0D]',
1096             '\R' => '${Etis620::eR}',
1097              
1098             # \N
1099             #
1100             # http://perldoc.perl.org/perlre.html
1101             # Character Classes and other Special Escapes
1102             # Any character but \n (experimental). Not affected by /s modifier
1103              
1104             '\N' => '${Etis620::eN}',
1105              
1106             # \b \B
1107              
1108             # P.180 Boundaries: The \b and \B Assertions
1109             # in Chapter 5: Pattern Matching
1110             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1111              
1112             # P.219 Boundaries: The \b and \B Assertions
1113             # in Chapter 5: Pattern Matching
1114             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1115              
1116             # \b really means (?:(?<=\w)(?!\w)|(?
1117             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1118             '\b' => '${Etis620::eb}',
1119              
1120             # \B really means (?:(?<=\w)(?=\w)|(?
1121             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1122             '\B' => '${Etis620::eB}',
1123              
1124 1827   100     2498 }->{$char} || '';
1125             }
1126              
1127             #
1128             # prepare TIS-620 characters per length
1129             #
1130              
1131             # 1 octet characters
1132             my @chars1 = ();
1133             sub chars1 {
1134 1827 0   0 0 66924 if (@chars1) {
1135 0         0 return @chars1;
1136             }
1137 0 0       0 if (exists $range_tr{1}) {
1138 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1139 0         0 while (my @range = splice(@ranges,0,1)) {
1140 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1141 0         0 push @chars1, pack 'C', $oct0;
1142             }
1143             }
1144             }
1145 0         0 return @chars1;
1146             }
1147              
1148             # 2 octets characters
1149             my @chars2 = ();
1150             sub chars2 {
1151 0 0   0 0 0 if (@chars2) {
1152 0         0 return @chars2;
1153             }
1154 0 0       0 if (exists $range_tr{2}) {
1155 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1156 0         0 while (my @range = splice(@ranges,0,2)) {
1157 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1158 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1159 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1160             }
1161             }
1162             }
1163             }
1164 0         0 return @chars2;
1165             }
1166              
1167             # 3 octets characters
1168             my @chars3 = ();
1169             sub chars3 {
1170 0 0   0 0 0 if (@chars3) {
1171 0         0 return @chars3;
1172             }
1173 0 0       0 if (exists $range_tr{3}) {
1174 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1175 0         0 while (my @range = splice(@ranges,0,3)) {
1176 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1177 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1178 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1179 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1180             }
1181             }
1182             }
1183             }
1184             }
1185 0         0 return @chars3;
1186             }
1187              
1188             # 4 octets characters
1189             my @chars4 = ();
1190             sub chars4 {
1191 0 0   0 0 0 if (@chars4) {
1192 0         0 return @chars4;
1193             }
1194 0 0       0 if (exists $range_tr{4}) {
1195 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1196 0         0 while (my @range = splice(@ranges,0,4)) {
1197 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1198 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1199 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1200 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1201 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1202             }
1203             }
1204             }
1205             }
1206             }
1207             }
1208 0         0 return @chars4;
1209             }
1210              
1211             #
1212             # TIS-620 open character list for tr
1213             #
1214             sub _charlist_tr {
1215              
1216 0     0   0 local $_ = shift @_;
1217              
1218             # unescape character
1219 0         0 my @char = ();
1220 0         0 while (not /\G \z/oxmsgc) {
1221 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1222 0         0 push @char, '\-';
1223             }
1224             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1225 0         0 push @char, CORE::chr(oct $1);
1226             }
1227             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1228 0         0 push @char, CORE::chr(hex $1);
1229             }
1230             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1231 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1232             }
1233             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1234             push @char, {
1235             '\0' => "\0",
1236             '\n' => "\n",
1237             '\r' => "\r",
1238             '\t' => "\t",
1239             '\f' => "\f",
1240             '\b' => "\x08", # \b means backspace in character class
1241             '\a' => "\a",
1242             '\e' => "\e",
1243 0         0 }->{$1};
1244             }
1245             elsif (/\G \\ ($q_char) /oxmsgc) {
1246 0         0 push @char, $1;
1247             }
1248             elsif (/\G ($q_char) /oxmsgc) {
1249 0         0 push @char, $1;
1250             }
1251             }
1252              
1253             # join separated multiple-octet
1254 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1255              
1256             # unescape '-'
1257 0         0 my @i = ();
1258 0         0 for my $i (0 .. $#char) {
1259 0 0       0 if ($char[$i] eq '\-') {
    0          
1260 0         0 $char[$i] = '-';
1261             }
1262             elsif ($char[$i] eq '-') {
1263 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1264 0         0 push @i, $i;
1265             }
1266             }
1267             }
1268              
1269             # open character list (reverse for splice)
1270 0         0 for my $i (CORE::reverse @i) {
1271 0         0 my @range = ();
1272              
1273             # range error
1274 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1275 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1276             }
1277              
1278             # range of multiple-octet code
1279 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1280 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1281 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1282             }
1283             elsif (CORE::length($char[$i+1]) == 2) {
1284 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1285 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1286             }
1287             elsif (CORE::length($char[$i+1]) == 3) {
1288 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1289 0         0 push @range, chars2();
1290 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1291             }
1292             elsif (CORE::length($char[$i+1]) == 4) {
1293 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1294 0         0 push @range, chars2();
1295 0         0 push @range, chars3();
1296 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1297             }
1298             else {
1299 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1300             }
1301             }
1302             elsif (CORE::length($char[$i-1]) == 2) {
1303 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1304 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1305             }
1306             elsif (CORE::length($char[$i+1]) == 3) {
1307 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1308 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1309             }
1310             elsif (CORE::length($char[$i+1]) == 4) {
1311 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1312 0         0 push @range, chars3();
1313 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1314             }
1315             else {
1316 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1317             }
1318             }
1319             elsif (CORE::length($char[$i-1]) == 3) {
1320 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1321 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1322             }
1323             elsif (CORE::length($char[$i+1]) == 4) {
1324 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1325 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1326             }
1327             else {
1328 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1329             }
1330             }
1331             elsif (CORE::length($char[$i-1]) == 4) {
1332 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1333 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1334             }
1335             else {
1336 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1337             }
1338             }
1339             else {
1340 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1341             }
1342              
1343 0         0 splice @char, $i-1, 3, @range;
1344             }
1345              
1346 0         0 return @char;
1347             }
1348              
1349             #
1350             # TIS-620 open character class
1351             #
1352             sub _cc {
1353 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1354 0         0 die __FILE__, ": subroutine cc got no parameter.\n";
1355             }
1356             elsif (scalar(@_) == 1) {
1357 0         0 return sprintf('\x%02X',$_[0]);
1358             }
1359             elsif (scalar(@_) == 2) {
1360 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1361 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1362             }
1363             elsif ($_[0] == $_[1]) {
1364 0         0 return sprintf('\x%02X',$_[0]);
1365             }
1366             elsif (($_[0]+1) == $_[1]) {
1367 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1368             }
1369             else {
1370 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1371             }
1372             }
1373             else {
1374 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1375             }
1376             }
1377              
1378             #
1379             # TIS-620 octet range
1380             #
1381             sub _octets {
1382 0     182   0 my $length = shift @_;
1383              
1384 182 50       329 if ($length == 1) {
1385 182         419 my($a1) = unpack 'C', $_[0];
1386 182         514 my($z1) = unpack 'C', $_[1];
1387              
1388 182 50       334 if ($a1 > $z1) {
1389 182         475 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1390             }
1391              
1392 0 50       0 if ($a1 == $z1) {
    50          
1393 182         424 return sprintf('\x%02X',$a1);
1394             }
1395             elsif (($a1+1) == $z1) {
1396 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1397             }
1398             else {
1399 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1400             }
1401             }
1402             else {
1403 182         1236 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1404             }
1405             }
1406              
1407             #
1408             # TIS-620 range regexp
1409             #
1410             sub _range_regexp {
1411 0     182   0 my($length,$first,$last) = @_;
1412              
1413 182         410 my @range_regexp = ();
1414 182 50       242 if (not exists $range_tr{$length}) {
1415 182         455 return @range_regexp;
1416             }
1417              
1418 0         0 my @ranges = @{ $range_tr{$length} };
  182         271  
1419 182         437 while (my @range = splice(@ranges,0,$length)) {
1420 182         568 my $min = '';
1421 182         281 my $max = '';
1422 182         237 for (my $i=0; $i < $length; $i++) {
1423 182         478 $min .= pack 'C', $range[$i][0];
1424 182         686 $max .= pack 'C', $range[$i][-1];
1425             }
1426              
1427             # min___max
1428             # FIRST_____________LAST
1429             # (nothing)
1430              
1431 182 50 33     479 if ($max lt $first) {
    50 33        
    50 33        
    50 33        
    50 33        
    0 0        
    0 0        
1432             }
1433              
1434             # **********
1435             # min_________max
1436             # FIRST_____________LAST
1437             # **********
1438              
1439             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1440 182         1803 push @range_regexp, _octets($length,$first,$max,$min,$max);
1441             }
1442              
1443             # **********************
1444             # min________________max
1445             # FIRST_____________LAST
1446             # **********************
1447              
1448             elsif (($min eq $first) and ($max eq $last)) {
1449 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1450             }
1451              
1452             # *********
1453             # min___max
1454             # FIRST_____________LAST
1455             # *********
1456              
1457             elsif (($first le $min) and ($max le $last)) {
1458 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1459             }
1460              
1461             # **********************
1462             # min__________________________max
1463             # FIRST_____________LAST
1464             # **********************
1465              
1466             elsif (($min le $first) and ($last le $max)) {
1467 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1468             }
1469              
1470             # *********
1471             # min________max
1472             # FIRST_____________LAST
1473             # *********
1474              
1475             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1476 182         482 push @range_regexp, _octets($length,$min,$last,$min,$max);
1477             }
1478              
1479             # min___max
1480             # FIRST_____________LAST
1481             # (nothing)
1482              
1483             elsif ($last lt $min) {
1484             }
1485              
1486             else {
1487 0         0 die __FILE__, ": subroutine _range_regexp panic.\n";
1488             }
1489             }
1490              
1491 0         0 return @range_regexp;
1492             }
1493              
1494             #
1495             # TIS-620 open character list for qr and not qr
1496             #
1497             sub _charlist {
1498              
1499 182     346   408 my $modifier = pop @_;
1500 346         580 my @char = @_;
1501              
1502 346 100       824 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1503              
1504             # unescape character
1505 346         838 for (my $i=0; $i <= $#char; $i++) {
1506              
1507             # escape - to ...
1508 346 100 100     1111 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1509 1101 100 100     7942 if ((0 < $i) and ($i < $#char)) {
1510 206         856 $char[$i] = '...';
1511             }
1512             }
1513              
1514             # octal escape sequence
1515             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1516 182         395 $char[$i] = octchr($1);
1517             }
1518              
1519             # hexadecimal escape sequence
1520             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1521 0         0 $char[$i] = hexchr($1);
1522             }
1523              
1524             # \b{...} --> b\{...}
1525             # \B{...} --> B\{...}
1526             # \N{CHARNAME} --> N\{CHARNAME}
1527             # \p{PROPERTY} --> p\{PROPERTY}
1528             # \P{PROPERTY} --> P\{PROPERTY}
1529             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1530 0         0 $char[$i] = $1 . '\\' . $2;
1531             }
1532              
1533             # \p, \P, \X --> p, P, X
1534             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1535 0         0 $char[$i] = $1;
1536             }
1537              
1538             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1539 0         0 $char[$i] = CORE::chr oct $1;
1540             }
1541             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1542 0         0 $char[$i] = CORE::chr hex $1;
1543             }
1544             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1545 22         124 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1546             }
1547             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1548             $char[$i] = {
1549             '\0' => "\0",
1550             '\n' => "\n",
1551             '\r' => "\r",
1552             '\t' => "\t",
1553             '\f' => "\f",
1554             '\b' => "\x08", # \b means backspace in character class
1555             '\a' => "\a",
1556             '\e' => "\e",
1557             '\d' => '[0-9]',
1558              
1559             # Vertical tabs are now whitespace
1560             # \s in a regex now matches a vertical tab in all circumstances.
1561             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1562             # \t \n \v \f \r space
1563             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1564             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1565             '\s' => '\s',
1566              
1567             '\w' => '[0-9A-Z_a-z]',
1568             '\D' => '${Etis620::eD}',
1569             '\S' => '${Etis620::eS}',
1570             '\W' => '${Etis620::eW}',
1571              
1572             '\H' => '${Etis620::eH}',
1573             '\V' => '${Etis620::eV}',
1574             '\h' => '[\x09\x20]',
1575             '\v' => '[\x0A\x0B\x0C\x0D]',
1576             '\R' => '${Etis620::eR}',
1577              
1578 0         0 }->{$1};
1579             }
1580              
1581             # POSIX-style character classes
1582             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1583             $char[$i] = {
1584              
1585             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1586             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1587             '[:^lower:]' => '${Etis620::not_lower_i}',
1588             '[:^upper:]' => '${Etis620::not_upper_i}',
1589              
1590 25         554 }->{$1};
1591             }
1592             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1593             $char[$i] = {
1594              
1595             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1596             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1597             '[:ascii:]' => '[\x00-\x7F]',
1598             '[:blank:]' => '[\x09\x20]',
1599             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1600             '[:digit:]' => '[\x30-\x39]',
1601             '[:graph:]' => '[\x21-\x7F]',
1602             '[:lower:]' => '[\x61-\x7A]',
1603             '[:print:]' => '[\x20-\x7F]',
1604             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1605              
1606             # P.174 POSIX-Style Character Classes
1607             # in Chapter 5: Pattern Matching
1608             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1609              
1610             # P.311 11.2.4 Character Classes and other Special Escapes
1611             # in Chapter 11: perlre: Perl regular expressions
1612             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1613              
1614             # P.210 POSIX-Style Character Classes
1615             # in Chapter 5: Pattern Matching
1616             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1617              
1618             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1619              
1620             '[:upper:]' => '[\x41-\x5A]',
1621             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1622             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1623             '[:^alnum:]' => '${Etis620::not_alnum}',
1624             '[:^alpha:]' => '${Etis620::not_alpha}',
1625             '[:^ascii:]' => '${Etis620::not_ascii}',
1626             '[:^blank:]' => '${Etis620::not_blank}',
1627             '[:^cntrl:]' => '${Etis620::not_cntrl}',
1628             '[:^digit:]' => '${Etis620::not_digit}',
1629             '[:^graph:]' => '${Etis620::not_graph}',
1630             '[:^lower:]' => '${Etis620::not_lower}',
1631             '[:^print:]' => '${Etis620::not_print}',
1632             '[:^punct:]' => '${Etis620::not_punct}',
1633             '[:^space:]' => '${Etis620::not_space}',
1634             '[:^upper:]' => '${Etis620::not_upper}',
1635             '[:^word:]' => '${Etis620::not_word}',
1636             '[:^xdigit:]' => '${Etis620::not_xdigit}',
1637              
1638 8         58 }->{$1};
1639             }
1640             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1641 70         1460 $char[$i] = $1;
1642             }
1643             }
1644              
1645             # open character list
1646 7         33 my @singleoctet = ();
1647 346         649 my @multipleoctet = ();
1648 346         540 for (my $i=0; $i <= $#char; ) {
1649              
1650             # escaped -
1651 346 100 100     988 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
1652 919         3789 $i += 1;
1653 182         240 next;
1654             }
1655              
1656             # make range regexp
1657             elsif ($char[$i] eq '...') {
1658              
1659             # range error
1660 182 50       346 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    50          
1661 182         784 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1662             }
1663             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1664 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
1665 182         456 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1666             }
1667             }
1668              
1669             # make range regexp per length
1670 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1671 182         528 my @regexp = ();
1672              
1673             # is first and last
1674 182 50 33     252 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1675 182         641 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1676             }
1677              
1678             # is first
1679             elsif ($length == CORE::length($char[$i-1])) {
1680 182         560 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1681             }
1682              
1683             # is inside in first and last
1684             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1685 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1686             }
1687              
1688             # is last
1689             elsif ($length == CORE::length($char[$i+1])) {
1690 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1691             }
1692              
1693             else {
1694 0         0 die __FILE__, ": subroutine make_regexp panic.\n";
1695             }
1696              
1697 0 50       0 if ($length == 1) {
1698 182         339 push @singleoctet, @regexp;
1699             }
1700             else {
1701 182         462 push @multipleoctet, @regexp;
1702             }
1703             }
1704              
1705 0         0 $i += 2;
1706             }
1707              
1708             # with /i modifier
1709             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1710 182 50       377 if ($modifier =~ /i/oxms) {
1711 469         705 my $uc = Etis620::uc($char[$i]);
1712 0         0 my $fc = Etis620::fc($char[$i]);
1713 0 0       0 if ($uc ne $fc) {
1714 0 0       0 if (CORE::length($fc) == 1) {
1715 0         0 push @singleoctet, $uc, $fc;
1716             }
1717             else {
1718 0         0 push @singleoctet, $uc;
1719 0         0 push @multipleoctet, $fc;
1720             }
1721             }
1722             else {
1723 0         0 push @singleoctet, $char[$i];
1724             }
1725             }
1726             else {
1727 0         0 push @singleoctet, $char[$i];
1728             }
1729 469         673 $i += 1;
1730             }
1731              
1732             # single character of single octet code
1733             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1734 469         898 push @singleoctet, "\t", "\x20";
1735 0         0 $i += 1;
1736             }
1737             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1738 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1739 0         0 $i += 1;
1740             }
1741             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1742 0         0 push @singleoctet, $char[$i];
1743 2         4 $i += 1;
1744             }
1745              
1746             # single character of multiple-octet code
1747             else {
1748 2         6 push @multipleoctet, $char[$i];
1749 84         160 $i += 1;
1750             }
1751             }
1752              
1753             # quote metachar
1754 84         218 for (@singleoctet) {
1755 346 50       1835 if ($_ eq '...') {
    100          
    100          
    100          
    100          
1756 653         3841 $_ = '-';
1757             }
1758             elsif (/\A \n \z/oxms) {
1759 0         0 $_ = '\n';
1760             }
1761             elsif (/\A \r \z/oxms) {
1762 8         22 $_ = '\r';
1763             }
1764             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1765 8         18 $_ = sprintf('\x%02X', CORE::ord $1);
1766             }
1767             elsif (/\A [\x00-\xFF] \z/oxms) {
1768 24         92 $_ = quotemeta $_;
1769             }
1770             }
1771              
1772             # return character list
1773 429         3086 return \@singleoctet, \@multipleoctet;
1774             }
1775              
1776             #
1777             # TIS-620 octal escape sequence
1778             #
1779             sub octchr {
1780 346     5 0 1177 my($octdigit) = @_;
1781              
1782 5         14 my @binary = ();
1783 5         7 for my $octal (split(//,$octdigit)) {
1784             push @binary, {
1785             '0' => '000',
1786             '1' => '001',
1787             '2' => '010',
1788             '3' => '011',
1789             '4' => '100',
1790             '5' => '101',
1791             '6' => '110',
1792             '7' => '111',
1793 5         21 }->{$octal};
1794             }
1795 50         179 my $binary = join '', @binary;
1796              
1797             my $octchr = {
1798             # 1234567
1799             1 => pack('B*', "0000000$binary"),
1800             2 => pack('B*', "000000$binary"),
1801             3 => pack('B*', "00000$binary"),
1802             4 => pack('B*', "0000$binary"),
1803             5 => pack('B*', "000$binary"),
1804             6 => pack('B*', "00$binary"),
1805             7 => pack('B*', "0$binary"),
1806             0 => pack('B*', "$binary"),
1807              
1808 5         13 }->{CORE::length($binary) % 8};
1809              
1810 5         60 return $octchr;
1811             }
1812              
1813             #
1814             # TIS-620 hexadecimal escape sequence
1815             #
1816             sub hexchr {
1817 5     5 0 18 my($hexdigit) = @_;
1818              
1819             my $hexchr = {
1820             1 => pack('H*', "0$hexdigit"),
1821             0 => pack('H*', "$hexdigit"),
1822              
1823 5         17 }->{CORE::length($_[0]) % 2};
1824              
1825 5         53 return $hexchr;
1826             }
1827              
1828             #
1829             # TIS-620 open character list for qr
1830             #
1831             sub charlist_qr {
1832              
1833 5     302 0 19 my $modifier = pop @_;
1834 302         811 my @char = @_;
1835              
1836 302         744 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1837 302         911 my @singleoctet = @$singleoctet;
1838 302         615 my @multipleoctet = @$multipleoctet;
1839              
1840             # return character list
1841 302 100       464 if (scalar(@singleoctet) >= 1) {
1842              
1843             # with /i modifier
1844 302 100       651 if ($modifier =~ m/i/oxms) {
1845 224         486 my %singleoctet_ignorecase = ();
1846 10         21 for (@singleoctet) {
1847 10   66     24 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1848 10         75 for my $ord (hex($1) .. hex($2)) {
1849 10         953 my $char = CORE::chr($ord);
1850 30         58 my $uc = Etis620::uc($char);
1851 30         57 my $fc = Etis620::fc($char);
1852 30 50       63 if ($uc eq $fc) {
1853 30         1152 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1854             }
1855             else {
1856 0 50       0 if (CORE::length($fc) == 1) {
1857 30         62 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1858 30         2247 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1859             }
1860             else {
1861 30         118 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1862 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1863             }
1864             }
1865             }
1866             }
1867 0 50       0 if ($_ ne '') {
1868 10         40 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1869             }
1870             }
1871 0         0 my $i = 0;
1872 10         19 my @singleoctet_ignorecase = ();
1873 10         17 for my $ord (0 .. 255) {
1874 10 100       27 if (exists $singleoctet_ignorecase{$ord}) {
1875 2560         5120 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         59  
1876             }
1877             else {
1878 60         1182 $i++;
1879             }
1880             }
1881 2500         4718 @singleoctet = ();
1882 10         22 for my $range (@singleoctet_ignorecase) {
1883 10 100       40 if (ref $range) {
1884 960 50       1481 if (scalar(@{$range}) == 1) {
  20 50       26  
1885 20         207 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1886             }
1887 0         0 elsif (scalar(@{$range}) == 2) {
1888 20         36 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1889             }
1890             else {
1891 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         27  
  20         25  
1892             }
1893             }
1894             }
1895             }
1896              
1897 20         128 my $not_anchor = '';
1898              
1899 224         361 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1900             }
1901 224 100       636 if (scalar(@multipleoctet) >= 2) {
1902 302         659 return '(?:' . join('|', @multipleoctet) . ')';
1903             }
1904             else {
1905 6         33 return $multipleoctet[0];
1906             }
1907             }
1908              
1909             #
1910             # TIS-620 open character list for not qr
1911             #
1912             sub charlist_not_qr {
1913              
1914 296     44 0 1229 my $modifier = pop @_;
1915 44         86 my @char = @_;
1916              
1917 44         159 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1918 44         171 my @singleoctet = @$singleoctet;
1919 44         136 my @multipleoctet = @$multipleoctet;
1920              
1921             # with /i modifier
1922 44 100       72 if ($modifier =~ m/i/oxms) {
1923 44         124 my %singleoctet_ignorecase = ();
1924 10         16 for (@singleoctet) {
1925 10   66     15 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1926 10         47 for my $ord (hex($1) .. hex($2)) {
1927 10         33 my $char = CORE::chr($ord);
1928 30         96 my $uc = Etis620::uc($char);
1929 30         88 my $fc = Etis620::fc($char);
1930 30 50       49 if ($uc eq $fc) {
1931 30         49 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1932             }
1933             else {
1934 0 50       0 if (CORE::length($fc) == 1) {
1935 30         95 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1936 30         70 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1937             }
1938             else {
1939 30         103 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1940 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1941             }
1942             }
1943             }
1944             }
1945 0 50       0 if ($_ ne '') {
1946 10         35 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1947             }
1948             }
1949 0         0 my $i = 0;
1950 10         15 my @singleoctet_ignorecase = ();
1951 10         14 for my $ord (0 .. 255) {
1952 10 100       15 if (exists $singleoctet_ignorecase{$ord}) {
1953 2560         3160 push @{$singleoctet_ignorecase[$i]}, $ord;
  60         54  
1954             }
1955             else {
1956 60         102 $i++;
1957             }
1958             }
1959 2500         2813 @singleoctet = ();
1960 10         19 for my $range (@singleoctet_ignorecase) {
1961 10 100       28 if (ref $range) {
1962 960 50       2470 if (scalar(@{$range}) == 1) {
  20 50       21  
1963 20         82 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1964             }
1965 0         0 elsif (scalar(@{$range}) == 2) {
1966 20         32 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1967             }
1968             else {
1969 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  20         23  
  20         26  
1970             }
1971             }
1972             }
1973             }
1974              
1975             # return character list
1976 20 50       114 if (scalar(@multipleoctet) >= 1) {
1977 44 0       113 if (scalar(@singleoctet) >= 1) {
1978              
1979             # any character other than multiple-octet and single octet character class
1980 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
1981             }
1982             else {
1983              
1984             # any character other than multiple-octet character class
1985 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
1986             }
1987             }
1988             else {
1989 0 50       0 if (scalar(@singleoctet) >= 1) {
1990              
1991             # any character other than single octet character class
1992 44         85 return '(?:[^' . join('', @singleoctet) . '])';
1993             }
1994             else {
1995              
1996             # any character
1997 44         266 return "(?:$your_char)";
1998             }
1999             }
2000             }
2001              
2002             #
2003             # open file in read mode
2004             #
2005             sub _open_r {
2006 0     408   0 my(undef,$file) = @_;
2007 204     204   2359 use Fcntl qw(O_RDONLY);
  204         488  
  204         32149  
2008 408         2775 return CORE::sysopen($_[0], $file, &O_RDONLY);
2009             }
2010              
2011             #
2012             # open file in append mode
2013             #
2014             sub _open_a {
2015 408     204   28684 my(undef,$file) = @_;
2016 204     204   1517 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  204         454  
  204         608655  
2017 204         656 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2018             }
2019              
2020             #
2021             # safe system
2022             #
2023             sub _systemx {
2024              
2025             # P.707 29.2.33. exec
2026             # in Chapter 29: Functions
2027             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2028             #
2029             # Be aware that in older releases of Perl, exec (and system) did not flush
2030             # your output buffer, so you needed to enable command buffering by setting $|
2031             # on one or more filehandles to avoid lost output in the case of exec, or
2032             # misordererd output in the case of system. This situation was largely remedied
2033             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2034              
2035             # P.855 exec
2036             # in Chapter 27: Functions
2037             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2038             #
2039             # In very old release of Perl (before v5.6), exec (and system) did not flush
2040             # your output buffer, so you needed to enable command buffering by setting $|
2041             # on one or more filehandles to avoid lost output with exec or misordered
2042             # output with system.
2043              
2044 204     204   52689 $| = 1;
2045              
2046             # P.565 23.1.2. Cleaning Up Your Environment
2047             # in Chapter 23: Security
2048             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2049              
2050             # P.656 Cleaning Up Your Environment
2051             # in Chapter 20: Security
2052             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2053              
2054             # local $ENV{'PATH'} = '.';
2055 204         892 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2056              
2057             # P.707 29.2.33. exec
2058             # in Chapter 29: Functions
2059             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2060             #
2061             # As we mentioned earlier, exec treats a discrete list of arguments as an
2062             # indication that it should bypass shell processing. However, there is one
2063             # place where you might still get tripped up. The exec call (and system, too)
2064             # will not distinguish between a single scalar argument and an array containing
2065             # only one element.
2066             #
2067             # @args = ("echo surprise"); # just one element in list
2068             # exec @args # still subject to shell escapes
2069             # or die "exec: $!"; # because @args == 1
2070             #
2071             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2072             # first argument as the pathname, which forces the rest of the arguments to be
2073             # interpreted as a list, even if there is only one of them:
2074             #
2075             # exec { $args[0] } @args # safe even with one-argument list
2076             # or die "can't exec @args: $!";
2077              
2078             # P.855 exec
2079             # in Chapter 27: Functions
2080             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2081             #
2082             # As we mentioned earlier, exec treats a discrete list of arguments as a
2083             # directive to bypass shell processing. However, there is one place where
2084             # you might still get tripped up. The exec call (and system, too) cannot
2085             # distinguish between a single scalar argument and an array containing
2086             # only one element.
2087             #
2088             # @args = ("echo surprise"); # just one element in list
2089             # exec @args # still subject to shell escapes
2090             # || die "exec: $!"; # because @args == 1
2091             #
2092             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2093             # argument as the pathname, which forces the rest of the arguments to be
2094             # interpreted as a list, even if there is only one of them:
2095             #
2096             # exec { $args[0] } @args # safe even with one-argument list
2097             # || die "can't exec @args: $!";
2098              
2099 204         1852 return CORE::system { $_[0] } @_; # safe even with one-argument list
  204         423  
2100             }
2101              
2102             #
2103             # TIS-620 order to character (with parameter)
2104             #
2105             sub Etis620::chr(;$) {
2106              
2107 204 0   0 0 19256593 my $c = @_ ? $_[0] : $_;
2108              
2109 0 0       0 if ($c == 0x00) {
2110 0         0 return "\x00";
2111             }
2112             else {
2113 0         0 my @chr = ();
2114 0         0 while ($c > 0) {
2115 0         0 unshift @chr, ($c % 0x100);
2116 0         0 $c = int($c / 0x100);
2117             }
2118 0         0 return pack 'C*', @chr;
2119             }
2120             }
2121              
2122             #
2123             # TIS-620 order to character (without parameter)
2124             #
2125             sub Etis620::chr_() {
2126              
2127 0     0 0 0 my $c = $_;
2128              
2129 0 0       0 if ($c == 0x00) {
2130 0         0 return "\x00";
2131             }
2132             else {
2133 0         0 my @chr = ();
2134 0         0 while ($c > 0) {
2135 0         0 unshift @chr, ($c % 0x100);
2136 0         0 $c = int($c / 0x100);
2137             }
2138 0         0 return pack 'C*', @chr;
2139             }
2140             }
2141              
2142             #
2143             # TIS-620 path globbing (with parameter)
2144             #
2145             sub Etis620::glob($) {
2146              
2147 0 0   0 0 0 if (wantarray) {
2148 0         0 my @glob = _DOS_like_glob(@_);
2149 0         0 for my $glob (@glob) {
2150 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2151             }
2152 0         0 return @glob;
2153             }
2154             else {
2155 0         0 my $glob = _DOS_like_glob(@_);
2156 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2157 0         0 return $glob;
2158             }
2159             }
2160              
2161             #
2162             # TIS-620 path globbing (without parameter)
2163             #
2164             sub Etis620::glob_() {
2165              
2166 0 0   0 0 0 if (wantarray) {
2167 0         0 my @glob = _DOS_like_glob();
2168 0         0 for my $glob (@glob) {
2169 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2170             }
2171 0         0 return @glob;
2172             }
2173             else {
2174 0         0 my $glob = _DOS_like_glob();
2175 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
2176 0         0 return $glob;
2177             }
2178             }
2179              
2180             #
2181             # TIS-620 path globbing via File::DosGlob 1.10
2182             #
2183             # Often I confuse "_dosglob" and "_doglob".
2184             # So, I renamed "_dosglob" to "_DOS_like_glob".
2185             #
2186             my %iter;
2187             my %entries;
2188             sub _DOS_like_glob {
2189              
2190             # context (keyed by second cxix argument provided by core)
2191 0     0   0 my($expr,$cxix) = @_;
2192              
2193             # glob without args defaults to $_
2194 0 0       0 $expr = $_ if not defined $expr;
2195              
2196             # represents the current user's home directory
2197             #
2198             # 7.3. Expanding Tildes in Filenames
2199             # in Chapter 7. File Access
2200             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2201             #
2202             # and File::HomeDir, File::HomeDir::Windows module
2203              
2204             # DOS-like system
2205 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2206 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
2207             { my_home_MSWin32() }oxmse;
2208             }
2209              
2210             # UNIX-like system
2211 0 0 0     0 else {
  0         0  
2212             $expr =~ s{ \A ~ ( (?:[^/])* ) }
2213             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2214             }
2215 0 0       0  
2216 0 0       0 # assume global context if not provided one
2217             $cxix = '_G_' if not defined $cxix;
2218             $iter{$cxix} = 0 if not exists $iter{$cxix};
2219 0 0       0  
2220 0         0 # if we're just beginning, do it all first
2221             if ($iter{$cxix} == 0) {
2222             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2223             }
2224 0 0       0  
2225 0         0 # chuck it all out, quick or slow
2226 0         0 if (wantarray) {
  0         0  
2227             delete $iter{$cxix};
2228             return @{delete $entries{$cxix}};
2229 0 0       0 }
  0         0  
2230 0         0 else {
  0         0  
2231             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
2232             return shift @{$entries{$cxix}};
2233             }
2234 0         0 else {
2235 0         0 # return undef for EOL
2236 0         0 delete $iter{$cxix};
2237             delete $entries{$cxix};
2238             return undef;
2239             }
2240             }
2241             }
2242              
2243             #
2244             # TIS-620 path globbing subroutine
2245             #
2246 0     0   0 sub _do_glob {
2247 0         0  
2248 0         0 my($cond,@expr) = @_;
2249             my @glob = ();
2250             my $fix_drive_relative_paths = 0;
2251 0         0  
2252 0 0       0 OUTER:
2253 0 0       0 for my $expr (@expr) {
2254             next OUTER if not defined $expr;
2255 0         0 next OUTER if $expr eq '';
2256 0         0  
2257 0         0 my @matched = ();
2258 0         0 my @globdir = ();
2259 0         0 my $head = '.';
2260             my $pathsep = '/';
2261             my $tail;
2262 0 0       0  
2263 0         0 # if argument is within quotes strip em and do no globbing
2264 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
2265 0 0       0 $expr = $1;
2266 0         0 if ($cond eq 'd') {
2267             if (-d $expr) {
2268             push @glob, $expr;
2269             }
2270 0 0       0 }
2271 0         0 else {
2272             if (-e $expr) {
2273             push @glob, $expr;
2274 0         0 }
2275             }
2276             next OUTER;
2277             }
2278              
2279 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
2280 0 0       0 # to h:./*.pm to expand correctly
2281 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2282             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2283             $fix_drive_relative_paths = 1;
2284             }
2285 0 0       0 }
2286 0 0       0  
2287 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
2288 0         0 if ($tail eq '') {
2289             push @glob, $expr;
2290 0 0       0 next OUTER;
2291 0 0       0 }
2292 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
2293 0         0 if (@globdir = _do_glob('d', $head)) {
2294             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
2295             next OUTER;
2296 0 0 0     0 }
2297 0         0 }
2298             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2299 0         0 $head .= $pathsep;
2300             }
2301             $expr = $tail;
2302             }
2303 0 0       0  
2304 0 0       0 # If file component has no wildcards, we can avoid opendir
2305 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2306             if ($head eq '.') {
2307 0 0 0     0 $head = '';
2308 0         0 }
2309             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2310 0         0 $head .= $pathsep;
2311 0 0       0 }
2312 0 0       0 $head .= $expr;
2313 0         0 if ($cond eq 'd') {
2314             if (-d $head) {
2315             push @glob, $head;
2316             }
2317 0 0       0 }
2318 0         0 else {
2319             if (-e $head) {
2320             push @glob, $head;
2321 0         0 }
2322             }
2323 0 0       0 next OUTER;
2324 0         0 }
2325 0         0 opendir(*DIR, $head) or next OUTER;
2326             my @leaf = readdir DIR;
2327 0 0       0 closedir DIR;
2328 0         0  
2329             if ($head eq '.') {
2330 0 0 0     0 $head = '';
2331 0         0 }
2332             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2333             $head .= $pathsep;
2334 0         0 }
2335 0         0  
2336 0         0 my $pattern = '';
2337             while ($expr =~ / \G ($q_char) /oxgc) {
2338             my $char = $1;
2339              
2340             # 6.9. Matching Shell Globs as Regular Expressions
2341             # in Chapter 6. Pattern Matching
2342             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2343 0 0       0 # (and so on)
    0          
    0          
2344 0         0  
2345             if ($char eq '*') {
2346             $pattern .= "(?:$your_char)*",
2347 0         0 }
2348             elsif ($char eq '?') {
2349             $pattern .= "(?:$your_char)?", # DOS style
2350             # $pattern .= "(?:$your_char)", # UNIX style
2351 0         0 }
2352             elsif ((my $fc = Etis620::fc($char)) ne $char) {
2353             $pattern .= $fc;
2354 0         0 }
2355             else {
2356             $pattern .= quotemeta $char;
2357 0     0   0 }
  0         0  
2358             }
2359             my $matchsub = sub { Etis620::fc($_[0]) =~ /\A $pattern \z/xms };
2360              
2361             # if ($@) {
2362             # print STDERR "$0: $@\n";
2363             # next OUTER;
2364             # }
2365 0         0  
2366 0 0 0     0 INNER:
2367 0         0 for my $leaf (@leaf) {
2368             if ($leaf eq '.' or $leaf eq '..') {
2369 0 0 0     0 next INNER;
2370 0         0 }
2371             if ($cond eq 'd' and not -d "$head$leaf") {
2372             next INNER;
2373 0 0       0 }
2374 0         0  
2375 0         0 if (&$matchsub($leaf)) {
2376             push @matched, "$head$leaf";
2377             next INNER;
2378             }
2379              
2380             # [DOS compatibility special case]
2381 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
2382              
2383             if (Etis620::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
2384             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2385 0 0       0 Etis620::index($pattern,'\\.') != -1 # pattern has a dot.
2386 0         0 ) {
2387 0         0 if (&$matchsub("$leaf.")) {
2388             push @matched, "$head$leaf";
2389             next INNER;
2390             }
2391 0 0       0 }
2392 0         0 }
2393             if (@matched) {
2394             push @glob, @matched;
2395 0 0       0 }
2396 0         0 }
2397 0         0 if ($fix_drive_relative_paths) {
2398             for my $glob (@glob) {
2399             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2400 0         0 }
2401             }
2402             return @glob;
2403             }
2404              
2405             #
2406             # TIS-620 parse line
2407             #
2408 0     0   0 sub _parse_line {
2409              
2410 0         0 my($line) = @_;
2411 0         0  
2412 0         0 $line .= ' ';
2413             my @piece = ();
2414             while ($line =~ /
2415             " ( (?>(?: [^"] )* ) ) " (?>\s+) |
2416             ( (?>(?: [^"\s] )* ) ) (?>\s+)
2417 0 0       0 /oxmsg
2418             ) {
2419 0         0 push @piece, defined($1) ? $1 : $2;
2420             }
2421             return @piece;
2422             }
2423              
2424             #
2425             # TIS-620 parse path
2426             #
2427 0     0   0 sub _parse_path {
2428              
2429 0         0 my($path,$pathsep) = @_;
2430 0         0  
2431 0         0 $path .= '/';
2432             my @subpath = ();
2433             while ($path =~ /
2434             ((?: [^\/\\] )+?) [\/\\]
2435 0         0 /oxmsg
2436             ) {
2437             push @subpath, $1;
2438 0         0 }
2439 0         0  
2440 0         0 my $tail = pop @subpath;
2441             my $head = join $pathsep, @subpath;
2442             return $head, $tail;
2443             }
2444              
2445             #
2446             # via File::HomeDir::Windows 1.00
2447             #
2448             sub my_home_MSWin32 {
2449              
2450             # A lot of unix people and unix-derived tools rely on
2451 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
2452 0         0 # so that they can replace raw HOME calls with File::HomeDir.
2453             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
2454             return $ENV{'HOME'};
2455             }
2456              
2457 0         0 # Do we have a user profile?
2458             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2459             return $ENV{'USERPROFILE'};
2460             }
2461              
2462 0         0 # Some Windows use something like $ENV{'HOME'}
2463             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2464             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2465 0         0 }
2466              
2467             return undef;
2468             }
2469              
2470             #
2471             # via File::HomeDir::Unix 1.00
2472 0     0 0 0 #
2473             sub my_home {
2474 0 0 0     0 my $home;
    0 0        
2475 0         0  
2476             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
2477             $home = $ENV{'HOME'};
2478             }
2479              
2480             # This is from the original code, but I'm guessing
2481 0         0 # it means "login directory" and exists on some Unixes.
2482             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2483             $home = $ENV{'LOGDIR'};
2484             }
2485              
2486             ### More-desperate methods
2487              
2488 0         0 # Light desperation on any (Unixish) platform
2489             else {
2490             $home = CORE::eval q{ (getpwuid($<))[7] };
2491             }
2492              
2493 0 0 0     0 # On Unix in general, a non-existant home means "no home"
2494 0         0 # For example, "nobody"-like users might use /nonexistant
2495             if (defined $home and ! -d($home)) {
2496 0         0 $home = undef;
2497             }
2498             return $home;
2499             }
2500              
2501             #
2502             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2503 0     0 0 0 #
2504             sub Etis620::PREMATCH {
2505             return $`;
2506             }
2507              
2508             #
2509             # ${^MATCH}, $MATCH, $& the string that matched
2510 0     0 0 0 #
2511             sub Etis620::MATCH {
2512             return $&;
2513             }
2514              
2515             #
2516             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2517 0     0 0 0 #
2518             sub Etis620::POSTMATCH {
2519             return $';
2520             }
2521              
2522             #
2523             # TIS-620 character to order (with parameter)
2524             #
2525 0 0   0 1 0 sub TIS620::ord(;$) {
2526              
2527 0 0       0 local $_ = shift if @_;
2528 0         0  
2529 0         0 if (/\A ($q_char) /oxms) {
2530 0         0 my @ord = unpack 'C*', $1;
2531 0         0 my $ord = 0;
2532             while (my $o = shift @ord) {
2533 0         0 $ord = $ord * 0x100 + $o;
2534             }
2535             return $ord;
2536 0         0 }
2537             else {
2538             return CORE::ord $_;
2539             }
2540             }
2541              
2542             #
2543             # TIS-620 character to order (without parameter)
2544             #
2545 0 0   0 0 0 sub TIS620::ord_() {
2546 0         0  
2547 0         0 if (/\A ($q_char) /oxms) {
2548 0         0 my @ord = unpack 'C*', $1;
2549 0         0 my $ord = 0;
2550             while (my $o = shift @ord) {
2551 0         0 $ord = $ord * 0x100 + $o;
2552             }
2553             return $ord;
2554 0         0 }
2555             else {
2556             return CORE::ord $_;
2557             }
2558             }
2559              
2560             #
2561             # TIS-620 reverse
2562             #
2563 0 0   0 0 0 sub TIS620::reverse(@) {
2564 0         0  
2565             if (wantarray) {
2566             return CORE::reverse @_;
2567             }
2568             else {
2569              
2570             # One of us once cornered Larry in an elevator and asked him what
2571             # problem he was solving with this, but he looked as far off into
2572             # the distance as he could in an elevator and said, "It seemed like
2573 0         0 # a good idea at the time."
2574              
2575             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2576             }
2577             }
2578              
2579             #
2580             # TIS-620 getc (with parameter, without parameter)
2581             #
2582 0     0 0 0 sub TIS620::getc(;*@) {
2583 0 0       0  
2584 0 0 0     0 my($package) = caller;
2585             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2586 0         0 croak 'Too many arguments for TIS620::getc' if @_ and not wantarray;
  0         0  
2587 0         0  
2588 0         0 my @length = sort { $a <=> $b } keys %range_tr;
2589 0         0 my $getc = '';
2590 0 0       0 for my $length ($length[0] .. $length[-1]) {
2591 0 0       0 $getc .= CORE::getc($fh);
2592 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
2593             if ($getc =~ /\A ${Etis620::dot_s} \z/oxms) {
2594             return wantarray ? ($getc,@_) : $getc;
2595             }
2596 0 0       0 }
2597             }
2598             return wantarray ? ($getc,@_) : $getc;
2599             }
2600              
2601             #
2602             # TIS-620 length by character
2603             #
2604 0 0   0 1 0 sub TIS620::length(;$) {
2605              
2606 0         0 local $_ = shift if @_;
2607 0         0  
2608             local @_ = /\G ($q_char) /oxmsg;
2609             return scalar @_;
2610             }
2611              
2612             #
2613             # TIS-620 substr by character
2614             #
2615             BEGIN {
2616              
2617             # P.232 The lvalue Attribute
2618             # in Chapter 6: Subroutines
2619             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2620              
2621             # P.336 The lvalue Attribute
2622             # in Chapter 7: Subroutines
2623             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2624              
2625             # P.144 8.4 Lvalue subroutines
2626             # in Chapter 8: perlsub: Perl subroutines
2627 204 50 0 204 1 149771 # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
2628              
2629             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
2630             # vv----------------------*******
2631             sub TIS620::substr($$;$$) %s {
2632              
2633             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
2634              
2635             # If the substring is beyond either end of the string, substr() returns the undefined
2636             # value and produces a warning. When used as an lvalue, specifying a substring that
2637             # is entirely outside the string raises an exception.
2638             # http://perldoc.perl.org/functions/substr.html
2639              
2640             # A return with no argument returns the scalar value undef in scalar context,
2641             # an empty list () in list context, and (naturally) nothing at all in void
2642             # context.
2643              
2644             my $offset = $_[1];
2645             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2646             return;
2647             }
2648              
2649             # substr($string,$offset,$length,$replacement)
2650             if (@_ == 4) {
2651             my(undef,undef,$length,$replacement) = @_;
2652             my $substr = join '', splice(@char, $offset, $length, $replacement);
2653             $_[0] = join '', @char;
2654              
2655             # return $substr; this doesn't work, don't say "return"
2656             $substr;
2657             }
2658              
2659             # substr($string,$offset,$length)
2660             elsif (@_ == 3) {
2661             my(undef,undef,$length) = @_;
2662             my $octet_offset = 0;
2663             my $octet_length = 0;
2664             if ($offset == 0) {
2665             $octet_offset = 0;
2666             }
2667             elsif ($offset > 0) {
2668             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2669             }
2670             else {
2671             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2672             }
2673             if ($length == 0) {
2674             $octet_length = 0;
2675             }
2676             elsif ($length > 0) {
2677             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2678             }
2679             else {
2680             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2681             }
2682             CORE::substr($_[0], $octet_offset, $octet_length);
2683             }
2684              
2685             # substr($string,$offset)
2686             else {
2687             my $octet_offset = 0;
2688             if ($offset == 0) {
2689             $octet_offset = 0;
2690             }
2691             elsif ($offset > 0) {
2692             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2693             }
2694             else {
2695             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2696             }
2697             CORE::substr($_[0], $octet_offset);
2698             }
2699             }
2700             END
2701             }
2702              
2703             #
2704             # TIS-620 index by character
2705             #
2706 0     0 1 0 sub TIS620::index($$;$) {
2707 0 0       0  
2708 0         0 my $index;
2709             if (@_ == 3) {
2710             $index = Etis620::index($_[0], $_[1], CORE::length(TIS620::substr($_[0], 0, $_[2])));
2711 0         0 }
2712             else {
2713             $index = Etis620::index($_[0], $_[1]);
2714 0 0       0 }
2715 0         0  
2716             if ($index == -1) {
2717             return -1;
2718 0         0 }
2719             else {
2720             return TIS620::length(CORE::substr $_[0], 0, $index);
2721             }
2722             }
2723              
2724             #
2725             # TIS-620 rindex by character
2726             #
2727 0     0 1 0 sub TIS620::rindex($$;$) {
2728 0 0       0  
2729 0         0 my $rindex;
2730             if (@_ == 3) {
2731             $rindex = Etis620::rindex($_[0], $_[1], CORE::length(TIS620::substr($_[0], 0, $_[2])));
2732 0         0 }
2733             else {
2734             $rindex = Etis620::rindex($_[0], $_[1]);
2735 0 0       0 }
2736 0         0  
2737             if ($rindex == -1) {
2738             return -1;
2739 0         0 }
2740             else {
2741             return TIS620::length(CORE::substr $_[0], 0, $rindex);
2742             }
2743             }
2744              
2745 204     204   1710 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  204         461  
  204         31463  
2746             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
2747             use vars qw($slash); $slash = 'm//';
2748              
2749             # ord() to ord() or TIS620::ord()
2750             my $function_ord = 'ord';
2751              
2752             # ord to ord or TIS620::ord_
2753             my $function_ord_ = 'ord';
2754              
2755             # reverse to reverse or TIS620::reverse
2756             my $function_reverse = 'reverse';
2757              
2758             # getc to getc or TIS620::getc
2759             my $function_getc = 'getc';
2760              
2761             # P.1023 Appendix W.9 Multibyte Anchoring
2762             # of ISBN 1-56592-224-7 CJKV Information Processing
2763              
2764 204     204   1524 my $anchor = '';
  204     0   465  
  204         9632791  
2765              
2766             use vars qw($nest);
2767              
2768             # regexp of nested parens in qqXX
2769              
2770             # P.340 Matching Nested Constructs with Embedded Code
2771             # in Chapter 7: Perl
2772             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2773              
2774             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
2775             [^\\()] |
2776             \( (?{$nest++}) |
2777             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2778             \\ [^c] |
2779             \\c[\x40-\x5F] |
2780             [\x00-\xFF]
2781             }xms;
2782              
2783             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
2784             [^\\{}] |
2785             \{ (?{$nest++}) |
2786             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2787             \\ [^c] |
2788             \\c[\x40-\x5F] |
2789             [\x00-\xFF]
2790             }xms;
2791              
2792             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
2793             [^\\\[\]] |
2794             \[ (?{$nest++}) |
2795             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2796             \\ [^c] |
2797             \\c[\x40-\x5F] |
2798             [\x00-\xFF]
2799             }xms;
2800              
2801             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
2802             [^\\<>] |
2803             \< (?{$nest++}) |
2804             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2805             \\ [^c] |
2806             \\c[\x40-\x5F] |
2807             [\x00-\xFF]
2808             }xms;
2809              
2810             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
2811             (?: ::)? (?:
2812             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2813             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2814             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2815             ))
2816             }xms;
2817              
2818             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
2819             (?: ::)? (?:
2820             (?>[0-9]+) |
2821             [^a-zA-Z_0-9\[\]] |
2822             ^[A-Z] |
2823             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
2824             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
2825             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
2826             ))
2827             }xms;
2828              
2829             my $qq_substr = qr{(?> Char::substr | TIS620::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
2830             }xms;
2831              
2832             # regexp of nested parens in qXX
2833             my $q_paren = qr{(?{local $nest=0}) (?>(?:
2834             [^()] |
2835             \( (?{$nest++}) |
2836             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2837             [\x00-\xFF]
2838             }xms;
2839              
2840             my $q_brace = qr{(?{local $nest=0}) (?>(?:
2841             [^\{\}] |
2842             \{ (?{$nest++}) |
2843             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2844             [\x00-\xFF]
2845             }xms;
2846              
2847             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
2848             [^\[\]] |
2849             \[ (?{$nest++}) |
2850             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2851             [\x00-\xFF]
2852             }xms;
2853              
2854             my $q_angle = qr{(?{local $nest=0}) (?>(?:
2855             [^<>] |
2856             \< (?{$nest++}) |
2857             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
2858             [\x00-\xFF]
2859             }xms;
2860              
2861             my $matched = '';
2862             my $s_matched = '';
2863              
2864             my $tr_variable = ''; # variable of tr///
2865             my $sub_variable = ''; # variable of s///
2866             my $bind_operator = ''; # =~ or !~
2867              
2868             my @heredoc = (); # here document
2869             my @heredoc_delimiter = ();
2870             my $here_script = ''; # here script
2871              
2872             #
2873             # escape TIS-620 script
2874 0 50   204 0 0 #
2875             sub TIS620::escape(;$) {
2876             local($_) = $_[0] if @_;
2877              
2878             # P.359 The Study Function
2879             # in Chapter 7: Perl
2880 204         626 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2881              
2882             study $_; # Yes, I studied study yesterday.
2883              
2884             # while all script
2885              
2886             # 6.14. Matching from Where the Last Pattern Left Off
2887             # in Chapter 6. Pattern Matching
2888             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2889             # (and so on)
2890              
2891             # one member of Tag-team
2892             #
2893             # P.128 Start of match (or end of previous match): \G
2894             # P.130 Advanced Use of \G with Perl
2895             # in Chapter 3: Overview of Regular Expression Features and Flavors
2896             # P.255 Use leading anchors
2897             # P.256 Expose ^ and \G at the front expressions
2898             # in Chapter 6: Crafting an Efficient Expression
2899             # P.315 "Tag-team" matching with /gc
2900             # in Chapter 7: Perl
2901 204         1003 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
2902 204         327  
2903 204         747 my $e_script = '';
2904             while (not /\G \z/oxgc) { # member
2905             $e_script .= TIS620::escape_token();
2906 73091         116737 }
2907              
2908             return $e_script;
2909             }
2910              
2911             #
2912             # escape TIS-620 token of script
2913             #
2914             sub TIS620::escape_token {
2915              
2916 204     73091 0 2744 # \n output here document
2917              
2918             my $ignore_modules = join('|', qw(
2919             utf8
2920             bytes
2921             charnames
2922             I18N::Japanese
2923             I18N::Collate
2924             I18N::JExt
2925             File::DosGlob
2926             Wild
2927             Wildcard
2928             Japanese
2929             ));
2930              
2931             # another member of Tag-team
2932             #
2933             # P.315 "Tag-team" matching with /gc
2934             # in Chapter 7: Perl
2935 73091 100 100     89599 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
2936 73091         3098633  
2937 12245 100       15243 if (/\G ( \n ) /oxgc) { # another member (and so on)
2938 12245         21355 my $heredoc = '';
2939             if (scalar(@heredoc_delimiter) >= 1) {
2940 174         228 $slash = 'm//';
2941 174         413  
2942             $heredoc = join '', @heredoc;
2943             @heredoc = ();
2944 174         295  
2945 174         318 # skip here document
2946             for my $heredoc_delimiter (@heredoc_delimiter) {
2947 174         1083 /\G .*? \n $heredoc_delimiter \n/xmsgc;
2948             }
2949 174         555 @heredoc_delimiter = ();
2950              
2951 174         255 $here_script = '';
2952             }
2953             return "\n" . $heredoc;
2954             }
2955 12245         36892  
2956             # ignore space, comment
2957             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
2958              
2959             # if (, elsif (, unless (, while (, until (, given (, and when (
2960              
2961             # given, when
2962              
2963             # P.225 The given Statement
2964             # in Chapter 15: Smart Matching and given-when
2965             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2966              
2967             # P.133 The given Statement
2968             # in Chapter 4: Statements and Declarations
2969             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2970 17216         66412  
2971 1379         2095 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
2972             $slash = 'm//';
2973             return $1;
2974             }
2975              
2976             # scalar variable ($scalar = ...) =~ tr///;
2977             # scalar variable ($scalar = ...) =~ s///;
2978              
2979             # state
2980              
2981             # P.68 Persistent, Private Variables
2982             # in Chapter 4: Subroutines
2983             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
2984              
2985             # P.160 Persistent Lexically Scoped Variables: state
2986             # in Chapter 4: Statements and Declarations
2987             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2988              
2989             # (and so on)
2990 1379         4282  
2991             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
2992 86 50       199 my $e_string = e_string($1);
    50          
2993 86         2149  
2994 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
2995 0         0 $tr_variable = $e_string . e_string($1);
2996 0         0 $bind_operator = $2;
2997             $slash = 'm//';
2998             return '';
2999 0         0 }
3000 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3001 0         0 $sub_variable = $e_string . e_string($1);
3002 0         0 $bind_operator = $2;
3003             $slash = 'm//';
3004             return '';
3005 0         0 }
3006 86         251 else {
3007             $slash = 'div';
3008             return $e_string;
3009             }
3010             }
3011              
3012 86         286 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Etis620::PREMATCH()
3013 4         8 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
3014             $slash = 'div';
3015             return q{Etis620::PREMATCH()};
3016             }
3017              
3018 4         14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Etis620::MATCH()
3019 28         249 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
3020             $slash = 'div';
3021             return q{Etis620::MATCH()};
3022             }
3023              
3024 28         106 # $', ${'} --> $', ${'}
3025 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
3026             $slash = 'div';
3027             return $1;
3028             }
3029              
3030 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Etis620::POSTMATCH()
3031 3         5 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
3032             $slash = 'div';
3033             return q{Etis620::POSTMATCH()};
3034             }
3035              
3036             # scalar variable $scalar =~ tr///;
3037             # scalar variable $scalar =~ s///;
3038             # substr() =~ tr///;
3039 3         11 # substr() =~ s///;
3040             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
3041 1668 100       4046 my $scalar = e_string($1);
    100          
3042 1668         6586  
3043 1         3 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
3044 1         3 $tr_variable = $scalar;
3045 1         2 $bind_operator = $1;
3046             $slash = 'm//';
3047             return '';
3048 1         3 }
3049 61         436 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
3050 61         120 $sub_variable = $scalar;
3051 61         85 $bind_operator = $1;
3052             $slash = 'm//';
3053             return '';
3054 61         181 }
3055 1606         2259 else {
3056             $slash = 'div';
3057             return $scalar;
3058             }
3059             }
3060              
3061 1606         4277 # end of statement
3062             elsif (/\G ( [,;] ) /oxgc) {
3063             $slash = 'm//';
3064 4831         7552  
3065             # clear tr/// variable
3066             $tr_variable = '';
3067 4831         6419  
3068             # clear s/// variable
3069 4831         5490 $sub_variable = '';
3070              
3071 4831         5158 $bind_operator = '';
3072              
3073             return $1;
3074             }
3075              
3076 4831         16720 # bareword
3077             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
3078             return $1;
3079             }
3080              
3081 0         0 # $0 --> $0
3082 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
3083             $slash = 'div';
3084             return $1;
3085 2         7 }
3086 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
3087             $slash = 'div';
3088             return $1;
3089             }
3090              
3091 0         0 # $$ --> $$
3092 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
3093             $slash = 'div';
3094             return $1;
3095             }
3096              
3097             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
3098 1         4 # $1, $2, $3 --> $1, $2, $3 otherwise
3099 4         10 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
3100             $slash = 'div';
3101             return e_capture($1);
3102 4         8 }
3103 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
3104             $slash = 'div';
3105             return e_capture($1);
3106             }
3107              
3108 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
3109 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
3110             $slash = 'div';
3111             return e_capture($1.'->'.$2);
3112             }
3113              
3114 0         0 # $$foo{ ... } --> $ $foo->{ ... }
3115 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
3116             $slash = 'div';
3117             return e_capture($1.'->'.$2);
3118             }
3119              
3120 0         0 # $$foo
3121 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
3122             $slash = 'div';
3123             return e_capture($1);
3124             }
3125              
3126 0         0 # ${ foo }
3127 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
3128             $slash = 'div';
3129             return '${' . $1 . '}';
3130             }
3131              
3132 0         0 # ${ ... }
3133 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
3134             $slash = 'div';
3135             return e_capture($1);
3136             }
3137              
3138             # variable or function
3139 0         0 # $ @ % & * $ #
3140 32         174 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) {
3141             $slash = 'div';
3142             return $1;
3143             }
3144             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
3145 32         109 # $ @ # \ ' " / ? ( ) [ ] < >
3146 62         113 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
3147             $slash = 'div';
3148             return $1;
3149             }
3150              
3151 62         214 # while ()
3152             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
3153             return $1;
3154             }
3155              
3156             # while () --- glob
3157              
3158             # avoid "Error: Runtime exception" of perl version 5.005_03
3159 0         0  
3160             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^>\0\a\e\f\n\r\t])+?) > (?>\s*) \) \b /oxgc) {
3161             return 'while ($_ = Etis620::glob("' . $1 . '"))';
3162             }
3163              
3164 0         0 # while (glob)
3165             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
3166             return 'while ($_ = Etis620::glob_)';
3167             }
3168              
3169 0         0 # while (glob(WILDCARD))
3170             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
3171             return 'while ($_ = Etis620::glob';
3172             }
3173 0         0  
  248         558  
3174             # doit if, doit unless, doit while, doit until, doit for, doit when
3175             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
3176 248         936  
  19         38  
3177 19         59 # subroutines of package Etis620
  0         0  
3178 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         24  
3179 13         40 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
3180 0         0 elsif (/\G \b TIS620::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         233  
3181 114         445 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
3182 2         6 elsif (/\G \b TIS620::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval TIS620::escape'; }
  0         0  
3183 0         0 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         4  
3184 2         5 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::chop'; }
  0         0  
3185 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  0         0  
3186 0         0 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  0         0  
3187 0         0 elsif (/\G \b TIS620::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'TIS620::index'; }
  2         4  
3188 2         6 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::index'; }
  0         0  
3189 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  0         0  
3190 0         0 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  0         0  
3191 0         0 elsif (/\G \b TIS620::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'TIS620::rindex'; }
  1         2  
3192 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::rindex'; }
  0         0  
3193 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::lc'; }
  1         3  
3194 1         3 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::lcfirst'; }
  0         0  
3195 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::uc'; }
  2         3  
3196             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::ucfirst'; }
3197             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::fc'; }
3198 2         7  
  0         0  
3199 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
3200 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
3201 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3202 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3203 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3204 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
3205             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
3206 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  
3207 0         0  
  0         0  
3208 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
3209 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3210 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3211 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3212 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
3213             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3214             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
3215 0         0  
  0         0  
3216 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
3217 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
3218 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
3219             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
3220 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         4  
3221 2         7  
  2         4  
3222 2         6 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         73  
3223 36         105 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         4  
3224 2         6 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::chr'; }
  8         18  
3225 8         27 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3226 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
3227 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Etis620::glob'; }
  0         0  
3228 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::lc_'; }
  0         0  
3229 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::lcfirst_'; }
  0         0  
3230 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::uc_'; }
  0         0  
3231 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::ucfirst_'; }
  0         0  
3232             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::fc_'; }
3233 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
3234 0         0  
  0         0  
3235 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
3236 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
3237 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::chr_'; }
  0         0  
3238 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
3239 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  0         0  
3240 0         0 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Etis620::glob_'; }
  8         18  
3241             elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
3242             elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
3243 8         30 # split
3244             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
3245 87         197 $slash = 'm//';
3246 87         159  
3247 87         328 my $e = '';
3248             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
3249             $e .= $1;
3250             }
3251 85 100       480  
  87 100       6172  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
3252             # end of split
3253             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Etis620::split' . $e; }
3254 2         9  
3255             # split scalar value
3256             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Etis620::split' . $e . e_string($1); }
3257 1         6  
3258 0         0 # split literal space
3259 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Etis620::split' . $e . qq {qq$1 $2}; }
3260 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Etis620::split' . $e . qq{$1qq$2 $3}; }
3261 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Etis620::split' . $e . qq{$1qq$2 $3}; }
3262 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Etis620::split' . $e . qq{$1qq$2 $3}; }
3263 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Etis620::split' . $e . qq{$1qq$2 $3}; }
3264 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Etis620::split' . $e . qq{$1qq$2 $3}; }
3265 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Etis620::split' . $e . qq {q$1 $2}; }
3266 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Etis620::split' . $e . qq {$1q$2 $3}; }
3267 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Etis620::split' . $e . qq {$1q$2 $3}; }
3268 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Etis620::split' . $e . qq {$1q$2 $3}; }
3269 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Etis620::split' . $e . qq {$1q$2 $3}; }
3270 10         103 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Etis620::split' . $e . qq {$1q$2 $3}; }
3271             elsif (/\G ' [ ] ' /oxgc) { return 'Etis620::split' . $e . qq {' '}; }
3272             elsif (/\G " [ ] " /oxgc) { return 'Etis620::split' . $e . qq {" "}; }
3273              
3274 0 0       0 # split qq//
  0         0  
3275             elsif (/\G \b (qq) \b /oxgc) {
3276 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
3277 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3278 0         0 while (not /\G \z/oxgc) {
3279 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3280 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
3281 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
3282 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
3283 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
3284             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
3285 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
3286             }
3287             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3288             }
3289             }
3290              
3291 0 50       0 # split qr//
  12         406  
3292             elsif (/\G \b (qr) \b /oxgc) {
3293 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
3294 12 50       59 else {
  12 50       3209  
    50          
    50          
    50          
    50          
    50          
    50          
3295 0         0 while (not /\G \z/oxgc) {
3296 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3297 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
3298 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
3299 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
3300 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
3301 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
3302             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
3303 12         77 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
3304             }
3305             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3306             }
3307             }
3308              
3309 0 0       0 # split q//
  0         0  
3310             elsif (/\G \b (q) \b /oxgc) {
3311 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
3312 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3313 0         0 while (not /\G \z/oxgc) {
3314 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3315 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
3316 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
3317 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
3318 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
3319             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
3320 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
3321             }
3322             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3323             }
3324             }
3325              
3326 0 50       0 # split m//
  18         464  
3327             elsif (/\G \b (m) \b /oxgc) {
3328 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
3329 18 50       78 else {
  18 50       3800  
    50          
    50          
    50          
    50          
    50          
    50          
3330 0         0 while (not /\G \z/oxgc) {
3331 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3332 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
3333 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
3334 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
3335 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
3336 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
3337             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
3338 18         226 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
3339             }
3340             die __FILE__, ": Search pattern not terminated\n";
3341             }
3342             }
3343              
3344 0         0 # split ''
3345 0         0 elsif (/\G (\') /oxgc) {
3346 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3347 0         0 while (not /\G \z/oxgc) {
3348 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3349 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
3350             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
3351 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3352             }
3353             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3354             }
3355              
3356 0         0 # split ""
3357 0         0 elsif (/\G (\") /oxgc) {
3358 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3359 0         0 while (not /\G \z/oxgc) {
3360 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3361 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
3362             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
3363 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3364             }
3365             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3366             }
3367              
3368 0         0 # split //
3369 44         115 elsif (/\G (\/) /oxgc) {
3370 44 50       151 my $regexp = '';
  381 50       1522  
    100          
    50          
3371 0         0 while (not /\G \z/oxgc) {
3372 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3373 44         184 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
3374             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
3375 337         806 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3376             }
3377             die __FILE__, ": Search pattern not terminated\n";
3378             }
3379             }
3380              
3381             # tr/// or y///
3382              
3383             # about [cdsrbB]* (/B modifier)
3384             #
3385             # P.559 appendix C
3386             # of ISBN 4-89052-384-7 Programming perl
3387             # (Japanese title is: Perl puroguramingu)
3388 0         0  
3389             elsif (/\G \b ( tr | y ) \b /oxgc) {
3390             my $ope = $1;
3391 3 50       8  
3392 3         45 # $1 $2 $3 $4 $5 $6
3393 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
3394             my @tr = ($tr_variable,$2);
3395             return e_tr(@tr,'',$4,$6);
3396 0         0 }
3397 3         6 else {
3398 3 50       10 my $e = '';
  3 50       252  
    50          
    50          
    50          
    50          
3399             while (not /\G \z/oxgc) {
3400 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3401 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3402 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3403 0         0 while (not /\G \z/oxgc) {
3404 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3405 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
3406 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
3407 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
3408             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
3409 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
3410             }
3411             die __FILE__, ": Transliteration replacement not terminated\n";
3412 0         0 }
3413 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3414 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3415 0         0 while (not /\G \z/oxgc) {
3416 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3417 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
3418 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
3419 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
3420             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
3421 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
3422             }
3423             die __FILE__, ": Transliteration replacement not terminated\n";
3424 0         0 }
3425 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3426 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3427 0         0 while (not /\G \z/oxgc) {
3428 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3429 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
3430 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
3431 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
3432             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
3433 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
3434             }
3435             die __FILE__, ": Transliteration replacement not terminated\n";
3436 0         0 }
3437 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3438 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
3439 0         0 while (not /\G \z/oxgc) {
3440 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3441 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
3442 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
3443 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
3444             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
3445 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
3446             }
3447             die __FILE__, ": Transliteration replacement not terminated\n";
3448             }
3449 0         0 # $1 $2 $3 $4 $5 $6
3450 3         13 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
3451             my @tr = ($tr_variable,$2);
3452             return e_tr(@tr,'',$4,$6);
3453 3         11 }
3454             }
3455             die __FILE__, ": Transliteration pattern not terminated\n";
3456             }
3457             }
3458              
3459 0         0 # qq//
3460             elsif (/\G \b (qq) \b /oxgc) {
3461             my $ope = $1;
3462 2136 50       5451  
3463 2136         4332 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
3464 0         0 if (/\G (\#) /oxgc) { # qq# #
3465 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3466 0         0 while (not /\G \z/oxgc) {
3467 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3468 0         0 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
3469             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
3470 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3471             }
3472             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3473             }
3474 0         0  
3475 2136         2786 else {
3476 2136 50       5171 my $e = '';
  2136 50       8576  
    100          
    50          
    50          
    0          
3477             while (not /\G \z/oxgc) {
3478             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3479              
3480 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
3481 0         0 elsif (/\G (\() /oxgc) { # qq ( )
3482 0         0 my $qq_string = '';
3483 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3484 0         0 while (not /\G \z/oxgc) {
3485 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3486             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
3487 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3488 0         0 elsif (/\G (\)) /oxgc) {
3489             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
3490 0         0 else { $qq_string .= $1; }
3491             }
3492 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3493             }
3494             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3495             }
3496              
3497 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
3498 2106         3036 elsif (/\G (\{) /oxgc) { # qq { }
3499 2106         3193 my $qq_string = '';
3500 2106 100       4261 local $nest = 1;
  83282 50       271941  
    100          
    100          
    50          
3501 610         1206 while (not /\G \z/oxgc) {
3502 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1173         2111  
3503             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
3504 1173 100       1943 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  3279         5215  
3505 2106         5385 elsif (/\G (\}) /oxgc) {
3506             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
3507 1173         2428 else { $qq_string .= $1; }
3508             }
3509 78220         175121 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3510             }
3511             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3512             }
3513              
3514 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
3515 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
3516 0         0 my $qq_string = '';
3517 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
3518 0         0 while (not /\G \z/oxgc) {
3519 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3520             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
3521 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
3522 0         0 elsif (/\G (\]) /oxgc) {
3523             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
3524 0         0 else { $qq_string .= $1; }
3525             }
3526 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3527             }
3528             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3529             }
3530              
3531 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
3532 30         50 elsif (/\G (\<) /oxgc) { # qq < >
3533 30         56 my $qq_string = '';
3534 30 100       96 local $nest = 1;
  1166 50       4079  
    50          
    100          
    50          
3535 22         144 while (not /\G \z/oxgc) {
3536 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
3537             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
3538 0 50       0 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  30         72  
3539 30         75 elsif (/\G (\>) /oxgc) {
3540             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
3541 0         0 else { $qq_string .= $1; }
3542             }
3543 1114         2532 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3544             }
3545             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3546             }
3547              
3548 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
3549 0         0 elsif (/\G (\S) /oxgc) { # qq * *
3550 0         0 my $delimiter = $1;
3551 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
3552 0         0 while (not /\G \z/oxgc) {
3553 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3554 0         0 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
3555             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
3556 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
3557             }
3558             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3559 0         0 }
3560             }
3561             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3562             }
3563             }
3564              
3565 0         0 # qr//
3566 0 0       0 elsif (/\G \b (qr) \b /oxgc) {
3567 0         0 my $ope = $1;
3568             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
3569             return e_qr($ope,$1,$3,$2,$4);
3570 0         0 }
3571 0         0 else {
3572 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3573 0         0 while (not /\G \z/oxgc) {
3574 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3575 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
3576 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
3577 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
3578 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
3579 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
3580             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
3581 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
3582             }
3583             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3584             }
3585             }
3586              
3587 0         0 # qw//
3588 14 50       37 elsif (/\G \b (qw) \b /oxgc) {
3589 14         45 my $ope = $1;
3590             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
3591             return e_qw($ope,$1,$3,$2);
3592 0         0 }
3593 14         25 else {
3594 14 50       57 my $e = '';
  14 50       109  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3595             while (not /\G \z/oxgc) {
3596 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3597 14         57  
3598             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3599 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
3600 0         0  
3601             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3602 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
3603 0         0  
3604             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3605 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
3606 0         0  
3607             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3608 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
3609 0         0  
3610             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3611 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
3612             }
3613             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3614             }
3615             }
3616              
3617 0         0 # qx//
3618 0 0       0 elsif (/\G \b (qx) \b /oxgc) {
3619 0         0 my $ope = $1;
3620             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
3621             return e_qq($ope,$1,$3,$2);
3622 0         0 }
3623 0         0 else {
3624 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
3625 0         0 while (not /\G \z/oxgc) {
3626 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3627 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
3628 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
3629 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
3630 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
3631             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
3632 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
3633             }
3634             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3635             }
3636             }
3637              
3638 0         0 # q//
3639             elsif (/\G \b (q) \b /oxgc) {
3640             my $ope = $1;
3641              
3642             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
3643              
3644             # avoid "Error: Runtime exception" of perl version 5.005_03
3645 422 50       1222 # (and so on)
3646 422         1254  
3647 0         0 if (/\G (\#) /oxgc) { # q# #
3648 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
3649 0         0 while (not /\G \z/oxgc) {
3650 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3651 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
3652             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
3653 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3654             }
3655             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3656             }
3657 0         0  
3658 422         763 else {
3659 422 50       2681 my $e = '';
  422 50       2498  
    100          
    50          
    100          
    50          
3660             while (not /\G \z/oxgc) {
3661             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3662              
3663 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
3664 0         0 elsif (/\G (\() /oxgc) { # q ( )
3665 0         0 my $q_string = '';
3666 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3667 0         0 while (not /\G \z/oxgc) {
3668 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3669 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
3670             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
3671 0 0       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3672 0         0 elsif (/\G (\)) /oxgc) {
3673             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
3674 0         0 else { $q_string .= $1; }
3675             }
3676 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3677             }
3678             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3679             }
3680              
3681 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
3682 416         1037 elsif (/\G (\{) /oxgc) { # q { }
3683 416         754 my $q_string = '';
3684 416 50       1599 local $nest = 1;
  9740 50       35322  
    50          
    100          
    100          
    50          
3685 0         0 while (not /\G \z/oxgc) {
3686 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3687 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  149         227  
3688             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
3689 149 100       284 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  565         1150  
3690 416         1508 elsif (/\G (\}) /oxgc) {
3691             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
3692 149         337 else { $q_string .= $1; }
3693             }
3694 9026         18044 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3695             }
3696             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3697             }
3698              
3699 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
3700 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
3701 0         0 my $q_string = '';
3702 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
3703 0         0 while (not /\G \z/oxgc) {
3704 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3705 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
3706             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
3707 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
3708 0         0 elsif (/\G (\]) /oxgc) {
3709             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
3710 0         0 else { $q_string .= $1; }
3711             }
3712 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3713             }
3714             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3715             }
3716              
3717 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
3718 5         10 elsif (/\G (\<) /oxgc) { # q < >
3719 5         10 my $q_string = '';
3720 5 50       18 local $nest = 1;
  88 50       380  
    50          
    50          
    100          
    50          
3721 0         0 while (not /\G \z/oxgc) {
3722 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3723 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
3724             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
3725 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         22  
3726 5         32 elsif (/\G (\>) /oxgc) {
3727             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
3728 0         0 else { $q_string .= $1; }
3729             }
3730 83         204 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3731             }
3732             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3733             }
3734              
3735 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
3736 1         3 elsif (/\G (\S) /oxgc) { # q * *
3737 1         2 my $delimiter = $1;
3738 1 50       4 my $q_string = '';
  14 50       67  
    100          
    50          
3739 0         0 while (not /\G \z/oxgc) {
3740 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3741 1         3 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
3742             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
3743 13         29 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3744             }
3745             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3746 0         0 }
3747             }
3748             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3749             }
3750             }
3751              
3752 0         0 # m//
3753 209 50       462 elsif (/\G \b (m) \b /oxgc) {
3754 209         1358 my $ope = $1;
3755             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
3756             return e_qr($ope,$1,$3,$2,$4);
3757 0         0 }
3758 209         321 else {
3759 209 50       714 my $e = '';
  209 50       10706  
    50          
    50          
    50          
    50          
    100          
    50          
    50          
3760 0         0 while (not /\G \z/oxgc) {
3761 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3762 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
3763 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
3764 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
3765 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
3766 10         28 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
3767 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
3768             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
3769 199         661 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
3770             }
3771             die __FILE__, ": Search pattern not terminated\n";
3772             }
3773             }
3774              
3775             # s///
3776              
3777             # about [cegimosxpradlunbB]* (/cg modifier)
3778             #
3779             # P.67 Pattern-Matching Operators
3780             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
3781 0         0  
3782             elsif (/\G \b (s) \b /oxgc) {
3783             my $ope = $1;
3784 97 100       269  
3785 97         1607 # $1 $2 $3 $4 $5 $6
3786             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
3787             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3788 1         5 }
3789 96         172 else {
3790 96 50       285 my $e = '';
  96 50       12320  
    50          
    50          
    50          
    100          
    50          
    50          
    50          
3791             while (not /\G \z/oxgc) {
3792 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3793 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
3794 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3795             while (not /\G \z/oxgc) {
3796 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3797 0         0 # $1 $2 $3 $4
3798 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3799 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3800 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3801 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3802 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3803 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3804 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3805             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3806 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3807             }
3808             die __FILE__, ": Substitution replacement not terminated\n";
3809 0         0 }
3810 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
3811 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3812             while (not /\G \z/oxgc) {
3813 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3814 0         0 # $1 $2 $3 $4
3815 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3816 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3817 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3818 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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 (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3822             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3823 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3824             }
3825             die __FILE__, ": Substitution replacement not terminated\n";
3826 0         0 }
3827 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
3828 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
3829             while (not /\G \z/oxgc) {
3830 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3831 0         0 # $1 $2 $3 $4
3832 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3833 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3834 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3835 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([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             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             die __FILE__, ": Substitution replacement not terminated\n";
3841 0         0 }
3842 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
3843 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
3844             while (not /\G \z/oxgc) {
3845 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
3846 0         0 # $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 (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3854             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3855 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
3856             }
3857             die __FILE__, ": Substitution replacement not terminated\n";
3858             }
3859 0         0 # $1 $2 $3 $4 $5 $6
3860             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
3861             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3862             }
3863 21         67 # $1 $2 $3 $4 $5 $6
3864             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3865             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
3866             }
3867 0         0 # $1 $2 $3 $4 $5 $6
3868             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3869             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3870             }
3871 0         0 # $1 $2 $3 $4 $5 $6
3872             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
3873             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
3874 75         337 }
3875             }
3876             die __FILE__, ": Substitution pattern not terminated\n";
3877             }
3878             }
3879 0         0  
3880 0         0 # require ignore module
3881 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
3882             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# require$1\n$2"; }
3883             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
3884 0         0  
3885 37         303 # use strict; --> use strict; no strict qw(refs);
3886 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
3887             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
3888             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
3889              
3890 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
3891 2         21 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3892             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
3893             return "use $1; no strict qw(refs);";
3894 0         0 }
3895             else {
3896             return "use $1;";
3897             }
3898 2 0 0     11 }
      0        
3899 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
3900             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
3901             return "use $1; no strict qw(refs);";
3902 0         0 }
3903             else {
3904             return "use $1;";
3905             }
3906             }
3907 0         0  
3908 2         15 # ignore use module
3909 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
3910             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# use$1\n$2"; }
3911             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
3912 0         0  
3913 0         0 # ignore no module
3914 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
3915             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^#]) /oxmsgc) { return "# no$1\n$2"; }
3916             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
3917 0         0  
3918             # use else
3919             elsif (/\G \b use \b /oxmsgc) { return "use"; }
3920 0         0  
3921             # use else
3922             elsif (/\G \b no \b /oxmsgc) { return "no"; }
3923              
3924 2         8 # ''
3925 836         1699 elsif (/\G (?
3926 836 100       2229 my $q_string = '';
  9464 100       29287  
    100          
    50          
3927 4         11 while (not /\G \z/oxgc) {
3928 12         23 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
3929 836         1919 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
3930             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
3931 8612         17205 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
3932             }
3933             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3934             }
3935              
3936 0         0 # ""
3937 1552         3190 elsif (/\G (\") /oxgc) {
3938 1552 100       4164 my $qq_string = '';
  35990 100       109677  
    100          
    50          
3939 67         159 while (not /\G \z/oxgc) {
3940 12         25 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
3941 1552         4267 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
3942             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
3943 34359         82346 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
3944             }
3945             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3946             }
3947              
3948 0         0 # ``
3949 1         3 elsif (/\G (\`) /oxgc) {
3950 1 50       4 my $qx_string = '';
  19 50       72  
    100          
    50          
3951 0         0 while (not /\G \z/oxgc) {
3952 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
3953 1         2 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
3954             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
3955 18         28 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
3956             }
3957             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
3958             }
3959              
3960 0         0 # // --- not divide operator (num / num), not defined-or
3961 425         974 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
3962 425 50       1318 my $regexp = '';
  4222 50       14407  
    100          
    50          
3963 0         0 while (not /\G \z/oxgc) {
3964 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3965 425         2853 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
3966             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
3967 3797         9419 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3968             }
3969             die __FILE__, ": Search pattern not terminated\n";
3970             }
3971              
3972 0         0 # ?? --- not conditional operator (condition ? then : else)
3973 0         0 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
3974 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
3975 0         0 while (not /\G \z/oxgc) {
3976 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
3977 0         0 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
3978             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
3979 0         0 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
3980             }
3981             die __FILE__, ": Search pattern not terminated\n";
3982             }
3983 0         0  
  0         0  
3984             # <<>> (a safer ARGV)
3985             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
3986 0         0  
  0         0  
3987             # << (bit shift) --- not here document
3988             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
3989              
3990 0         0 # <<~'HEREDOC'
3991 6         11 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
3992 6         11 $slash = 'm//';
3993             my $here_quote = $1;
3994             my $delimiter = $2;
3995 6 50       9  
3996 6         13 # get here document
3997 6         29 if ($here_script eq '') {
3998             $here_script = CORE::substr $_, pos $_;
3999 6 50       31 $here_script =~ s/.*?\n//oxm;
4000 6         59 }
4001 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4002 6         8 my $heredoc = $1;
4003 6         45 my $indent = $2;
4004 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
4005             push @heredoc, $heredoc . qq{\n$delimiter\n};
4006             push @heredoc_delimiter, qq{\\s*$delimiter};
4007 6         10 }
4008             else {
4009 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4010             }
4011             return qq{<<'$delimiter'};
4012             }
4013              
4014             # <<~\HEREDOC
4015              
4016             # P.66 2.6.6. "Here" Documents
4017             # in Chapter 2: Bits and Pieces
4018             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4019              
4020             # P.73 "Here" Documents
4021             # in Chapter 2: Bits and Pieces
4022             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4023 6         23  
4024 3         6 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4025 3         16 $slash = 'm//';
4026             my $here_quote = $1;
4027             my $delimiter = $2;
4028 3 50       7  
4029 3         7 # get here document
4030 3         28 if ($here_script eq '') {
4031             $here_script = CORE::substr $_, pos $_;
4032 3 50       18 $here_script =~ s/.*?\n//oxm;
4033 3         45 }
4034 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4035 3         5 my $heredoc = $1;
4036 3         37 my $indent = $2;
4037 3         11 $heredoc =~ s{^$indent}{}msg; # no /ox
4038             push @heredoc, $heredoc . qq{\n$delimiter\n};
4039             push @heredoc_delimiter, qq{\\s*$delimiter};
4040 3         6 }
4041             else {
4042 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4043             }
4044             return qq{<<\\$delimiter};
4045             }
4046              
4047 3         13 # <<~"HEREDOC"
4048 6         13 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4049 6         12 $slash = 'm//';
4050             my $here_quote = $1;
4051             my $delimiter = $2;
4052 6 50       8  
4053 6         12 # get here document
4054 6         36 if ($here_script eq '') {
4055             $here_script = CORE::substr $_, pos $_;
4056 6 50       31 $here_script =~ s/.*?\n//oxm;
4057 6         54 }
4058 6         12 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4059 6         7 my $heredoc = $1;
4060 6         46 my $indent = $2;
4061 6         32 $heredoc =~ s{^$indent}{}msg; # no /ox
4062             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4063             push @heredoc_delimiter, qq{\\s*$delimiter};
4064 6         14 }
4065             else {
4066 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4067             }
4068             return qq{<<"$delimiter"};
4069             }
4070              
4071 6         23 # <<~HEREDOC
4072 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4073 3         18 $slash = 'm//';
4074             my $here_quote = $1;
4075             my $delimiter = $2;
4076 3 50       7  
4077 3         9 # get here document
4078 3         9 if ($here_script eq '') {
4079             $here_script = CORE::substr $_, pos $_;
4080 3 50       16 $here_script =~ s/.*?\n//oxm;
4081 3         43 }
4082 3         8 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4083 3         6 my $heredoc = $1;
4084 3         36 my $indent = $2;
4085 3         9 $heredoc =~ s{^$indent}{}msg; # no /ox
4086             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4087             push @heredoc_delimiter, qq{\\s*$delimiter};
4088 3         8 }
4089             else {
4090 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4091             }
4092             return qq{<<$delimiter};
4093             }
4094              
4095 3         12 # <<~`HEREDOC`
4096 6         11 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4097 6         11 $slash = 'm//';
4098             my $here_quote = $1;
4099             my $delimiter = $2;
4100 6 50       9  
4101 6         12 # get here document
4102 6         19 if ($here_script eq '') {
4103             $here_script = CORE::substr $_, pos $_;
4104 6 50       43 $here_script =~ s/.*?\n//oxm;
4105 6         56 }
4106 6         13 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4107 6         9 my $heredoc = $1;
4108 6         60 my $indent = $2;
4109 6         17 $heredoc =~ s{^$indent}{}msg; # no /ox
4110             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4111             push @heredoc_delimiter, qq{\\s*$delimiter};
4112 6         14 }
4113             else {
4114 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4115             }
4116             return qq{<<`$delimiter`};
4117             }
4118              
4119 6         111 # <<'HEREDOC'
4120 72         149 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4121 72         208 $slash = 'm//';
4122             my $here_quote = $1;
4123             my $delimiter = $2;
4124 72 50       117  
4125 72         154 # get here document
4126 72         579 if ($here_script eq '') {
4127             $here_script = CORE::substr $_, pos $_;
4128 72 50       496 $here_script =~ s/.*?\n//oxm;
4129 72         681 }
4130 72         259 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4131             push @heredoc, $1 . qq{\n$delimiter\n};
4132             push @heredoc_delimiter, $delimiter;
4133 72         121 }
4134             else {
4135 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4136             }
4137             return $here_quote;
4138             }
4139              
4140             # <<\HEREDOC
4141              
4142             # P.66 2.6.6. "Here" Documents
4143             # in Chapter 2: Bits and Pieces
4144             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4145              
4146             # P.73 "Here" Documents
4147             # in Chapter 2: Bits and Pieces
4148             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4149 72         279  
4150 0         0 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4151 0         0 $slash = 'm//';
4152             my $here_quote = $1;
4153             my $delimiter = $2;
4154 0 0       0  
4155 0         0 # get here document
4156 0         0 if ($here_script eq '') {
4157             $here_script = CORE::substr $_, pos $_;
4158 0 0       0 $here_script =~ s/.*?\n//oxm;
4159 0         0 }
4160 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4161             push @heredoc, $1 . qq{\n$delimiter\n};
4162             push @heredoc_delimiter, $delimiter;
4163 0         0 }
4164             else {
4165 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4166             }
4167             return $here_quote;
4168             }
4169              
4170 0         0 # <<"HEREDOC"
4171 36         83 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4172 36         78 $slash = 'm//';
4173             my $here_quote = $1;
4174             my $delimiter = $2;
4175 36 50       65  
4176 36         87 # get here document
4177 36         352 if ($here_script eq '') {
4178             $here_script = CORE::substr $_, pos $_;
4179 36 50       247 $here_script =~ s/.*?\n//oxm;
4180 36         479 }
4181 36         109 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4182             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4183             push @heredoc_delimiter, $delimiter;
4184 36         81 }
4185             else {
4186 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4187             }
4188             return $here_quote;
4189             }
4190              
4191 36         144 # <
4192 42         107 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4193 42         93 $slash = 'm//';
4194             my $here_quote = $1;
4195             my $delimiter = $2;
4196 42 50       87  
4197 42         628 # get here document
4198 42         521 if ($here_script eq '') {
4199             $here_script = CORE::substr $_, pos $_;
4200 42 50       433 $here_script =~ s/.*?\n//oxm;
4201 42         610 }
4202 42         335 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4203             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4204             push @heredoc_delimiter, $delimiter;
4205 42         106 }
4206             else {
4207 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4208             }
4209             return $here_quote;
4210             }
4211              
4212 42         181 # <<`HEREDOC`
4213 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4214 0         0 $slash = 'm//';
4215             my $here_quote = $1;
4216             my $delimiter = $2;
4217 0 0       0  
4218 0         0 # get here document
4219 0         0 if ($here_script eq '') {
4220             $here_script = CORE::substr $_, pos $_;
4221 0 0       0 $here_script =~ s/.*?\n//oxm;
4222 0         0 }
4223 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4224             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4225             push @heredoc_delimiter, $delimiter;
4226 0         0 }
4227             else {
4228 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4229             }
4230             return $here_quote;
4231             }
4232              
4233 0         0 # <<= <=> <= < operator
4234             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
4235             return $1;
4236             }
4237              
4238 12         61 #
4239             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
4240             return $1;
4241             }
4242              
4243             # --- glob
4244              
4245             # avoid "Error: Runtime exception" of perl version 5.005_03
4246 0         0  
4247             elsif (/\G < ((?:[^>\0\a\e\f\n\r\t])+?) > /oxgc) {
4248             return 'Etis620::glob("' . $1 . '")';
4249             }
4250 0         0  
4251             # __DATA__
4252             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
4253 0         0  
4254             # __END__
4255             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
4256              
4257             # \cD Control-D
4258              
4259             # P.68 2.6.8. Other Literal Tokens
4260             # in Chapter 2: Bits and Pieces
4261             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4262              
4263             # P.76 Other Literal Tokens
4264             # in Chapter 2: Bits and Pieces
4265 204         1618 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4266              
4267             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
4268 0         0  
4269             # \cZ Control-Z
4270             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
4271              
4272             # any operator before div
4273             elsif (/\G (
4274             -- | \+\+ |
4275 0         0 [\)\}\]]
  5017         11137  
4276              
4277             ) /oxgc) { $slash = 'div'; return $1; }
4278              
4279             # yada-yada or triple-dot operator
4280             elsif (/\G (
4281 5017         23419 \.\.\.
  7         13  
4282              
4283             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
4284              
4285             # any operator before m//
4286              
4287             # //, //= (defined-or)
4288              
4289             # P.164 Logical Operators
4290             # in Chapter 10: More Control Structures
4291             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4292              
4293             # P.119 C-Style Logical (Short-Circuit) Operators
4294             # in Chapter 3: Unary and Binary Operators
4295             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4296              
4297             # (and so on)
4298              
4299             # ~~
4300              
4301             # P.221 The Smart Match Operator
4302             # in Chapter 15: Smart Matching and given-when
4303             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
4304              
4305             # P.112 Smartmatch Operator
4306             # in Chapter 3: Unary and Binary Operators
4307             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4308              
4309             # (and so on)
4310              
4311             elsif (/\G ((?>
4312              
4313             !~~ | !~ | != | ! |
4314             %= | % |
4315             &&= | && | &= | &\.= | &\. | & |
4316             -= | -> | - |
4317             :(?>\s*)= |
4318             : |
4319             <<>> |
4320             <<= | <=> | <= | < |
4321             == | => | =~ | = |
4322             >>= | >> | >= | > |
4323             \*\*= | \*\* | \*= | \* |
4324             \+= | \+ |
4325             \.\. | \.= | \. |
4326             \/\/= | \/\/ |
4327             \/= | \/ |
4328             \? |
4329             \\ |
4330             \^= | \^\.= | \^\. | \^ |
4331             \b x= |
4332             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
4333             ~~ | ~\. | ~ |
4334             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
4335             \b(?: print )\b |
4336              
4337 7         24 [,;\(\{\[]
  8644         17839  
4338              
4339             )) /oxgc) { $slash = 'm//'; return $1; }
4340 8644         58043  
  15184         29137  
4341             # other any character
4342             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
4343              
4344 15184         71028 # system error
4345             else {
4346             die __FILE__, ": Oops, this shouldn't happen!\n";
4347             }
4348             }
4349              
4350 0     1767 0 0 # escape TIS-620 string
4351 1767         4261 sub e_string {
4352             my($string) = @_;
4353 1767         2718 my $e_string = '';
4354              
4355             local $slash = 'm//';
4356              
4357             # P.1024 Appendix W.10 Multibyte Processing
4358             # of ISBN 1-56592-224-7 CJKV Information Processing
4359 1767         2913 # (and so on)
4360              
4361             my @char = $string =~ / \G (?>[^\\]|\\$q_char|$q_char) /oxmsg;
4362 1767 100 66     13400  
4363 1767 50       7701 # without { ... }
4364 1751         3606 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
4365             if ($string !~ /<
4366             return $string;
4367             }
4368             }
4369 1751         4353  
4370 16 50       46 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
4371             while ($string !~ /\G \z/oxgc) {
4372             if (0) {
4373             }
4374 185         10193  
4375 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Etis620::PREMATCH()]}
4376 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
4377             $e_string .= q{Etis620::PREMATCH()};
4378             $slash = 'div';
4379             }
4380              
4381 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Etis620::MATCH()]}
4382 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
4383             $e_string .= q{Etis620::MATCH()};
4384             $slash = 'div';
4385             }
4386              
4387 0         0 # $', ${'} --> $', ${'}
4388 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
4389             $e_string .= $1;
4390             $slash = 'div';
4391             }
4392              
4393 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Etis620::POSTMATCH()]}
4394 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
4395             $e_string .= q{Etis620::POSTMATCH()};
4396             $slash = 'div';
4397             }
4398              
4399 0         0 # bareword
4400 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
4401             $e_string .= $1;
4402             $slash = 'div';
4403             }
4404              
4405 0         0 # $0 --> $0
4406 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
4407             $e_string .= $1;
4408             $slash = 'div';
4409 0         0 }
4410 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
4411             $e_string .= $1;
4412             $slash = 'div';
4413             }
4414              
4415 0         0 # $$ --> $$
4416 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
4417             $e_string .= $1;
4418             $slash = 'div';
4419             }
4420              
4421             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
4422 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
4423 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
4424             $e_string .= e_capture($1);
4425             $slash = 'div';
4426 0         0 }
4427 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
4428             $e_string .= e_capture($1);
4429             $slash = 'div';
4430             }
4431              
4432 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
4433 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
4434             $e_string .= e_capture($1.'->'.$2);
4435             $slash = 'div';
4436             }
4437              
4438 0         0 # $$foo{ ... } --> $ $foo->{ ... }
4439 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
4440             $e_string .= e_capture($1.'->'.$2);
4441             $slash = 'div';
4442             }
4443              
4444 0         0 # $$foo
4445 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
4446             $e_string .= e_capture($1);
4447             $slash = 'div';
4448             }
4449              
4450 0         0 # ${ foo }
4451 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
4452             $e_string .= '${' . $1 . '}';
4453             $slash = 'div';
4454             }
4455              
4456 0         0 # ${ ... }
4457 3         8 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
4458             $e_string .= e_capture($1);
4459             $slash = 'div';
4460             }
4461              
4462             # variable or function
4463 3         14 # $ @ % & * $ #
4464 6         13 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) {
4465             $e_string .= $1;
4466             $slash = 'div';
4467             }
4468             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
4469 6         17 # $ @ # \ ' " / ? ( ) [ ] < >
4470 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
4471             $e_string .= $1;
4472             $slash = 'div';
4473             }
4474 0         0  
  0         0  
4475 0         0 # subroutines of package Etis620
  0         0  
4476 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
4477 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4478 0         0 elsif ($string =~ /\G \b TIS620::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
4479 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
4480 0         0 elsif ($string =~ /\G \b TIS620::eval \b /oxgc) { $e_string .= 'eval TIS620::escape'; $slash = 'm//'; }
  0         0  
4481 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
4482 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Etis620::chop'; $slash = 'm//'; }
  0         0  
4483 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
4484 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
4485 0         0 elsif ($string =~ /\G \b TIS620::index \b /oxgc) { $e_string .= 'TIS620::index'; $slash = 'm//'; }
  0         0  
4486 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Etis620::index'; $slash = 'm//'; }
  0         0  
4487 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
4488 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
4489 0         0 elsif ($string =~ /\G \b TIS620::rindex \b /oxgc) { $e_string .= 'TIS620::rindex'; $slash = 'm//'; }
  0         0  
4490 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Etis620::rindex'; $slash = 'm//'; }
  0         0  
4491 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::lc'; $slash = 'm//'; }
  0         0  
4492 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::lcfirst'; $slash = 'm//'; }
  0         0  
4493 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::uc'; $slash = 'm//'; }
  0         0  
4494             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::ucfirst'; $slash = 'm//'; }
4495             elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::fc'; $slash = 'm//'; }
4496 0         0  
  0         0  
4497 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
4498 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4499 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  
4500 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  
4501 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  
4502 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  
4503             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
4504 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  
4505 0         0  
  0         0  
4506 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
4507 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  
4508 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  
4509 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  
4510 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  
4511             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4512             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
4513 0         0  
  0         0  
4514 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
4515 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4516 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
4517             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
4518 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
4519 0         0  
  0         0  
4520 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4521 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4522 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::chr'; $slash = 'm//'; }
  0         0  
4523 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4524 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
4525 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Etis620::glob'; $slash = 'm//'; }
  0         0  
4526 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Etis620::lc_'; $slash = 'm//'; }
  0         0  
4527 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Etis620::lcfirst_'; $slash = 'm//'; }
  0         0  
4528 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Etis620::uc_'; $slash = 'm//'; }
  0         0  
4529 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Etis620::ucfirst_'; $slash = 'm//'; }
  0         0  
4530             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Etis620::fc_'; $slash = 'm//'; }
4531 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
4532 0         0  
  0         0  
4533 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
4534 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
4535 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Etis620::chr_'; $slash = 'm//'; }
  0         0  
4536 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
4537 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
4538 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Etis620::glob_'; $slash = 'm//'; }
  0         0  
4539             elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
4540             elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
4541 0         0 # split
4542             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
4543 0         0 $slash = 'm//';
4544 0         0  
4545 0         0 my $e = '';
4546             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
4547             $e .= $1;
4548             }
4549 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
4550             # end of split
4551             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Etis620::split' . $e; }
4552 0         0  
  0         0  
4553             # split scalar value
4554             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Etis620::split' . $e . e_string($1); next E_STRING_LOOP; }
4555 0         0  
  0         0  
4556 0         0 # split literal space
  0         0  
4557 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
4558 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Etis620::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4559 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Etis620::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4560 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Etis620::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4561 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Etis620::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4562 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Etis620::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
4563 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
4564 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4565 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4566 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4567 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4568 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Etis620::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
4569             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Etis620::split' . $e . qq {' '}; next E_STRING_LOOP; }
4570             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Etis620::split' . $e . qq {" "}; next E_STRING_LOOP; }
4571              
4572 0 0       0 # split qq//
  0         0  
  0         0  
4573             elsif ($string =~ /\G \b (qq) \b /oxgc) {
4574 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
4575 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4576 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4577 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4578 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  
4579 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  
4580 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  
4581 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  
4582             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
4583 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 * *
4584             }
4585             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4586             }
4587             }
4588              
4589 0 0       0 # split qr//
  0         0  
  0         0  
4590             elsif ($string =~ /\G \b (qr) \b /oxgc) {
4591 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
4592 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4593 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4594 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4595 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  
4596 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  
4597 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  
4598 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  
4599 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  
4600             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
4601 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 * *
4602             }
4603             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4604             }
4605             }
4606              
4607 0 0       0 # split q//
  0         0  
  0         0  
4608             elsif ($string =~ /\G \b (q) \b /oxgc) {
4609 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
4610 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4611 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4612 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4613 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  
4614 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  
4615 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  
4616 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  
4617             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
4618 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 * *
4619             }
4620             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4621             }
4622             }
4623              
4624 0 0       0 # split m//
  0         0  
  0         0  
4625             elsif ($string =~ /\G \b (m) \b /oxgc) {
4626 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 # #
4627 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
4628 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4629 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
4630 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  
4631 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  
4632 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  
4633 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  
4634 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  
4635             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
4636 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 * *
4637             }
4638             die __FILE__, ": Search pattern not terminated\n";
4639             }
4640             }
4641              
4642 0         0 # split ''
4643 0         0 elsif ($string =~ /\G (\') /oxgc) {
4644 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
4645 0         0 while ($string !~ /\G \z/oxgc) {
4646 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
4647 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
4648             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
4649 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
4650             }
4651             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4652             }
4653              
4654 0         0 # split ""
4655 0         0 elsif ($string =~ /\G (\") /oxgc) {
4656 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
4657 0         0 while ($string !~ /\G \z/oxgc) {
4658 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
4659 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
4660             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
4661 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
4662             }
4663             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4664             }
4665              
4666 0         0 # split //
4667 0         0 elsif ($string =~ /\G (\/) /oxgc) {
4668 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
4669 0         0 while ($string !~ /\G \z/oxgc) {
4670 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
4671 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
4672             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
4673 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
4674             }
4675             die __FILE__, ": Search pattern not terminated\n";
4676             }
4677             }
4678              
4679 0         0 # qq//
4680 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
4681 0         0 my $ope = $1;
4682             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
4683             $e_string .= e_qq($ope,$1,$3,$2);
4684 0         0 }
4685 0         0 else {
4686 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4687 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4688 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4689 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
4690 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
4691 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
4692             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
4693 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
4694             }
4695             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4696             }
4697             }
4698              
4699 0         0 # qx//
4700 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
4701 0         0 my $ope = $1;
4702             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
4703             $e_string .= e_qq($ope,$1,$3,$2);
4704 0         0 }
4705 0         0 else {
4706 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
4707 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4708 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4709 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
4710 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
4711 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
4712 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
4713             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
4714 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
4715             }
4716             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4717             }
4718             }
4719              
4720 0         0 # q//
4721 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
4722 0         0 my $ope = $1;
4723             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
4724             $e_string .= e_q($ope,$1,$3,$2);
4725 0         0 }
4726 0         0 else {
4727 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
4728 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
4729 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
4730 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
4731 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
4732 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
4733             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
4734 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 * *
4735             }
4736             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
4737             }
4738             }
4739 0         0  
4740             # ''
4741             elsif ($string =~ /\G (?
4742 0         0  
4743             # ""
4744             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4745 0         0  
4746             # ``
4747             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
4748 0         0  
4749             # <<>> (a safer ARGV)
4750             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
4751 0         0  
4752             # <<= <=> <= < operator
4753             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
4754 0         0  
4755             #
4756             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
4757              
4758 0         0 # --- glob
4759             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
4760             $e_string .= 'Etis620::glob("' . $1 . '")';
4761             }
4762              
4763 0         0 # << (bit shift) --- not here document
4764 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
4765             $slash = 'm//';
4766             $e_string .= $1;
4767             }
4768              
4769 0         0 # <<~'HEREDOC'
4770 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
4771 0         0 $slash = 'm//';
4772             my $here_quote = $1;
4773             my $delimiter = $2;
4774 0 0       0  
4775 0         0 # get here document
4776 0         0 if ($here_script eq '') {
4777             $here_script = CORE::substr $_, pos $_;
4778 0 0       0 $here_script =~ s/.*?\n//oxm;
4779 0         0 }
4780 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4781 0         0 my $heredoc = $1;
4782 0         0 my $indent = $2;
4783 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4784             push @heredoc, $heredoc . qq{\n$delimiter\n};
4785             push @heredoc_delimiter, qq{\\s*$delimiter};
4786 0         0 }
4787             else {
4788 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4789             }
4790             $e_string .= qq{<<'$delimiter'};
4791             }
4792              
4793 0         0 # <<~\HEREDOC
4794 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
4795 0         0 $slash = 'm//';
4796             my $here_quote = $1;
4797             my $delimiter = $2;
4798 0 0       0  
4799 0         0 # get here document
4800 0         0 if ($here_script eq '') {
4801             $here_script = CORE::substr $_, pos $_;
4802 0 0       0 $here_script =~ s/.*?\n//oxm;
4803 0         0 }
4804 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4805 0         0 my $heredoc = $1;
4806 0         0 my $indent = $2;
4807 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4808             push @heredoc, $heredoc . qq{\n$delimiter\n};
4809             push @heredoc_delimiter, qq{\\s*$delimiter};
4810 0         0 }
4811             else {
4812 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4813             }
4814             $e_string .= qq{<<\\$delimiter};
4815             }
4816              
4817 0         0 # <<~"HEREDOC"
4818 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
4819 0         0 $slash = 'm//';
4820             my $here_quote = $1;
4821             my $delimiter = $2;
4822 0 0       0  
4823 0         0 # get here document
4824 0         0 if ($here_script eq '') {
4825             $here_script = CORE::substr $_, pos $_;
4826 0 0       0 $here_script =~ s/.*?\n//oxm;
4827 0         0 }
4828 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4829 0         0 my $heredoc = $1;
4830 0         0 my $indent = $2;
4831 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4832             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4833             push @heredoc_delimiter, qq{\\s*$delimiter};
4834 0         0 }
4835             else {
4836 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4837             }
4838             $e_string .= qq{<<"$delimiter"};
4839             }
4840              
4841 0         0 # <<~HEREDOC
4842 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
4843 0         0 $slash = 'm//';
4844             my $here_quote = $1;
4845             my $delimiter = $2;
4846 0 0       0  
4847 0         0 # get here document
4848 0         0 if ($here_script eq '') {
4849             $here_script = CORE::substr $_, pos $_;
4850 0 0       0 $here_script =~ s/.*?\n//oxm;
4851 0         0 }
4852 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4853 0         0 my $heredoc = $1;
4854 0         0 my $indent = $2;
4855 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4856             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4857             push @heredoc_delimiter, qq{\\s*$delimiter};
4858 0         0 }
4859             else {
4860 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4861             }
4862             $e_string .= qq{<<$delimiter};
4863             }
4864              
4865 0         0 # <<~`HEREDOC`
4866 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
4867 0         0 $slash = 'm//';
4868             my $here_quote = $1;
4869             my $delimiter = $2;
4870 0 0       0  
4871 0         0 # get here document
4872 0         0 if ($here_script eq '') {
4873             $here_script = CORE::substr $_, pos $_;
4874 0 0       0 $here_script =~ s/.*?\n//oxm;
4875 0         0 }
4876 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
4877 0         0 my $heredoc = $1;
4878 0         0 my $indent = $2;
4879 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
4880             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
4881             push @heredoc_delimiter, qq{\\s*$delimiter};
4882 0         0 }
4883             else {
4884 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4885             }
4886             $e_string .= qq{<<`$delimiter`};
4887             }
4888              
4889 0         0 # <<'HEREDOC'
4890 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
4891 0         0 $slash = 'm//';
4892             my $here_quote = $1;
4893             my $delimiter = $2;
4894 0 0       0  
4895 0         0 # get here document
4896 0         0 if ($here_script eq '') {
4897             $here_script = CORE::substr $_, pos $_;
4898 0 0       0 $here_script =~ s/.*?\n//oxm;
4899 0         0 }
4900 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4901             push @heredoc, $1 . qq{\n$delimiter\n};
4902             push @heredoc_delimiter, $delimiter;
4903 0         0 }
4904             else {
4905 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4906             }
4907             $e_string .= $here_quote;
4908             }
4909              
4910 0         0 # <<\HEREDOC
4911 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
4912 0         0 $slash = 'm//';
4913             my $here_quote = $1;
4914             my $delimiter = $2;
4915 0 0       0  
4916 0         0 # get here document
4917 0         0 if ($here_script eq '') {
4918             $here_script = CORE::substr $_, pos $_;
4919 0 0       0 $here_script =~ s/.*?\n//oxm;
4920 0         0 }
4921 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4922             push @heredoc, $1 . qq{\n$delimiter\n};
4923             push @heredoc_delimiter, $delimiter;
4924 0         0 }
4925             else {
4926 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4927             }
4928             $e_string .= $here_quote;
4929             }
4930              
4931 0         0 # <<"HEREDOC"
4932 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
4933 0         0 $slash = 'm//';
4934             my $here_quote = $1;
4935             my $delimiter = $2;
4936 0 0       0  
4937 0         0 # get here document
4938 0         0 if ($here_script eq '') {
4939             $here_script = CORE::substr $_, pos $_;
4940 0 0       0 $here_script =~ s/.*?\n//oxm;
4941 0         0 }
4942 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4943             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4944             push @heredoc_delimiter, $delimiter;
4945 0         0 }
4946             else {
4947 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4948             }
4949             $e_string .= $here_quote;
4950             }
4951              
4952 0         0 # <
4953 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
4954 0         0 $slash = 'm//';
4955             my $here_quote = $1;
4956             my $delimiter = $2;
4957 0 0       0  
4958 0         0 # get here document
4959 0         0 if ($here_script eq '') {
4960             $here_script = CORE::substr $_, pos $_;
4961 0 0       0 $here_script =~ s/.*?\n//oxm;
4962 0         0 }
4963 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4964             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4965             push @heredoc_delimiter, $delimiter;
4966 0         0 }
4967             else {
4968 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4969             }
4970             $e_string .= $here_quote;
4971             }
4972              
4973 0         0 # <<`HEREDOC`
4974 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
4975 0         0 $slash = 'm//';
4976             my $here_quote = $1;
4977             my $delimiter = $2;
4978 0 0       0  
4979 0         0 # get here document
4980 0         0 if ($here_script eq '') {
4981             $here_script = CORE::substr $_, pos $_;
4982 0 0       0 $here_script =~ s/.*?\n//oxm;
4983 0         0 }
4984 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
4985             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
4986             push @heredoc_delimiter, $delimiter;
4987 0         0 }
4988             else {
4989 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
4990             }
4991             $e_string .= $here_quote;
4992             }
4993              
4994             # any operator before div
4995             elsif ($string =~ /\G (
4996             -- | \+\+ |
4997 0         0 [\)\}\]]
  17         28  
4998              
4999             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
5000              
5001             # yada-yada or triple-dot operator
5002             elsif ($string =~ /\G (
5003 17         50 \.\.\.
  0         0  
5004              
5005             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
5006              
5007             # any operator before m//
5008             elsif ($string =~ /\G ((?>
5009              
5010             !~~ | !~ | != | ! |
5011             %= | % |
5012             &&= | && | &= | &\.= | &\. | & |
5013             -= | -> | - |
5014             :(?>\s*)= |
5015             : |
5016             <<>> |
5017             <<= | <=> | <= | < |
5018             == | => | =~ | = |
5019             >>= | >> | >= | > |
5020             \*\*= | \*\* | \*= | \* |
5021             \+= | \+ |
5022             \.\. | \.= | \. |
5023             \/\/= | \/\/ |
5024             \/= | \/ |
5025             \? |
5026             \\ |
5027             \^= | \^\.= | \^\. | \^ |
5028             \b x= |
5029             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
5030             ~~ | ~\. | ~ |
5031             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
5032             \b(?: print )\b |
5033              
5034 0         0 [,;\(\{\[]
  30         59  
5035              
5036             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
5037 30         91  
5038             # other any character
5039             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
5040              
5041 129         355 # system error
5042             else {
5043             die __FILE__, ": Oops, this shouldn't happen!\n";
5044             }
5045 0         0 }
5046              
5047             return $e_string;
5048             }
5049              
5050             #
5051             # character class
5052 16     1879 0 66 #
5053             sub character_class {
5054 1879 100       3430 my($char,$modifier) = @_;
5055 1879 100       2948  
5056 52         115 if ($char eq '.') {
5057             if ($modifier =~ /s/) {
5058             return '${Etis620::dot_s}';
5059 17         38 }
5060             else {
5061             return '${Etis620::dot}';
5062             }
5063 35         76 }
5064             else {
5065             return Etis620::classic_character_class($char);
5066             }
5067             }
5068              
5069             #
5070             # escape capture ($1, $2, $3, ...)
5071             #
5072 1827     212 0 3350 sub e_capture {
5073              
5074             return join '', '${', $_[0], '}';
5075             }
5076              
5077             #
5078             # escape transliteration (tr/// or y///)
5079 212     3 0 893 #
5080 3         19 sub e_tr {
5081 3   50     7 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
5082             my $e_tr = '';
5083 3         8 $modifier ||= '';
5084              
5085             $slash = 'div';
5086 3         4  
5087             # quote character class 1
5088             $charclass = q_tr($charclass);
5089 3         8  
5090             # quote character class 2
5091             $charclass2 = q_tr($charclass2);
5092 3 50       7  
5093 3 0       9 # /b /B modifier
5094 0         0 if ($modifier =~ tr/bB//d) {
5095             if ($variable eq '') {
5096             $e_tr = qq{tr$charclass$e$charclass2$modifier};
5097 0         0 }
5098             else {
5099             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
5100             }
5101 0 100       0 }
5102 3         9 else {
5103             if ($variable eq '') {
5104             $e_tr = qq{Etis620::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
5105 2         9 }
5106             else {
5107             $e_tr = qq{Etis620::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
5108             }
5109             }
5110 1         6  
5111 3         5 # clear tr/// variable
5112             $tr_variable = '';
5113 3         5 $bind_operator = '';
5114              
5115             return $e_tr;
5116             }
5117              
5118             #
5119             # quote for escape transliteration (tr/// or y///)
5120 3     6 0 17 #
5121             sub q_tr {
5122             my($charclass) = @_;
5123 6 50       9  
    0          
    0          
    0          
    0          
    0          
5124 6         41 # quote character class
5125             if ($charclass !~ /'/oxms) {
5126             return e_q('', "'", "'", $charclass); # --> q' '
5127 6         9 }
5128             elsif ($charclass !~ /\//oxms) {
5129             return e_q('q', '/', '/', $charclass); # --> q/ /
5130 0         0 }
5131             elsif ($charclass !~ /\#/oxms) {
5132             return e_q('q', '#', '#', $charclass); # --> q# #
5133 0         0 }
5134             elsif ($charclass !~ /[\<\>]/oxms) {
5135             return e_q('q', '<', '>', $charclass); # --> q< >
5136 0         0 }
5137             elsif ($charclass !~ /[\(\)]/oxms) {
5138             return e_q('q', '(', ')', $charclass); # --> q( )
5139 0         0 }
5140             elsif ($charclass !~ /[\{\}]/oxms) {
5141             return e_q('q', '{', '}', $charclass); # --> q{ }
5142 0         0 }
5143 0 0       0 else {
5144 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5145             if ($charclass !~ /\Q$char\E/xms) {
5146             return e_q('q', $char, $char, $charclass);
5147             }
5148             }
5149 0         0 }
5150              
5151             return e_q('q', '{', '}', $charclass);
5152             }
5153              
5154             #
5155             # escape q string (q//, '')
5156 0     1264 0 0 #
5157             sub e_q {
5158 1264         3050 my($ope,$delimiter,$end_delimiter,$string) = @_;
5159              
5160 1264         1955 $slash = 'div';
5161              
5162             return join '', $ope, $delimiter, $string, $end_delimiter;
5163             }
5164              
5165             #
5166             # escape qq string (qq//, "", qx//, ``)
5167 1264     3770 0 6803 #
5168             sub e_qq {
5169 3770         8866 my($ope,$delimiter,$end_delimiter,$string) = @_;
5170              
5171 3770         5251 $slash = 'div';
5172 3770         4695  
5173             my $left_e = 0;
5174             my $right_e = 0;
5175 3770         4381  
5176             # split regexp
5177             my @char = $string =~ /\G((?>
5178             [^\\\$] |
5179             \\x\{ (?>[0-9A-Fa-f]+) \} |
5180             \\o\{ (?>[0-7]+) \} |
5181             \\N\{ (?>[^0-9\}][^\}]*) \} |
5182             \\ $q_char |
5183             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5184             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5185             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5186             \$ (?>\s* [0-9]+) |
5187             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5188             \$ \$ (?![\w\{]) |
5189             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5190             $q_char
5191 3770         142892 ))/oxmsg;
5192              
5193             for (my $i=0; $i <= $#char; $i++) {
5194 3770 50 33     12594  
    50 33        
    100          
    100          
    50          
5195 114471         380629 # "\L\u" --> "\u\L"
5196             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5197             @char[$i,$i+1] = @char[$i+1,$i];
5198             }
5199              
5200 0         0 # "\U\l" --> "\l\U"
5201             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5202             @char[$i,$i+1] = @char[$i+1,$i];
5203             }
5204              
5205 0         0 # octal escape sequence
5206             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5207             $char[$i] = Etis620::octchr($1);
5208             }
5209              
5210 1         4 # hexadecimal escape sequence
5211             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5212             $char[$i] = Etis620::hexchr($1);
5213             }
5214              
5215 1         4 # \N{CHARNAME} --> N{CHARNAME}
5216             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5217             $char[$i] = $1;
5218 0 100       0 }
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5219              
5220             if (0) {
5221             }
5222              
5223             # \F
5224             #
5225             # P.69 Table 2-6. Translation escapes
5226             # in Chapter 2: Bits and Pieces
5227             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5228             # (and so on)
5229 114471         991694  
5230 0 50       0 # \u \l \U \L \F \Q \E
5231 484         1042 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5232             if ($right_e < $left_e) {
5233             $char[$i] = '\\' . $char[$i];
5234             }
5235             }
5236             elsif ($char[$i] eq '\u') {
5237              
5238             # "STRING @{[ LIST EXPR ]} MORE STRING"
5239              
5240             # P.257 Other Tricks You Can Do with Hard References
5241             # in Chapter 8: References
5242             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5243              
5244             # P.353 Other Tricks You Can Do with Hard References
5245             # in Chapter 8: References
5246             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5247              
5248 0         0 # (and so on)
5249 0         0  
5250             $char[$i] = '@{[Etis620::ucfirst qq<';
5251             $left_e++;
5252 0         0 }
5253 0         0 elsif ($char[$i] eq '\l') {
5254             $char[$i] = '@{[Etis620::lcfirst qq<';
5255             $left_e++;
5256 0         0 }
5257 0         0 elsif ($char[$i] eq '\U') {
5258             $char[$i] = '@{[Etis620::uc qq<';
5259             $left_e++;
5260 0         0 }
5261 0         0 elsif ($char[$i] eq '\L') {
5262             $char[$i] = '@{[Etis620::lc qq<';
5263             $left_e++;
5264 0         0 }
5265 8         11 elsif ($char[$i] eq '\F') {
5266             $char[$i] = '@{[Etis620::fc qq<';
5267             $left_e++;
5268 8         14 }
5269 0         0 elsif ($char[$i] eq '\Q') {
5270             $char[$i] = '@{[CORE::quotemeta qq<';
5271             $left_e++;
5272 0 50       0 }
5273 8         14 elsif ($char[$i] eq '\E') {
5274 8         10 if ($right_e < $left_e) {
5275             $char[$i] = '>]}';
5276             $right_e++;
5277 8         15 }
5278             else {
5279             $char[$i] = '';
5280             }
5281 0         0 }
5282 0 0       0 elsif ($char[$i] eq '\Q') {
5283 0         0 while (1) {
5284             if (++$i > $#char) {
5285 0 0       0 last;
5286 0         0 }
5287             if ($char[$i] eq '\E') {
5288             last;
5289             }
5290             }
5291             }
5292             elsif ($char[$i] eq '\E') {
5293             }
5294              
5295             # $0 --> $0
5296             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5297             }
5298             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5299             }
5300              
5301             # $$ --> $$
5302             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5303             }
5304              
5305             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5306 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5307             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5308             $char[$i] = e_capture($1);
5309 205         387 }
5310             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5311             $char[$i] = e_capture($1);
5312             }
5313              
5314 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5315             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5316             $char[$i] = e_capture($1.'->'.$2);
5317             }
5318              
5319 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5320             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5321             $char[$i] = e_capture($1.'->'.$2);
5322             }
5323              
5324 0         0 # $$foo
5325             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5326             $char[$i] = e_capture($1);
5327             }
5328              
5329 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Etis620::PREMATCH()
5330             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5331             $char[$i] = '@{[Etis620::PREMATCH()]}';
5332             }
5333              
5334 44         115 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Etis620::MATCH()
5335             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5336             $char[$i] = '@{[Etis620::MATCH()]}';
5337             }
5338              
5339 45         115 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Etis620::POSTMATCH()
5340             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5341             $char[$i] = '@{[Etis620::POSTMATCH()]}';
5342             }
5343              
5344             # ${ foo } --> ${ foo }
5345             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5346             }
5347              
5348 33         89 # ${ ... }
5349             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5350             $char[$i] = e_capture($1);
5351             }
5352             }
5353 0 50       0  
5354 3770         9268 # return string
5355             if ($left_e > $right_e) {
5356 0         0 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
5357             }
5358             return join '', $ope, $delimiter, @char, $end_delimiter;
5359             }
5360              
5361             #
5362             # escape qw string (qw//)
5363 3770     14 0 35125 #
5364             sub e_qw {
5365 14         69 my($ope,$delimiter,$end_delimiter,$string) = @_;
5366              
5367             $slash = 'div';
5368 14         30  
  14         160  
5369 381 50       3116 # choice again delimiter
    0          
    0          
    0          
    0          
5370 14         97 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
5371             if (not $octet{$end_delimiter}) {
5372             return join '', $ope, $delimiter, $string, $end_delimiter;
5373 14         108 }
5374             elsif (not $octet{')'}) {
5375             return join '', $ope, '(', $string, ')';
5376 0         0 }
5377             elsif (not $octet{'}'}) {
5378             return join '', $ope, '{', $string, '}';
5379 0         0 }
5380             elsif (not $octet{']'}) {
5381             return join '', $ope, '[', $string, ']';
5382 0         0 }
5383             elsif (not $octet{'>'}) {
5384             return join '', $ope, '<', $string, '>';
5385 0         0 }
5386 0 0       0 else {
5387 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5388             if (not $octet{$char}) {
5389             return join '', $ope, $char, $string, $char;
5390             }
5391             }
5392             }
5393 0         0  
5394 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
5395 0         0 my @string = CORE::split(/\s+/, $string);
5396 0         0 for my $string (@string) {
5397 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
5398 0         0 for my $octet (@octet) {
5399             if ($octet =~ /\A (['\\]) \z/oxms) {
5400             $octet = '\\' . $1;
5401 0         0 }
5402             }
5403 0         0 $string = join '', @octet;
  0         0  
5404             }
5405             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
5406             }
5407              
5408             #
5409             # escape here document (<<"HEREDOC", <
5410 0     93 0 0 #
5411             sub e_heredoc {
5412 93         255 my($string) = @_;
5413              
5414 93         331 $slash = 'm//';
5415              
5416 93         298 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
5417 93         142  
5418             my $left_e = 0;
5419             my $right_e = 0;
5420 93         124  
5421             # split regexp
5422             my @char = $string =~ /\G((?>
5423             [^\\\$] |
5424             \\x\{ (?>[0-9A-Fa-f]+) \} |
5425             \\o\{ (?>[0-7]+) \} |
5426             \\N\{ (?>[^0-9\}][^\}]*) \} |
5427             \\ $q_char |
5428             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5429             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5430             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5431             \$ (?>\s* [0-9]+) |
5432             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5433             \$ \$ (?![\w\{]) |
5434             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5435             $q_char
5436 93         20458 ))/oxmsg;
5437              
5438             for (my $i=0; $i <= $#char; $i++) {
5439 93 50 33     451  
    50 33        
    100          
    100          
    50          
5440 5449         17996 # "\L\u" --> "\u\L"
5441             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5442             @char[$i,$i+1] = @char[$i+1,$i];
5443             }
5444              
5445 0         0 # "\U\l" --> "\l\U"
5446             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5447             @char[$i,$i+1] = @char[$i+1,$i];
5448             }
5449              
5450 0         0 # octal escape sequence
5451             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5452             $char[$i] = Etis620::octchr($1);
5453             }
5454              
5455 1         3 # hexadecimal escape sequence
5456             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5457             $char[$i] = Etis620::hexchr($1);
5458             }
5459              
5460 1         4 # \N{CHARNAME} --> N{CHARNAME}
5461             elsif ($char[$i] =~ /\A \\ ( N\{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5462             $char[$i] = $1;
5463 0 50       0 }
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
5464              
5465             if (0) {
5466             }
5467 5449         48530  
5468 0 0       0 # \u \l \U \L \F \Q \E
5469 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
5470             if ($right_e < $left_e) {
5471             $char[$i] = '\\' . $char[$i];
5472             }
5473 0         0 }
5474 0         0 elsif ($char[$i] eq '\u') {
5475             $char[$i] = '@{[Etis620::ucfirst qq<';
5476             $left_e++;
5477 0         0 }
5478 0         0 elsif ($char[$i] eq '\l') {
5479             $char[$i] = '@{[Etis620::lcfirst qq<';
5480             $left_e++;
5481 0         0 }
5482 0         0 elsif ($char[$i] eq '\U') {
5483             $char[$i] = '@{[Etis620::uc qq<';
5484             $left_e++;
5485 0         0 }
5486 0         0 elsif ($char[$i] eq '\L') {
5487             $char[$i] = '@{[Etis620::lc qq<';
5488             $left_e++;
5489 0         0 }
5490 0         0 elsif ($char[$i] eq '\F') {
5491             $char[$i] = '@{[Etis620::fc qq<';
5492             $left_e++;
5493 0         0 }
5494 0         0 elsif ($char[$i] eq '\Q') {
5495             $char[$i] = '@{[CORE::quotemeta qq<';
5496             $left_e++;
5497 0 0       0 }
5498 0         0 elsif ($char[$i] eq '\E') {
5499 0         0 if ($right_e < $left_e) {
5500             $char[$i] = '>]}';
5501             $right_e++;
5502 0         0 }
5503             else {
5504             $char[$i] = '';
5505             }
5506 0         0 }
5507 0 0       0 elsif ($char[$i] eq '\Q') {
5508 0         0 while (1) {
5509             if (++$i > $#char) {
5510 0 0       0 last;
5511 0         0 }
5512             if ($char[$i] eq '\E') {
5513             last;
5514             }
5515             }
5516             }
5517             elsif ($char[$i] eq '\E') {
5518             }
5519              
5520             # $0 --> $0
5521             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5522             }
5523             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5524             }
5525              
5526             # $$ --> $$
5527             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5528             }
5529              
5530             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5531 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5532             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5533             $char[$i] = e_capture($1);
5534 0         0 }
5535             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5536             $char[$i] = e_capture($1);
5537             }
5538              
5539 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5540             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5541             $char[$i] = e_capture($1.'->'.$2);
5542             }
5543              
5544 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5545             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5546             $char[$i] = e_capture($1.'->'.$2);
5547             }
5548              
5549 0         0 # $$foo
5550             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5551             $char[$i] = e_capture($1);
5552             }
5553              
5554 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Etis620::PREMATCH()
5555             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5556             $char[$i] = '@{[Etis620::PREMATCH()]}';
5557             }
5558              
5559 8         41 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Etis620::MATCH()
5560             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5561             $char[$i] = '@{[Etis620::MATCH()]}';
5562             }
5563              
5564 8         43 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Etis620::POSTMATCH()
5565             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5566             $char[$i] = '@{[Etis620::POSTMATCH()]}';
5567             }
5568              
5569             # ${ foo } --> ${ foo }
5570             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
5571             }
5572              
5573 6         32 # ${ ... }
5574             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5575             $char[$i] = e_capture($1);
5576             }
5577             }
5578 0 50       0  
5579 93         217 # return string
5580             if ($left_e > $right_e) {
5581 0         0 return join '', @char, '>]}' x ($left_e - $right_e);
5582             }
5583             return join '', @char;
5584             }
5585              
5586             #
5587             # escape regexp (m//, qr//)
5588 93     624 0 1194 #
5589 624   100     2746 sub e_qr {
5590             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
5591 624         2629 $modifier ||= '';
5592 624 50       2461  
5593 624         1527 $modifier =~ tr/p//d;
5594 0         0 if ($modifier =~ /([adlu])/oxms) {
5595 0 0       0 my $line = 0;
5596 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
5597 0         0 if ($filename ne __FILE__) {
5598             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
5599             last;
5600 0         0 }
5601             }
5602             die qq{Unsupported modifier "$1" used at line $line.\n};
5603 0         0 }
5604              
5605             $slash = 'div';
5606 624 100       1625  
    100          
5607 624         10691 # literal null string pattern
5608 8         9 if ($string eq '') {
5609 8         9 $modifier =~ tr/bB//d;
5610             $modifier =~ tr/i//d;
5611             return join '', $ope, $delimiter, $end_delimiter, $modifier;
5612             }
5613              
5614             # /b /B modifier
5615             elsif ($modifier =~ tr/bB//d) {
5616 8 50       41  
5617 2         7 # choice again delimiter
5618 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
5619 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
5620 0         0 my %octet = map {$_ => 1} @char;
5621 0         0 if (not $octet{')'}) {
5622             $delimiter = '(';
5623             $end_delimiter = ')';
5624 0         0 }
5625 0         0 elsif (not $octet{'}'}) {
5626             $delimiter = '{';
5627             $end_delimiter = '}';
5628 0         0 }
5629 0         0 elsif (not $octet{']'}) {
5630             $delimiter = '[';
5631             $end_delimiter = ']';
5632 0         0 }
5633 0         0 elsif (not $octet{'>'}) {
5634             $delimiter = '<';
5635             $end_delimiter = '>';
5636 0         0 }
5637 0 0       0 else {
5638 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5639 0         0 if (not $octet{$char}) {
5640 0         0 $delimiter = $char;
5641             $end_delimiter = $char;
5642             last;
5643             }
5644             }
5645             }
5646 0 50 33     0 }
5647 2         13  
5648             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
5649             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
5650 0         0 }
5651             else {
5652             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
5653             }
5654 2 100       13 }
5655 614         1365  
5656             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
5657             my $metachar = qr/[\@\\|[\]{^]/oxms;
5658 614         2294  
5659             # split regexp
5660             my @char = $string =~ /\G((?>
5661             [^\\\$\@\[\(] |
5662             \\x (?>[0-9A-Fa-f]{1,2}) |
5663             \\ (?>[0-7]{2,3}) |
5664             \\c [\x40-\x5F] |
5665             \\x\{ (?>[0-9A-Fa-f]+) \} |
5666             \\o\{ (?>[0-7]+) \} |
5667             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
5668             \\ $q_char |
5669             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
5670             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
5671             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
5672             [\$\@] $qq_variable |
5673             \$ (?>\s* [0-9]+) |
5674             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
5675             \$ \$ (?![\w\{]) |
5676             \$ (?>\s*) \$ (?>\s*) $qq_variable |
5677             \[\^ |
5678             \[\: (?>[a-z]+) :\] |
5679             \[\:\^ (?>[a-z]+) :\] |
5680             \(\? |
5681             $q_char
5682             ))/oxmsg;
5683 614 50       68660  
5684 614         2746 # choice again delimiter
  0         0  
5685 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
5686 0         0 my %octet = map {$_ => 1} @char;
5687 0         0 if (not $octet{')'}) {
5688             $delimiter = '(';
5689             $end_delimiter = ')';
5690 0         0 }
5691 0         0 elsif (not $octet{'}'}) {
5692             $delimiter = '{';
5693             $end_delimiter = '}';
5694 0         0 }
5695 0         0 elsif (not $octet{']'}) {
5696             $delimiter = '[';
5697             $end_delimiter = ']';
5698 0         0 }
5699 0         0 elsif (not $octet{'>'}) {
5700             $delimiter = '<';
5701             $end_delimiter = '>';
5702 0         0 }
5703 0 0       0 else {
5704 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
5705 0         0 if (not $octet{$char}) {
5706 0         0 $delimiter = $char;
5707             $end_delimiter = $char;
5708             last;
5709             }
5710             }
5711             }
5712 0         0 }
5713 614         953  
5714 614         790 my $left_e = 0;
5715             my $right_e = 0;
5716             for (my $i=0; $i <= $#char; $i++) {
5717 614 50 66     1569  
    50 66        
    100          
    100          
    100          
    100          
5718 1820         9236 # "\L\u" --> "\u\L"
5719             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
5720             @char[$i,$i+1] = @char[$i+1,$i];
5721             }
5722              
5723 0         0 # "\U\l" --> "\l\U"
5724             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
5725             @char[$i,$i+1] = @char[$i+1,$i];
5726             }
5727              
5728 0         0 # octal escape sequence
5729             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
5730             $char[$i] = Etis620::octchr($1);
5731             }
5732              
5733 1         2 # hexadecimal escape sequence
5734             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
5735             $char[$i] = Etis620::hexchr($1);
5736             }
5737              
5738             # \b{...} --> b\{...}
5739             # \B{...} --> B\{...}
5740             # \N{CHARNAME} --> N\{CHARNAME}
5741             # \p{PROPERTY} --> p\{PROPERTY}
5742 1         4 # \P{PROPERTY} --> P\{PROPERTY}
5743             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
5744             $char[$i] = $1 . '\\' . $2;
5745             }
5746              
5747 6         21 # \p, \P, \X --> p, P, X
5748             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
5749             $char[$i] = $1;
5750 4 100 100     12 }
    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          
5751              
5752             if (0) {
5753             }
5754 1820         5335  
5755 0 50 33     0 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
5756 6         86 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
5757             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)) {
5758             $char[$i] .= join '', splice @char, $i+1, 3;
5759 0         0 }
5760             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)) {
5761             $char[$i] .= join '', splice @char, $i+1, 2;
5762 0         0 }
5763             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)) {
5764             $char[$i] .= join '', splice @char, $i+1, 1;
5765             }
5766             }
5767              
5768 0         0 # open character class [...]
5769             elsif ($char[$i] eq '[') {
5770             my $left = $i;
5771              
5772             # [] make die "Unmatched [] in regexp ...\n"
5773 316 100       503 # (and so on)
5774 316         834  
5775             if ($char[$i+1] eq ']') {
5776             $i++;
5777 3         6 }
5778 316 50       459  
5779 1343         2208 while (1) {
5780             if (++$i > $#char) {
5781 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5782 1343         2019 }
5783             if ($char[$i] eq ']') {
5784             my $right = $i;
5785 316 100       384  
5786 316         1931 # [...]
  30         73  
5787             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5788             splice @char, $left, $right-$left+1, sprintf(q{@{[Etis620::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5789 90         145 }
5790             else {
5791             splice @char, $left, $right-$left+1, Etis620::charlist_qr(@char[$left+1..$right-1], $modifier);
5792 286         1070 }
5793 316         550  
5794             $i = $left;
5795             last;
5796             }
5797             }
5798             }
5799              
5800 316         784 # open character class [^...]
5801             elsif ($char[$i] eq '[^') {
5802             my $left = $i;
5803              
5804             # [^] make die "Unmatched [] in regexp ...\n"
5805 74 100       143 # (and so on)
5806 74         188  
5807             if ($char[$i+1] eq ']') {
5808             $i++;
5809 4         7 }
5810 74 50       82  
5811 272         399 while (1) {
5812             if (++$i > $#char) {
5813 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
5814 272         398 }
5815             if ($char[$i] eq ']') {
5816             my $right = $i;
5817 74 100       115  
5818 74         442 # [^...]
  30         58  
5819             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
5820             splice @char, $left, $right-$left+1, sprintf(q{@{[Etis620::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
5821 90         139 }
5822             else {
5823             splice @char, $left, $right-$left+1, Etis620::charlist_not_qr(@char[$left+1..$right-1], $modifier);
5824 44         196 }
5825 74         143  
5826             $i = $left;
5827             last;
5828             }
5829             }
5830             }
5831              
5832 74         201 # rewrite character class or escape character
5833             elsif (my $char = character_class($char[$i],$modifier)) {
5834             $char[$i] = $char;
5835             }
5836              
5837 139 50       342 # /i modifier
5838 20         31 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Etis620::uc($char[$i]) ne Etis620::fc($char[$i]))) {
5839             if (CORE::length(Etis620::fc($char[$i])) == 1) {
5840             $char[$i] = '[' . Etis620::uc($char[$i]) . Etis620::fc($char[$i]) . ']';
5841 20         46 }
5842             else {
5843             $char[$i] = '(?:' . Etis620::uc($char[$i]) . '|' . Etis620::fc($char[$i]) . ')';
5844             }
5845             }
5846              
5847 0 50       0 # \u \l \U \L \F \Q \E
5848 1         4 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
5849             if ($right_e < $left_e) {
5850             $char[$i] = '\\' . $char[$i];
5851             }
5852 0         0 }
5853 0         0 elsif ($char[$i] eq '\u') {
5854             $char[$i] = '@{[Etis620::ucfirst qq<';
5855             $left_e++;
5856 0         0 }
5857 0         0 elsif ($char[$i] eq '\l') {
5858             $char[$i] = '@{[Etis620::lcfirst qq<';
5859             $left_e++;
5860 0         0 }
5861 1         3 elsif ($char[$i] eq '\U') {
5862             $char[$i] = '@{[Etis620::uc qq<';
5863             $left_e++;
5864 1         4 }
5865 1         2 elsif ($char[$i] eq '\L') {
5866             $char[$i] = '@{[Etis620::lc qq<';
5867             $left_e++;
5868 1         3 }
5869 6         13 elsif ($char[$i] eq '\F') {
5870             $char[$i] = '@{[Etis620::fc qq<';
5871             $left_e++;
5872 6         13 }
5873 1         3 elsif ($char[$i] eq '\Q') {
5874             $char[$i] = '@{[CORE::quotemeta qq<';
5875             $left_e++;
5876 1 50       3 }
5877 9         19 elsif ($char[$i] eq '\E') {
5878 9         13 if ($right_e < $left_e) {
5879             $char[$i] = '>]}';
5880             $right_e++;
5881 9         19 }
5882             else {
5883             $char[$i] = '';
5884             }
5885 0         0 }
5886 0 0       0 elsif ($char[$i] eq '\Q') {
5887 0         0 while (1) {
5888             if (++$i > $#char) {
5889 0 0       0 last;
5890 0         0 }
5891             if ($char[$i] eq '\E') {
5892             last;
5893             }
5894             }
5895             }
5896             elsif ($char[$i] eq '\E') {
5897             }
5898              
5899 0 0       0 # $0 --> $0
5900 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
5901             if ($ignorecase) {
5902             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5903             }
5904 0 0       0 }
5905 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
5906             if ($ignorecase) {
5907             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5908             }
5909             }
5910              
5911             # $$ --> $$
5912             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
5913             }
5914              
5915             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
5916 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
5917 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
5918 0         0 $char[$i] = e_capture($1);
5919             if ($ignorecase) {
5920             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5921             }
5922 0         0 }
5923 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
5924 0         0 $char[$i] = e_capture($1);
5925             if ($ignorecase) {
5926             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5927             }
5928             }
5929              
5930 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
5931 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
5932 0         0 $char[$i] = e_capture($1.'->'.$2);
5933             if ($ignorecase) {
5934             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5935             }
5936             }
5937              
5938 0         0 # $$foo{ ... } --> $ $foo->{ ... }
5939 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
5940 0         0 $char[$i] = e_capture($1.'->'.$2);
5941             if ($ignorecase) {
5942             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5943             }
5944             }
5945              
5946 0         0 # $$foo
5947 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
5948 0         0 $char[$i] = e_capture($1);
5949             if ($ignorecase) {
5950             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5951             }
5952             }
5953              
5954 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Etis620::PREMATCH()
5955 8         21 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
5956             if ($ignorecase) {
5957             $char[$i] = '@{[Etis620::ignorecase(Etis620::PREMATCH())]}';
5958 0         0 }
5959             else {
5960             $char[$i] = '@{[Etis620::PREMATCH()]}';
5961             }
5962             }
5963              
5964 8 50       23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Etis620::MATCH()
5965 8         22 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
5966             if ($ignorecase) {
5967             $char[$i] = '@{[Etis620::ignorecase(Etis620::MATCH())]}';
5968 0         0 }
5969             else {
5970             $char[$i] = '@{[Etis620::MATCH()]}';
5971             }
5972             }
5973              
5974 8 50       25 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Etis620::POSTMATCH()
5975 6         18 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
5976             if ($ignorecase) {
5977             $char[$i] = '@{[Etis620::ignorecase(Etis620::POSTMATCH())]}';
5978 0         0 }
5979             else {
5980             $char[$i] = '@{[Etis620::POSTMATCH()]}';
5981             }
5982             }
5983              
5984 6 0       15 # ${ foo }
5985 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
5986             if ($ignorecase) {
5987             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5988             }
5989             }
5990              
5991 0         0 # ${ ... }
5992 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
5993 0         0 $char[$i] = e_capture($1);
5994             if ($ignorecase) {
5995             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
5996             }
5997             }
5998              
5999 0         0 # $scalar or @array
6000 5 100       15 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6001 5         14 $char[$i] = e_string($char[$i]);
6002             if ($ignorecase) {
6003             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6004             }
6005             }
6006              
6007 3 100 33     11 # quote character before ? + * {
    50          
6008             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6009             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6010 138         1780 }
6011 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6012 0         0 my $char = $char[$i-1];
6013             if ($char[$i] eq '{') {
6014             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
6015 0         0 }
6016             else {
6017             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
6018             }
6019 0         0 }
6020             else {
6021             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6022             }
6023             }
6024             }
6025 127         454  
6026 614 50       1118 # make regexp string
6027 614 0 0     1306 $modifier =~ tr/i//d;
6028 0         0 if ($left_e > $right_e) {
6029             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6030             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
6031 0         0 }
6032             else {
6033             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6034 0 50 33     0 }
6035 614         3690 }
6036             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
6037             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
6038 0         0 }
6039             else {
6040             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6041             }
6042             }
6043              
6044             #
6045             # double quote stuff
6046 614     180 0 6339 #
6047             sub qq_stuff {
6048             my($delimiter,$end_delimiter,$stuff) = @_;
6049 180 100       310  
6050 180         347 # scalar variable or array variable
6051             if ($stuff =~ /\A [\$\@] /oxms) {
6052             return $stuff;
6053             }
6054 100         349  
  80         179  
6055 80         247 # quote by delimiter
6056 80 50       204 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
6057 80 50       146 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6058 80 50       118 next if $char eq $delimiter;
6059 80         158 next if $char eq $end_delimiter;
6060             if (not $octet{$char}) {
6061             return join '', 'qq', $char, $stuff, $char;
6062 80         374 }
6063             }
6064             return join '', 'qq', '<', $stuff, '>';
6065             }
6066              
6067             #
6068             # escape regexp (m'', qr'', and m''b, qr''b)
6069 0     10 0 0 #
6070 10   50     46 sub e_qr_q {
6071             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6072 10         42 $modifier ||= '';
6073 10 50       13  
6074 10         23 $modifier =~ tr/p//d;
6075 0         0 if ($modifier =~ /([adlu])/oxms) {
6076 0 0       0 my $line = 0;
6077 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6078 0         0 if ($filename ne __FILE__) {
6079             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6080             last;
6081 0         0 }
6082             }
6083             die qq{Unsupported modifier "$1" used at line $line.\n};
6084 0         0 }
6085              
6086             $slash = 'div';
6087 10 100       17  
    50          
6088 10         22 # literal null string pattern
6089 8         9 if ($string eq '') {
6090 8         14 $modifier =~ tr/bB//d;
6091             $modifier =~ tr/i//d;
6092             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6093             }
6094              
6095 8         35 # with /b /B modifier
6096             elsif ($modifier =~ tr/bB//d) {
6097             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6098             }
6099              
6100 0         0 # without /b /B modifier
6101             else {
6102             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6103             }
6104             }
6105              
6106             #
6107             # escape regexp (m'', qr'')
6108 2     2 0 8 #
6109             sub e_qr_qt {
6110 2 50       5 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6111              
6112             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6113 2         6  
6114             # split regexp
6115             my @char = $string =~ /\G((?>
6116             [^\\\[\$\@\/] |
6117             [\x00-\xFF] |
6118             \[\^ |
6119             \[\: (?>[a-z]+) \:\] |
6120             \[\:\^ (?>[a-z]+) \:\] |
6121             [\$\@\/] |
6122             \\ (?:$q_char) |
6123             (?:$q_char)
6124             ))/oxmsg;
6125 2         64  
6126 2 50 33     12 # unescape character
    50 33        
    50 33        
    50          
    50          
    50          
6127             for (my $i=0; $i <= $#char; $i++) {
6128             if (0) {
6129             }
6130 2         28  
6131 0         0 # open character class [...]
6132 0 0       0 elsif ($char[$i] eq '[') {
6133 0         0 my $left = $i;
6134             if ($char[$i+1] eq ']') {
6135 0         0 $i++;
6136 0 0       0 }
6137 0         0 while (1) {
6138             if (++$i > $#char) {
6139 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6140 0         0 }
6141             if ($char[$i] eq ']') {
6142             my $right = $i;
6143 0         0  
6144             # [...]
6145 0         0 splice @char, $left, $right-$left+1, Etis620::charlist_qr(@char[$left+1..$right-1], $modifier);
6146 0         0  
6147             $i = $left;
6148             last;
6149             }
6150             }
6151             }
6152              
6153 0         0 # open character class [^...]
6154 0 0       0 elsif ($char[$i] eq '[^') {
6155 0         0 my $left = $i;
6156             if ($char[$i+1] eq ']') {
6157 0         0 $i++;
6158 0 0       0 }
6159 0         0 while (1) {
6160             if (++$i > $#char) {
6161 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6162 0         0 }
6163             if ($char[$i] eq ']') {
6164             my $right = $i;
6165 0         0  
6166             # [^...]
6167 0         0 splice @char, $left, $right-$left+1, Etis620::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6168 0         0  
6169             $i = $left;
6170             last;
6171             }
6172             }
6173             }
6174              
6175 0         0 # escape $ @ / and \
6176             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6177             $char[$i] = '\\' . $char[$i];
6178             }
6179              
6180 0         0 # rewrite character class or escape character
6181             elsif (my $char = character_class($char[$i],$modifier)) {
6182             $char[$i] = $char;
6183             }
6184              
6185 0 0       0 # /i modifier
6186 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Etis620::uc($char[$i]) ne Etis620::fc($char[$i]))) {
6187             if (CORE::length(Etis620::fc($char[$i])) == 1) {
6188             $char[$i] = '[' . Etis620::uc($char[$i]) . Etis620::fc($char[$i]) . ']';
6189 0         0 }
6190             else {
6191             $char[$i] = '(?:' . Etis620::uc($char[$i]) . '|' . Etis620::fc($char[$i]) . ')';
6192             }
6193             }
6194              
6195 0 0       0 # quote character before ? + * {
6196             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6197             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6198 0         0 }
6199             else {
6200             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6201             }
6202             }
6203 0         0 }
6204 2         11  
6205             $delimiter = '/';
6206 2         4 $end_delimiter = '/';
6207 2         4  
6208             $modifier =~ tr/i//d;
6209             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6210             }
6211              
6212             #
6213             # escape regexp (m''b, qr''b)
6214 2     0 0 18 #
6215             sub e_qr_qb {
6216             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6217 0         0  
6218             # split regexp
6219             my @char = $string =~ /\G ((?>[^\\]|\\\\)) /oxmsg;
6220 0         0  
6221 0 0       0 # unescape character
    0          
6222             for (my $i=0; $i <= $#char; $i++) {
6223             if (0) {
6224             }
6225 0         0  
6226             # remain \\
6227             elsif ($char[$i] eq '\\\\') {
6228             }
6229              
6230 0         0 # escape $ @ / and \
6231             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6232             $char[$i] = '\\' . $char[$i];
6233             }
6234 0         0 }
6235 0         0  
6236 0         0 $delimiter = '/';
6237             $end_delimiter = '/';
6238             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6239             }
6240              
6241             #
6242             # escape regexp (s/here//)
6243 0     76 0 0 #
6244 76   100     218 sub e_s1 {
6245             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6246 76         295 $modifier ||= '';
6247 76 50       123  
6248 76         226 $modifier =~ tr/p//d;
6249 0         0 if ($modifier =~ /([adlu])/oxms) {
6250 0 0       0 my $line = 0;
6251 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6252 0         0 if ($filename ne __FILE__) {
6253             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6254             last;
6255 0         0 }
6256             }
6257             die qq{Unsupported modifier "$1" used at line $line.\n};
6258 0         0 }
6259              
6260             $slash = 'div';
6261 76 100       146  
    50          
6262 76         266 # literal null string pattern
6263 8         12 if ($string eq '') {
6264 8         10 $modifier =~ tr/bB//d;
6265             $modifier =~ tr/i//d;
6266             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6267             }
6268              
6269             # /b /B modifier
6270             elsif ($modifier =~ tr/bB//d) {
6271 8 0       50  
6272 0         0 # choice again delimiter
6273 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
6274 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
6275 0         0 my %octet = map {$_ => 1} @char;
6276 0         0 if (not $octet{')'}) {
6277             $delimiter = '(';
6278             $end_delimiter = ')';
6279 0         0 }
6280 0         0 elsif (not $octet{'}'}) {
6281             $delimiter = '{';
6282             $end_delimiter = '}';
6283 0         0 }
6284 0         0 elsif (not $octet{']'}) {
6285             $delimiter = '[';
6286             $end_delimiter = ']';
6287 0         0 }
6288 0         0 elsif (not $octet{'>'}) {
6289             $delimiter = '<';
6290             $end_delimiter = '>';
6291 0         0 }
6292 0 0       0 else {
6293 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6294 0         0 if (not $octet{$char}) {
6295 0         0 $delimiter = $char;
6296             $end_delimiter = $char;
6297             last;
6298             }
6299             }
6300             }
6301 0         0 }
6302 0         0  
6303             my $prematch = '';
6304             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
6305 0 100       0 }
6306 68         284  
6307             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6308             my $metachar = qr/[\@\\|[\]{^]/oxms;
6309 68         287  
6310             # split regexp
6311             my @char = $string =~ /\G((?>
6312             [^\\\$\@\[\(] |
6313             \\ (?>[1-9][0-9]*) |
6314             \\g (?>\s*) (?>[1-9][0-9]*) |
6315             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6316             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
6317             \\x (?>[0-9A-Fa-f]{1,2}) |
6318             \\ (?>[0-7]{2,3}) |
6319             \\c [\x40-\x5F] |
6320             \\x\{ (?>[0-9A-Fa-f]+) \} |
6321             \\o\{ (?>[0-7]+) \} |
6322             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
6323             \\ $q_char |
6324             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
6325             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
6326             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
6327             [\$\@] $qq_variable |
6328             \$ (?>\s* [0-9]+) |
6329             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
6330             \$ \$ (?![\w\{]) |
6331             \$ (?>\s*) \$ (?>\s*) $qq_variable |
6332             \[\^ |
6333             \[\: (?>[a-z]+) :\] |
6334             \[\:\^ (?>[a-z]+) :\] |
6335             \(\? |
6336             $q_char
6337             ))/oxmsg;
6338 68 50       17017  
6339 68         476 # choice again delimiter
  0         0  
6340 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
6341 0         0 my %octet = map {$_ => 1} @char;
6342 0         0 if (not $octet{')'}) {
6343             $delimiter = '(';
6344             $end_delimiter = ')';
6345 0         0 }
6346 0         0 elsif (not $octet{'}'}) {
6347             $delimiter = '{';
6348             $end_delimiter = '}';
6349 0         0 }
6350 0         0 elsif (not $octet{']'}) {
6351             $delimiter = '[';
6352             $end_delimiter = ']';
6353 0         0 }
6354 0         0 elsif (not $octet{'>'}) {
6355             $delimiter = '<';
6356             $end_delimiter = '>';
6357 0         0 }
6358 0 0       0 else {
6359 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
6360 0         0 if (not $octet{$char}) {
6361 0         0 $delimiter = $char;
6362             $end_delimiter = $char;
6363             last;
6364             }
6365             }
6366             }
6367             }
6368 0         0  
  68         138  
6369             # count '('
6370 253         433 my $parens = grep { $_ eq '(' } @char;
6371 68         102  
6372 68         90 my $left_e = 0;
6373             my $right_e = 0;
6374             for (my $i=0; $i <= $#char; $i++) {
6375 68 50 33     188  
    50 33        
    100          
    100          
    50          
    50          
6376 195         1746 # "\L\u" --> "\u\L"
6377             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
6378             @char[$i,$i+1] = @char[$i+1,$i];
6379             }
6380              
6381 0         0 # "\U\l" --> "\l\U"
6382             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
6383             @char[$i,$i+1] = @char[$i+1,$i];
6384             }
6385              
6386 0         0 # octal escape sequence
6387             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
6388             $char[$i] = Etis620::octchr($1);
6389             }
6390              
6391 1         3 # hexadecimal escape sequence
6392             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
6393             $char[$i] = Etis620::hexchr($1);
6394             }
6395              
6396             # \b{...} --> b\{...}
6397             # \B{...} --> B\{...}
6398             # \N{CHARNAME} --> N\{CHARNAME}
6399             # \p{PROPERTY} --> p\{PROPERTY}
6400 1         4 # \P{PROPERTY} --> P\{PROPERTY}
6401             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
6402             $char[$i] = $1 . '\\' . $2;
6403             }
6404              
6405 0         0 # \p, \P, \X --> p, P, X
6406             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
6407             $char[$i] = $1;
6408 0 50 66     0 }
    100 66        
    50 100        
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
6409              
6410             if (0) {
6411             }
6412 195         668  
6413 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
6414 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
6415             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)) {
6416             $char[$i] .= join '', splice @char, $i+1, 3;
6417 0         0 }
6418             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)) {
6419             $char[$i] .= join '', splice @char, $i+1, 2;
6420 0         0 }
6421             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)) {
6422             $char[$i] .= join '', splice @char, $i+1, 1;
6423             }
6424             }
6425              
6426 0         0 # open character class [...]
6427 13 50       18 elsif ($char[$i] eq '[') {
6428 13         49 my $left = $i;
6429             if ($char[$i+1] eq ']') {
6430 0         0 $i++;
6431 13 50       19 }
6432 58         88 while (1) {
6433             if (++$i > $#char) {
6434 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
6435 58         128 }
6436             if ($char[$i] eq ']') {
6437             my $right = $i;
6438 13 50       23  
6439 13         76 # [...]
  0         0  
6440             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6441             splice @char, $left, $right-$left+1, sprintf(q{@{[Etis620::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6442 0         0 }
6443             else {
6444             splice @char, $left, $right-$left+1, Etis620::charlist_qr(@char[$left+1..$right-1], $modifier);
6445 13         51 }
6446 13         26  
6447             $i = $left;
6448             last;
6449             }
6450             }
6451             }
6452              
6453 13         35 # open character class [^...]
6454 0 0       0 elsif ($char[$i] eq '[^') {
6455 0         0 my $left = $i;
6456             if ($char[$i+1] eq ']') {
6457 0         0 $i++;
6458 0 0       0 }
6459 0         0 while (1) {
6460             if (++$i > $#char) {
6461 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6462 0         0 }
6463             if ($char[$i] eq ']') {
6464             my $right = $i;
6465 0 0       0  
6466 0         0 # [^...]
  0         0  
6467             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
6468             splice @char, $left, $right-$left+1, sprintf(q{@{[Etis620::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
6469 0         0 }
6470             else {
6471             splice @char, $left, $right-$left+1, Etis620::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6472 0         0 }
6473 0         0  
6474             $i = $left;
6475             last;
6476             }
6477             }
6478             }
6479              
6480 0         0 # rewrite character class or escape character
6481             elsif (my $char = character_class($char[$i],$modifier)) {
6482             $char[$i] = $char;
6483             }
6484              
6485 7 50       15 # /i modifier
6486 3         10 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Etis620::uc($char[$i]) ne Etis620::fc($char[$i]))) {
6487             if (CORE::length(Etis620::fc($char[$i])) == 1) {
6488             $char[$i] = '[' . Etis620::uc($char[$i]) . Etis620::fc($char[$i]) . ']';
6489 3         6 }
6490             else {
6491             $char[$i] = '(?:' . Etis620::uc($char[$i]) . '|' . Etis620::fc($char[$i]) . ')';
6492             }
6493             }
6494              
6495 0 0       0 # \u \l \U \L \F \Q \E
6496 0         0 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
6497             if ($right_e < $left_e) {
6498             $char[$i] = '\\' . $char[$i];
6499             }
6500 0         0 }
6501 0         0 elsif ($char[$i] eq '\u') {
6502             $char[$i] = '@{[Etis620::ucfirst qq<';
6503             $left_e++;
6504 0         0 }
6505 0         0 elsif ($char[$i] eq '\l') {
6506             $char[$i] = '@{[Etis620::lcfirst qq<';
6507             $left_e++;
6508 0         0 }
6509 0         0 elsif ($char[$i] eq '\U') {
6510             $char[$i] = '@{[Etis620::uc qq<';
6511             $left_e++;
6512 0         0 }
6513 0         0 elsif ($char[$i] eq '\L') {
6514             $char[$i] = '@{[Etis620::lc qq<';
6515             $left_e++;
6516 0         0 }
6517 0         0 elsif ($char[$i] eq '\F') {
6518             $char[$i] = '@{[Etis620::fc qq<';
6519             $left_e++;
6520 0         0 }
6521 0         0 elsif ($char[$i] eq '\Q') {
6522             $char[$i] = '@{[CORE::quotemeta qq<';
6523             $left_e++;
6524 0 0       0 }
6525 0         0 elsif ($char[$i] eq '\E') {
6526 0         0 if ($right_e < $left_e) {
6527             $char[$i] = '>]}';
6528             $right_e++;
6529 0         0 }
6530             else {
6531             $char[$i] = '';
6532             }
6533 0         0 }
6534 0 0       0 elsif ($char[$i] eq '\Q') {
6535 0         0 while (1) {
6536             if (++$i > $#char) {
6537 0 0       0 last;
6538 0         0 }
6539             if ($char[$i] eq '\E') {
6540             last;
6541             }
6542             }
6543             }
6544             elsif ($char[$i] eq '\E') {
6545             }
6546              
6547             # \0 --> \0
6548             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
6549             }
6550              
6551             # \g{N}, \g{-N}
6552              
6553             # P.108 Using Simple Patterns
6554             # in Chapter 7: In the World of Regular Expressions
6555             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6556              
6557             # P.221 Capturing
6558             # in Chapter 5: Pattern Matching
6559             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6560              
6561             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
6562             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6563             }
6564              
6565             # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
6566             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6567             }
6568              
6569             # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
6570             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6571             }
6572              
6573             # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
6574             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
6575             }
6576              
6577 0 0       0 # $0 --> $0
6578 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
6579             if ($ignorecase) {
6580             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6581             }
6582 0 0       0 }
6583 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
6584             if ($ignorecase) {
6585             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6586             }
6587             }
6588              
6589             # $$ --> $$
6590             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
6591             }
6592              
6593             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6594 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
6595 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
6596 0         0 $char[$i] = e_capture($1);
6597             if ($ignorecase) {
6598             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6599             }
6600 0         0 }
6601 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
6602 0         0 $char[$i] = e_capture($1);
6603             if ($ignorecase) {
6604             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6605             }
6606             }
6607              
6608 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6609 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
6610 0         0 $char[$i] = e_capture($1.'->'.$2);
6611             if ($ignorecase) {
6612             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6613             }
6614             }
6615              
6616 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6617 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
6618 0         0 $char[$i] = e_capture($1.'->'.$2);
6619             if ($ignorecase) {
6620             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6621             }
6622             }
6623              
6624 0         0 # $$foo
6625 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
6626 0         0 $char[$i] = e_capture($1);
6627             if ($ignorecase) {
6628             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6629             }
6630             }
6631              
6632 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Etis620::PREMATCH()
6633 4         13 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
6634             if ($ignorecase) {
6635             $char[$i] = '@{[Etis620::ignorecase(Etis620::PREMATCH())]}';
6636 0         0 }
6637             else {
6638             $char[$i] = '@{[Etis620::PREMATCH()]}';
6639             }
6640             }
6641              
6642 4 50       14 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Etis620::MATCH()
6643 4         14 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
6644             if ($ignorecase) {
6645             $char[$i] = '@{[Etis620::ignorecase(Etis620::MATCH())]}';
6646 0         0 }
6647             else {
6648             $char[$i] = '@{[Etis620::MATCH()]}';
6649             }
6650             }
6651              
6652 4 50       14 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Etis620::POSTMATCH()
6653 3         10 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
6654             if ($ignorecase) {
6655             $char[$i] = '@{[Etis620::ignorecase(Etis620::POSTMATCH())]}';
6656 0         0 }
6657             else {
6658             $char[$i] = '@{[Etis620::POSTMATCH()]}';
6659             }
6660             }
6661              
6662 3 0       10 # ${ foo }
6663 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
6664             if ($ignorecase) {
6665             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6666             }
6667             }
6668              
6669 0         0 # ${ ... }
6670 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
6671 0         0 $char[$i] = e_capture($1);
6672             if ($ignorecase) {
6673             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6674             }
6675             }
6676              
6677 0         0 # $scalar or @array
6678 4 50       20 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
6679 4         20 $char[$i] = e_string($char[$i]);
6680             if ($ignorecase) {
6681             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
6682             }
6683             }
6684              
6685 0 50       0 # quote character before ? + * {
6686             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6687             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
6688 13         77 }
6689             else {
6690             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6691             }
6692             }
6693             }
6694 13         65  
6695 68         154 # make regexp string
6696 68 50       108 my $prematch = '';
6697 68         178 $modifier =~ tr/i//d;
6698             if ($left_e > $right_e) {
6699 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
6700             }
6701             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6702             }
6703              
6704             #
6705             # escape regexp (s'here'' or s'here''b)
6706 68     21 0 813 #
6707 21   100     47 sub e_s1_q {
6708             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6709 21         76 $modifier ||= '';
6710 21 50       30  
6711 21         47 $modifier =~ tr/p//d;
6712 0         0 if ($modifier =~ /([adlu])/oxms) {
6713 0 0       0 my $line = 0;
6714 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6715 0         0 if ($filename ne __FILE__) {
6716             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6717             last;
6718 0         0 }
6719             }
6720             die qq{Unsupported modifier "$1" used at line $line.\n};
6721 0         0 }
6722              
6723             $slash = 'div';
6724 21 100       31  
    50          
6725 21         53 # literal null string pattern
6726 8         10 if ($string eq '') {
6727 8         10 $modifier =~ tr/bB//d;
6728             $modifier =~ tr/i//d;
6729             return join '', $ope, $delimiter, $end_delimiter, $modifier;
6730             }
6731              
6732 8         45 # with /b /B modifier
6733             elsif ($modifier =~ tr/bB//d) {
6734             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
6735             }
6736              
6737 0         0 # without /b /B modifier
6738             else {
6739             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
6740             }
6741             }
6742              
6743             #
6744             # escape regexp (s'here'')
6745 13     13 0 34 #
6746             sub e_s1_qt {
6747 13 50       27 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6748              
6749             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
6750 13         45  
6751             # split regexp
6752             my @char = $string =~ /\G((?>
6753             [^\\\[\$\@\/] |
6754             [\x00-\xFF] |
6755             \[\^ |
6756             \[\: (?>[a-z]+) \:\] |
6757             \[\:\^ (?>[a-z]+) \:\] |
6758             [\$\@\/] |
6759             \\ (?:$q_char) |
6760             (?:$q_char)
6761             ))/oxmsg;
6762 13         205  
6763 13 50 33     41 # unescape character
    50 33        
    50 66        
    100          
    50          
    50          
6764             for (my $i=0; $i <= $#char; $i++) {
6765             if (0) {
6766             }
6767 25         104  
6768 0         0 # open character class [...]
6769 0 0       0 elsif ($char[$i] eq '[') {
6770 0         0 my $left = $i;
6771             if ($char[$i+1] eq ']') {
6772 0         0 $i++;
6773 0 0       0 }
6774 0         0 while (1) {
6775             if (++$i > $#char) {
6776 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6777 0         0 }
6778             if ($char[$i] eq ']') {
6779             my $right = $i;
6780 0         0  
6781             # [...]
6782 0         0 splice @char, $left, $right-$left+1, Etis620::charlist_qr(@char[$left+1..$right-1], $modifier);
6783 0         0  
6784             $i = $left;
6785             last;
6786             }
6787             }
6788             }
6789              
6790 0         0 # open character class [^...]
6791 0 0       0 elsif ($char[$i] eq '[^') {
6792 0         0 my $left = $i;
6793             if ($char[$i+1] eq ']') {
6794 0         0 $i++;
6795 0 0       0 }
6796 0         0 while (1) {
6797             if (++$i > $#char) {
6798 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
6799 0         0 }
6800             if ($char[$i] eq ']') {
6801             my $right = $i;
6802 0         0  
6803             # [^...]
6804 0         0 splice @char, $left, $right-$left+1, Etis620::charlist_not_qr(@char[$left+1..$right-1], $modifier);
6805 0         0  
6806             $i = $left;
6807             last;
6808             }
6809             }
6810             }
6811              
6812 0         0 # escape $ @ / and \
6813             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6814             $char[$i] = '\\' . $char[$i];
6815             }
6816              
6817 0         0 # rewrite character class or escape character
6818             elsif (my $char = character_class($char[$i],$modifier)) {
6819             $char[$i] = $char;
6820             }
6821              
6822 6 0       11 # /i modifier
6823 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Etis620::uc($char[$i]) ne Etis620::fc($char[$i]))) {
6824             if (CORE::length(Etis620::fc($char[$i])) == 1) {
6825             $char[$i] = '[' . Etis620::uc($char[$i]) . Etis620::fc($char[$i]) . ']';
6826 0         0 }
6827             else {
6828             $char[$i] = '(?:' . Etis620::uc($char[$i]) . '|' . Etis620::fc($char[$i]) . ')';
6829             }
6830             }
6831              
6832 0 0       0 # quote character before ? + * {
6833             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
6834             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
6835 0         0 }
6836             else {
6837             $char[$i-1] = '(?:' . $char[$i-1] . ')';
6838             }
6839             }
6840 0         0 }
6841 13         26  
6842 13         20 $modifier =~ tr/i//d;
6843 13         18 $delimiter = '/';
6844 13         16 $end_delimiter = '/';
6845             my $prematch = '';
6846             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6847             }
6848              
6849             #
6850             # escape regexp (s'here''b)
6851 13     0 0 112 #
6852             sub e_s1_qb {
6853             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
6854 0         0  
6855             # split regexp
6856             my @char = $string =~ /\G (?>[^\\]|\\\\) /oxmsg;
6857 0         0  
6858 0 0       0 # unescape character
    0          
6859             for (my $i=0; $i <= $#char; $i++) {
6860             if (0) {
6861             }
6862 0         0  
6863             # remain \\
6864             elsif ($char[$i] eq '\\\\') {
6865             }
6866              
6867 0         0 # escape $ @ / and \
6868             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6869             $char[$i] = '\\' . $char[$i];
6870             }
6871 0         0 }
6872 0         0  
6873 0         0 $delimiter = '/';
6874 0         0 $end_delimiter = '/';
6875             my $prematch = '';
6876             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
6877             }
6878              
6879             #
6880             # escape regexp (s''here')
6881 0     16 0 0 #
6882             sub e_s2_q {
6883 16         35 my($ope,$delimiter,$end_delimiter,$string) = @_;
6884              
6885 16         21 $slash = 'div';
6886 16         99  
6887 16 100       46 my @char = $string =~ / \G (?>[^\\]|\\\\|$q_char) /oxmsg;
    100          
6888             for (my $i=0; $i <= $#char; $i++) {
6889             if (0) {
6890             }
6891 9         30  
6892             # not escape \\
6893             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
6894             }
6895              
6896 0         0 # escape $ @ / and \
6897             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
6898             $char[$i] = '\\' . $char[$i];
6899             }
6900 5         13 }
6901              
6902             return join '', $ope, $delimiter, @char, $end_delimiter;
6903             }
6904              
6905             #
6906             # escape regexp (s/here/and here/modifier)
6907 16     97 0 49 #
6908 97   100     977 sub e_sub {
6909             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
6910 97         469 $modifier ||= '';
6911 97 50       199  
6912 97         264 $modifier =~ tr/p//d;
6913 0         0 if ($modifier =~ /([adlu])/oxms) {
6914 0 0       0 my $line = 0;
6915 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
6916 0         0 if ($filename ne __FILE__) {
6917             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
6918             last;
6919 0         0 }
6920             }
6921             die qq{Unsupported modifier "$1" used at line $line.\n};
6922 0 100       0 }
6923 97         237  
6924 36         49 if ($variable eq '') {
6925             $variable = '$_';
6926             $bind_operator = ' =~ ';
6927 36         47 }
6928              
6929             $slash = 'div';
6930              
6931             # P.128 Start of match (or end of previous match): \G
6932             # P.130 Advanced Use of \G with Perl
6933             # in Chapter 3: Overview of Regular Expression Features and Flavors
6934             # P.312 Iterative Matching: Scalar Context, with /g
6935             # in Chapter 7: Perl
6936             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6937              
6938             # P.181 Where You Left Off: The \G Assertion
6939             # in Chapter 5: Pattern Matching
6940             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
6941              
6942             # P.220 Where You Left Off: The \G Assertion
6943             # in Chapter 5: Pattern Matching
6944 97         166 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6945 97         155  
6946             my $e_modifier = $modifier =~ tr/e//d;
6947 97         136 my $r_modifier = $modifier =~ tr/r//d;
6948 97 50       133  
6949 97         244 my $my = '';
6950 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
6951 0         0 $my = $variable;
6952             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
6953             $variable =~ s/ = .+ \z//oxms;
6954 0         0 }
6955 97         223  
6956             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
6957             $variable_basename =~ s/ \s+ \z//oxms;
6958 97         187  
6959 97 100       142 # quote replacement string
6960 97         202 my $e_replacement = '';
6961 17         43 if ($e_modifier >= 1) {
6962             $e_replacement = e_qq('', '', '', $replacement);
6963             $e_modifier--;
6964 17 100       48 }
6965 80         173 else {
6966             if ($delimiter2 eq "'") {
6967             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
6968 16         50 }
6969             else {
6970             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
6971             }
6972 64         154 }
6973              
6974             my $sub = '';
6975 97 100       171  
6976 97 100       248 # with /r
6977             if ($r_modifier) {
6978             if (0) {
6979             }
6980 8         14  
6981 0 50       0 # s///gr without multibyte anchoring
6982             elsif ($modifier =~ /g/oxms) {
6983             $sub = sprintf(
6984             # 1 2 3 4 5
6985             q,
6986              
6987             $variable, # 1
6988             ($delimiter1 eq "'") ? # 2
6989             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
6990             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
6991             $s_matched, # 3
6992             $e_replacement, # 4
6993             '$Etis620::re_r=CORE::eval $Etis620::re_r; ' x $e_modifier, # 5
6994             );
6995             }
6996              
6997             # s///r
6998 4         15 else {
6999              
7000 4 50       13 my $prematch = q{$`};
7001              
7002             $sub = sprintf(
7003             # 1 2 3 4 5 6 7
7004             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Etis620::re_r=%s; %s"%s$Etis620::re_r$'" } : %s>,
7005              
7006             $variable, # 1
7007             ($delimiter1 eq "'") ? # 2
7008             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7009             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7010             $s_matched, # 3
7011             $e_replacement, # 4
7012             '$Etis620::re_r=CORE::eval $Etis620::re_r; ' x $e_modifier, # 5
7013             $prematch, # 6
7014             $variable, # 7
7015             );
7016             }
7017 4 50       13  
7018 8         22 # $var !~ s///r doesn't make sense
7019             if ($bind_operator =~ / !~ /oxms) {
7020             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
7021             }
7022             }
7023              
7024 0 100       0 # without /r
7025             else {
7026             if (0) {
7027             }
7028 89         232  
7029 0 100       0 # s///g without multibyte anchoring
    100          
7030             elsif ($modifier =~ /g/oxms) {
7031             $sub = sprintf(
7032             # 1 2 3 4 5 6 7 8
7033             q,
7034              
7035             $variable, # 1
7036             ($delimiter1 eq "'") ? # 2
7037             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7038             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7039             $s_matched, # 3
7040             $e_replacement, # 4
7041             '$Etis620::re_r=CORE::eval $Etis620::re_r; ' x $e_modifier, # 5
7042             $variable, # 6
7043             $variable, # 7
7044             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
7045             );
7046             }
7047              
7048             # s///
7049 22         89 else {
7050              
7051 67 100       277 my $prematch = q{$`};
    100          
7052              
7053             $sub = sprintf(
7054              
7055             ($bind_operator =~ / =~ /oxms) ?
7056              
7057             # 1 2 3 4 5 6 7 8
7058             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Etis620::re_r=%s; %s%s="%s$Etis620::re_r$'"; 1 } : undef> :
7059              
7060             # 1 2 3 4 5 6 7 8
7061             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Etis620::re_r=%s; %s%s="%s$Etis620::re_r$'"; undef }>,
7062              
7063             $variable, # 1
7064             $bind_operator, # 2
7065             ($delimiter1 eq "'") ? # 3
7066             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
7067             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
7068             $s_matched, # 4
7069             $e_replacement, # 5
7070             '$Etis620::re_r=CORE::eval $Etis620::re_r; ' x $e_modifier, # 6
7071             $variable, # 7
7072             $prematch, # 8
7073             );
7074             }
7075             }
7076 67 50       381  
7077 97         264 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
7078             if ($my ne '') {
7079             $sub = "($my, $sub)[1]";
7080             }
7081 0         0  
7082 97         148 # clear s/// variable
7083             $sub_variable = '';
7084 97         125 $bind_operator = '';
7085              
7086             return $sub;
7087             }
7088              
7089             #
7090             # escape regexp of split qr//
7091 97     74 0 700 #
7092 74   100     863 sub e_split {
7093             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7094 74         489 $modifier ||= '';
7095 74 50       110  
7096 74         324 $modifier =~ tr/p//d;
7097 0         0 if ($modifier =~ /([adlu])/oxms) {
7098 0 0       0 my $line = 0;
7099 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7100 0         0 if ($filename ne __FILE__) {
7101             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7102             last;
7103 0         0 }
7104             }
7105             die qq{Unsupported modifier "$1" used at line $line.\n};
7106 0         0 }
7107              
7108             $slash = 'div';
7109 74 50       164  
7110 74         237 # /b /B modifier
7111             if ($modifier =~ tr/bB//d) {
7112             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7113 0 50       0 }
7114 74         181  
7115             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7116             my $metachar = qr/[\@\\|[\]{^]/oxms;
7117 74         274  
7118             # split regexp
7119             my @char = $string =~ /\G((?>
7120             [^\\\$\@\[\(] |
7121             \\x (?>[0-9A-Fa-f]{1,2}) |
7122             \\ (?>[0-7]{2,3}) |
7123             \\c [\x40-\x5F] |
7124             \\x\{ (?>[0-9A-Fa-f]+) \} |
7125             \\o\{ (?>[0-7]+) \} |
7126             \\[bBNpP]\{ (?>[^0-9\}][^\}]*) \} |
7127             \\ $q_char |
7128             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
7129             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
7130             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
7131             [\$\@] $qq_variable |
7132             \$ (?>\s* [0-9]+) |
7133             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
7134             \$ \$ (?![\w\{]) |
7135             \$ (?>\s*) \$ (?>\s*) $qq_variable |
7136             \[\^ |
7137             \[\: (?>[a-z]+) :\] |
7138             \[\:\^ (?>[a-z]+) :\] |
7139             \(\? |
7140             $q_char
7141 74         9407 ))/oxmsg;
7142 74         258  
7143 74         122 my $left_e = 0;
7144             my $right_e = 0;
7145             for (my $i=0; $i <= $#char; $i++) {
7146 74 50 33     357  
    50 33        
    100          
    100          
    50          
    50          
7147 249         1236 # "\L\u" --> "\u\L"
7148             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
7149             @char[$i,$i+1] = @char[$i+1,$i];
7150             }
7151              
7152 0         0 # "\U\l" --> "\l\U"
7153             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
7154             @char[$i,$i+1] = @char[$i+1,$i];
7155             }
7156              
7157 0         0 # octal escape sequence
7158             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
7159             $char[$i] = Etis620::octchr($1);
7160             }
7161              
7162 1         3 # hexadecimal escape sequence
7163             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
7164             $char[$i] = Etis620::hexchr($1);
7165             }
7166              
7167             # \b{...} --> b\{...}
7168             # \B{...} --> B\{...}
7169             # \N{CHARNAME} --> N\{CHARNAME}
7170             # \p{PROPERTY} --> p\{PROPERTY}
7171 1         5 # \P{PROPERTY} --> P\{PROPERTY}
7172             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
7173             $char[$i] = $1 . '\\' . $2;
7174             }
7175              
7176 0         0 # \p, \P, \X --> p, P, X
7177             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
7178             $char[$i] = $1;
7179 0 50 100     0 }
    100 33        
    50 33        
    100 100        
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
7180              
7181             if (0) {
7182             }
7183 249         817  
7184 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
7185 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
7186             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)) {
7187             $char[$i] .= join '', splice @char, $i+1, 3;
7188 0         0 }
7189             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)) {
7190             $char[$i] .= join '', splice @char, $i+1, 2;
7191 0         0 }
7192             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)) {
7193             $char[$i] .= join '', splice @char, $i+1, 1;
7194             }
7195             }
7196              
7197 0         0 # open character class [...]
7198 3 50       5 elsif ($char[$i] eq '[') {
7199 3         24 my $left = $i;
7200             if ($char[$i+1] eq ']') {
7201 0         0 $i++;
7202 3 50       4 }
7203 7         12 while (1) {
7204             if (++$i > $#char) {
7205 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
7206 7         15 }
7207             if ($char[$i] eq ']') {
7208             my $right = $i;
7209 3 50       5  
7210 3         32 # [...]
  0         0  
7211             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7212             splice @char, $left, $right-$left+1, sprintf(q{@{[Etis620::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7213 0         0 }
7214             else {
7215             splice @char, $left, $right-$left+1, Etis620::charlist_qr(@char[$left+1..$right-1], $modifier);
7216 3         22 }
7217 3         6  
7218             $i = $left;
7219             last;
7220             }
7221             }
7222             }
7223              
7224 3         7 # open character class [^...]
7225 0 0       0 elsif ($char[$i] eq '[^') {
7226 0         0 my $left = $i;
7227             if ($char[$i+1] eq ']') {
7228 0         0 $i++;
7229 0 0       0 }
7230 0         0 while (1) {
7231             if (++$i > $#char) {
7232 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
7233 0         0 }
7234             if ($char[$i] eq ']') {
7235             my $right = $i;
7236 0 0       0  
7237 0         0 # [^...]
  0         0  
7238             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
7239             splice @char, $left, $right-$left+1, sprintf(q{@{[Etis620::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
7240 0         0 }
7241             else {
7242             splice @char, $left, $right-$left+1, Etis620::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7243 0         0 }
7244 0         0  
7245             $i = $left;
7246             last;
7247             }
7248             }
7249             }
7250              
7251 0         0 # rewrite character class or escape character
7252             elsif (my $char = character_class($char[$i],$modifier)) {
7253             $char[$i] = $char;
7254             }
7255              
7256             # P.794 29.2.161. split
7257             # in Chapter 29: Functions
7258             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7259              
7260             # P.951 split
7261             # in Chapter 27: Functions
7262             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7263              
7264             # said "The //m modifier is assumed when you split on the pattern /^/",
7265             # but perl5.008 is not so. Therefore, this software adds //m.
7266             # (and so on)
7267              
7268 1         3 # split(m/^/) --> split(m/^/m)
7269             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7270             $modifier .= 'm';
7271             }
7272              
7273 7 0       26 # /i modifier
7274 0         0 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Etis620::uc($char[$i]) ne Etis620::fc($char[$i]))) {
7275             if (CORE::length(Etis620::fc($char[$i])) == 1) {
7276             $char[$i] = '[' . Etis620::uc($char[$i]) . Etis620::fc($char[$i]) . ']';
7277 0         0 }
7278             else {
7279             $char[$i] = '(?:' . Etis620::uc($char[$i]) . '|' . Etis620::fc($char[$i]) . ')';
7280             }
7281             }
7282              
7283 0 0       0 # \u \l \U \L \F \Q \E
7284 0         0 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
7285             if ($right_e < $left_e) {
7286             $char[$i] = '\\' . $char[$i];
7287             }
7288 0         0 }
7289 0         0 elsif ($char[$i] eq '\u') {
7290             $char[$i] = '@{[Etis620::ucfirst qq<';
7291             $left_e++;
7292 0         0 }
7293 0         0 elsif ($char[$i] eq '\l') {
7294             $char[$i] = '@{[Etis620::lcfirst qq<';
7295             $left_e++;
7296 0         0 }
7297 0         0 elsif ($char[$i] eq '\U') {
7298             $char[$i] = '@{[Etis620::uc qq<';
7299             $left_e++;
7300 0         0 }
7301 0         0 elsif ($char[$i] eq '\L') {
7302             $char[$i] = '@{[Etis620::lc qq<';
7303             $left_e++;
7304 0         0 }
7305 0         0 elsif ($char[$i] eq '\F') {
7306             $char[$i] = '@{[Etis620::fc qq<';
7307             $left_e++;
7308 0         0 }
7309 0         0 elsif ($char[$i] eq '\Q') {
7310             $char[$i] = '@{[CORE::quotemeta qq<';
7311             $left_e++;
7312 0 0       0 }
7313 0         0 elsif ($char[$i] eq '\E') {
7314 0         0 if ($right_e < $left_e) {
7315             $char[$i] = '>]}';
7316             $right_e++;
7317 0         0 }
7318             else {
7319             $char[$i] = '';
7320             }
7321 0         0 }
7322 0 0       0 elsif ($char[$i] eq '\Q') {
7323 0         0 while (1) {
7324             if (++$i > $#char) {
7325 0 0       0 last;
7326 0         0 }
7327             if ($char[$i] eq '\E') {
7328             last;
7329             }
7330             }
7331             }
7332             elsif ($char[$i] eq '\E') {
7333             }
7334              
7335 0 0       0 # $0 --> $0
7336 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
7337             if ($ignorecase) {
7338             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7339             }
7340 0 0       0 }
7341 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
7342             if ($ignorecase) {
7343             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7344             }
7345             }
7346              
7347             # $$ --> $$
7348             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
7349             }
7350              
7351             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7352 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7353 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
7354 0         0 $char[$i] = e_capture($1);
7355             if ($ignorecase) {
7356             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7357             }
7358 0         0 }
7359 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
7360 0         0 $char[$i] = e_capture($1);
7361             if ($ignorecase) {
7362             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7363             }
7364             }
7365              
7366 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7367 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
7368 0         0 $char[$i] = e_capture($1.'->'.$2);
7369             if ($ignorecase) {
7370             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7371             }
7372             }
7373              
7374 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7375 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
7376 0         0 $char[$i] = e_capture($1.'->'.$2);
7377             if ($ignorecase) {
7378             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7379             }
7380             }
7381              
7382 0         0 # $$foo
7383 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
7384 0         0 $char[$i] = e_capture($1);
7385             if ($ignorecase) {
7386             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7387             }
7388             }
7389              
7390 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Etis620::PREMATCH()
7391 12         38 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
7392             if ($ignorecase) {
7393             $char[$i] = '@{[Etis620::ignorecase(Etis620::PREMATCH())]}';
7394 0         0 }
7395             else {
7396             $char[$i] = '@{[Etis620::PREMATCH()]}';
7397             }
7398             }
7399              
7400 12 50       86 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Etis620::MATCH()
7401 12         48 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
7402             if ($ignorecase) {
7403             $char[$i] = '@{[Etis620::ignorecase(Etis620::MATCH())]}';
7404 0         0 }
7405             else {
7406             $char[$i] = '@{[Etis620::MATCH()]}';
7407             }
7408             }
7409              
7410 12 50       56 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Etis620::POSTMATCH()
7411 9         28 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
7412             if ($ignorecase) {
7413             $char[$i] = '@{[Etis620::ignorecase(Etis620::POSTMATCH())]}';
7414 0         0 }
7415             else {
7416             $char[$i] = '@{[Etis620::POSTMATCH()]}';
7417             }
7418             }
7419              
7420 9 0       40 # ${ foo }
7421 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
7422             if ($ignorecase) {
7423             $char[$i] = '@{[Etis620::ignorecase(' . $1 . ')]}';
7424             }
7425             }
7426              
7427 0         0 # ${ ... }
7428 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
7429 0         0 $char[$i] = e_capture($1);
7430             if ($ignorecase) {
7431             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7432             }
7433             }
7434              
7435 0         0 # $scalar or @array
7436 3 50       10 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
7437 3         14 $char[$i] = e_string($char[$i]);
7438             if ($ignorecase) {
7439             $char[$i] = '@{[Etis620::ignorecase(' . $char[$i] . ')]}';
7440             }
7441             }
7442              
7443 0 50       0 # quote character before ? + * {
7444             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7445             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
7446 1         7 }
7447             else {
7448             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7449             }
7450             }
7451             }
7452 0         0  
7453 74 50       143 # make regexp string
7454 74         190 $modifier =~ tr/i//d;
7455             if ($left_e > $right_e) {
7456 0         0 return join '', 'Etis620::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
7457             }
7458             return join '', 'Etis620::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7459             }
7460              
7461             #
7462             # escape regexp of split qr''
7463 74     0 0 762 #
7464 0   0       sub e_split_q {
7465             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
7466 0           $modifier ||= '';
7467 0 0          
7468 0           $modifier =~ tr/p//d;
7469 0           if ($modifier =~ /([adlu])/oxms) {
7470 0 0         my $line = 0;
7471 0           for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
7472 0           if ($filename ne __FILE__) {
7473             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
7474             last;
7475 0           }
7476             }
7477             die qq{Unsupported modifier "$1" used at line $line.\n};
7478 0           }
7479              
7480             $slash = 'div';
7481 0 0          
7482 0           # /b /B modifier
7483             if ($modifier =~ tr/bB//d) {
7484             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
7485 0 0         }
7486              
7487             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
7488 0            
7489             # split regexp
7490             my @char = $string =~ /\G((?>
7491             [^\\\[] |
7492             [\x00-\xFF] |
7493             \[\^ |
7494             \[\: (?>[a-z]+) \:\] |
7495             \[\:\^ (?>[a-z]+) \:\] |
7496             \\ (?:$q_char) |
7497             (?:$q_char)
7498             ))/oxmsg;
7499 0            
7500 0 0 0       # unescape character
    0 0        
    0 0        
    0 0        
    0          
    0          
7501             for (my $i=0; $i <= $#char; $i++) {
7502             if (0) {
7503             }
7504 0            
7505 0           # open character class [...]
7506 0 0         elsif ($char[$i] eq '[') {
7507 0           my $left = $i;
7508             if ($char[$i+1] eq ']') {
7509 0           $i++;
7510 0 0         }
7511 0           while (1) {
7512             if (++$i > $#char) {
7513 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7514 0           }
7515             if ($char[$i] eq ']') {
7516             my $right = $i;
7517 0            
7518             # [...]
7519 0           splice @char, $left, $right-$left+1, Etis620::charlist_qr(@char[$left+1..$right-1], $modifier);
7520 0            
7521             $i = $left;
7522             last;
7523             }
7524             }
7525             }
7526              
7527 0           # open character class [^...]
7528 0 0         elsif ($char[$i] eq '[^') {
7529 0           my $left = $i;
7530             if ($char[$i+1] eq ']') {
7531 0           $i++;
7532 0 0         }
7533 0           while (1) {
7534             if (++$i > $#char) {
7535 0 0         die __FILE__, ": Unmatched [] in regexp\n";
7536 0           }
7537             if ($char[$i] eq ']') {
7538             my $right = $i;
7539 0            
7540             # [^...]
7541 0           splice @char, $left, $right-$left+1, Etis620::charlist_not_qr(@char[$left+1..$right-1], $modifier);
7542 0            
7543             $i = $left;
7544             last;
7545             }
7546             }
7547             }
7548              
7549 0           # rewrite character class or escape character
7550             elsif (my $char = character_class($char[$i],$modifier)) {
7551             $char[$i] = $char;
7552             }
7553              
7554 0           # split(m/^/) --> split(m/^/m)
7555             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
7556             $modifier .= 'm';
7557             }
7558              
7559 0 0         # /i modifier
7560 0           elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Etis620::uc($char[$i]) ne Etis620::fc($char[$i]))) {
7561             if (CORE::length(Etis620::fc($char[$i])) == 1) {
7562             $char[$i] = '[' . Etis620::uc($char[$i]) . Etis620::fc($char[$i]) . ']';
7563 0           }
7564             else {
7565             $char[$i] = '(?:' . Etis620::uc($char[$i]) . '|' . Etis620::fc($char[$i]) . ')';
7566             }
7567             }
7568              
7569 0 0         # quote character before ? + * {
7570             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
7571             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
7572 0           }
7573             else {
7574             $char[$i-1] = '(?:' . $char[$i-1] . ')';
7575             }
7576             }
7577 0           }
7578 0            
7579             $modifier =~ tr/i//d;
7580             return join '', 'Etis620::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
7581             }
7582              
7583             #
7584             # instead of Carp::carp
7585 0     0 0   #
7586 0           sub carp {
7587             my($package,$filename,$line) = caller(1);
7588             print STDERR "@_ at $filename line $line.\n";
7589             }
7590              
7591             #
7592             # instead of Carp::croak
7593 0     0 0   #
7594 0           sub croak {
7595 0           my($package,$filename,$line) = caller(1);
7596             print STDERR "@_ at $filename line $line.\n";
7597             die "\n";
7598             }
7599              
7600             #
7601             # instead of Carp::cluck
7602 0     0 0   #
7603 0           sub cluck {
7604 0           my $i = 0;
7605 0           my @cluck = ();
7606 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7607             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
7608 0           $i++;
7609 0           }
7610 0           print STDERR CORE::reverse @cluck;
7611             print STDERR "\n";
7612             print STDERR @_;
7613             }
7614              
7615             #
7616             # instead of Carp::confess
7617 0     0 0   #
7618 0           sub confess {
7619 0           my $i = 0;
7620 0           my @confess = ();
7621 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
7622             push @confess, "[$i] $filename($line) $package::$subroutine\n";
7623 0           $i++;
7624 0           }
7625 0           print STDERR CORE::reverse @confess;
7626 0           print STDERR "\n";
7627             print STDERR @_;
7628             die "\n";
7629             }
7630              
7631             1;
7632              
7633             __END__