File Coverage

blib/lib/Euhc.pm
Criterion Covered Total %
statement 1204 4691 25.6
branch 1360 4560 29.8
condition 162 496 32.6
subroutine 68 190 35.7
pod 8 148 5.4
total 2802 10085 27.7


line stmt bran cond sub pod time code
1             package Euhc;
2 389     389   12108 use strict;
  389         3079  
  389         17161  
3             ######################################################################
4             #
5             # Euhc - Run-time routines for UHC.pm
6             #
7             # http://search.cpan.org/dist/Char-UHC/
8             #
9             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
10             ######################################################################
11              
12 389     389   8145 use 5.00503; # Galapagos Consensus 1998 for primetools
  389         2930  
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 389     389   3347 use vars qw($VERSION);
  389         2490  
  389         58242  
28             $VERSION = '1.13';
29             $VERSION = $VERSION;
30              
31             BEGIN {
32 389 50   389   3091 if ($^X =~ / jperl /oxmsi) {
33 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
34             }
35 389         4341 if (CORE::ord('A') == 193) {
36             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
37             }
38 389         55879 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 389     389   32225 CORE::eval q{
  389     389   4107  
  389     100   2426  
  389         50163  
  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 389 50       166819 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     1152 0 0 my($name) = @_;
73              
74 1152 50       2956 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
75 1152         4505 return $name;
76             }
77             elsif (Euhc::index($name,'::') >= 0) {
78 0         0 return $name;
79             }
80             elsif (Euhc::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 1152         10580 return (caller)[0] . '::' . $name;
107             }
108             }
109              
110             sub qualify_to_ref ($;$) {
111 0 50   1152 0 0 if (defined $_[1]) {
112 389     389   4491 no strict qw(refs);
  389         760  
  389         29536  
113 1152         3574 return \*{ qualify $_[0], $_[1] };
  0         0  
114             }
115             else {
116 389     389   2365 no strict qw(refs);
  389     0   4076  
  389         71460  
117 0         0 return \*{ qualify $_[0], (caller)[0] };
  1152         1835  
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{[\x81-\xFE][\x00-\xFF]|[\x00-\xFF]};
148 389     389   6038 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  389         4754  
  389         28243  
149 389     389   2589 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  389         2649  
  389         661699  
150              
151             #
152             # UHC character range per length
153             #
154             my %range_tr = ();
155              
156             #
157             # UHC 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 Euhc \z/oxms) {
173             %range_tr = (
174             1 => [ [0x00..0x80],
175             [0xFF..0xFF],
176             ],
177             2 => [ [0x81..0xFE],[0x41..0x5A],
178             [0x81..0xFE],[0x61..0x7A],
179             [0x81..0xFE],[0x81..0xFE],
180             ],
181             );
182             }
183              
184             else {
185             croak "Don't know my package name '@{[__PACKAGE__]}'";
186             }
187              
188             #
189             # @ARGV wildcard globbing
190             #
191             sub import {
192              
193 1152 50   5   6372 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
194 5         91 my @argv = ();
195 0         0 for (@ARGV) {
196              
197             # has space
198 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
199 0 0       0 if (my @glob = Euhc::glob(qq{"$_"})) {
200 0         0 push @argv, @glob;
201             }
202             else {
203 0         0 push @argv, $_;
204             }
205             }
206              
207             # has wildcard metachar
208             elsif (/\A (?:$q_char)*? [*?] /oxms) {
209 0 0       0 if (my @glob = Euhc::glob($_)) {
210 0         0 push @argv, @glob;
211             }
212             else {
213 0         0 push @argv, $_;
214             }
215             }
216              
217             # no wildcard globbing
218             else {
219 0         0 push @argv, $_;
220             }
221             }
222 0         0 @ARGV = @argv;
223             }
224              
225 0         0 *Char::ord = \&UHC::ord;
226 5         27 *Char::ord_ = \&UHC::ord_;
227 5         14 *Char::reverse = \&UHC::reverse;
228 5         13 *Char::getc = \&UHC::getc;
229 5         10 *Char::length = \&UHC::length;
230 5         10 *Char::substr = \&UHC::substr;
231 5         10 *Char::index = \&UHC::index;
232 5         11 *Char::rindex = \&UHC::rindex;
233 5         45 *Char::eval = \&UHC::eval;
234 5         38 *Char::escape = \&UHC::escape;
235 5         12 *Char::escape_token = \&UHC::escape_token;
236 5         11 *Char::escape_script = \&UHC::escape_script;
237             }
238              
239             # P.230 Care with Prototypes
240             # in Chapter 6: Subroutines
241             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
242             #
243             # If you aren't careful, you can get yourself into trouble with prototypes.
244             # But if you are careful, you can do a lot of neat things with them. This is
245             # all very powerful, of course, and should only be used in moderation to make
246             # the world a better place.
247              
248             # P.332 Care with Prototypes
249             # in Chapter 7: Subroutines
250             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
251             #
252             # If you aren't careful, you can get yourself into trouble with prototypes.
253             # But if you are careful, you can do a lot of neat things with them. This is
254             # all very powerful, of course, and should only be used in moderation to make
255             # the world a better place.
256              
257             #
258             # Prototypes of subroutines
259             #
260       0     sub unimport {}
261             sub Euhc::split(;$$$);
262             sub Euhc::tr($$$$;$);
263             sub Euhc::chop(@);
264             sub Euhc::index($$;$);
265             sub Euhc::rindex($$;$);
266             sub Euhc::lcfirst(@);
267             sub Euhc::lcfirst_();
268             sub Euhc::lc(@);
269             sub Euhc::lc_();
270             sub Euhc::ucfirst(@);
271             sub Euhc::ucfirst_();
272             sub Euhc::uc(@);
273             sub Euhc::uc_();
274             sub Euhc::fc(@);
275             sub Euhc::fc_();
276             sub Euhc::ignorecase;
277             sub Euhc::classic_character_class;
278             sub Euhc::capture;
279             sub Euhc::chr(;$);
280             sub Euhc::chr_();
281             sub Euhc::filetest;
282             sub Euhc::r(;*@);
283             sub Euhc::w(;*@);
284             sub Euhc::x(;*@);
285             sub Euhc::o(;*@);
286             sub Euhc::R(;*@);
287             sub Euhc::W(;*@);
288             sub Euhc::X(;*@);
289             sub Euhc::O(;*@);
290             sub Euhc::e(;*@);
291             sub Euhc::z(;*@);
292             sub Euhc::s(;*@);
293             sub Euhc::f(;*@);
294             sub Euhc::d(;*@);
295             sub Euhc::l(;*@);
296             sub Euhc::p(;*@);
297             sub Euhc::S(;*@);
298             sub Euhc::b(;*@);
299             sub Euhc::c(;*@);
300             sub Euhc::u(;*@);
301             sub Euhc::g(;*@);
302             sub Euhc::k(;*@);
303             sub Euhc::T(;*@);
304             sub Euhc::B(;*@);
305             sub Euhc::M(;*@);
306             sub Euhc::A(;*@);
307             sub Euhc::C(;*@);
308             sub Euhc::filetest_;
309             sub Euhc::r_();
310             sub Euhc::w_();
311             sub Euhc::x_();
312             sub Euhc::o_();
313             sub Euhc::R_();
314             sub Euhc::W_();
315             sub Euhc::X_();
316             sub Euhc::O_();
317             sub Euhc::e_();
318             sub Euhc::z_();
319             sub Euhc::s_();
320             sub Euhc::f_();
321             sub Euhc::d_();
322             sub Euhc::l_();
323             sub Euhc::p_();
324             sub Euhc::S_();
325             sub Euhc::b_();
326             sub Euhc::c_();
327             sub Euhc::u_();
328             sub Euhc::g_();
329             sub Euhc::k_();
330             sub Euhc::T_();
331             sub Euhc::B_();
332             sub Euhc::M_();
333             sub Euhc::A_();
334             sub Euhc::C_();
335             sub Euhc::glob($);
336             sub Euhc::glob_();
337             sub Euhc::lstat(*);
338             sub Euhc::lstat_();
339             sub Euhc::opendir(*$);
340             sub Euhc::stat(*);
341             sub Euhc::stat_();
342             sub Euhc::unlink(@);
343             sub Euhc::chdir(;$);
344             sub Euhc::do($);
345             sub Euhc::require(;$);
346             sub Euhc::telldir(*);
347              
348             sub UHC::ord(;$);
349             sub UHC::ord_();
350             sub UHC::reverse(@);
351             sub UHC::getc(;*@);
352             sub UHC::length(;$);
353             sub UHC::substr($$;$$);
354             sub UHC::index($$;$);
355             sub UHC::rindex($$;$);
356             sub UHC::escape(;$);
357              
358             #
359             # Regexp work
360             #
361 389         44488 use vars qw(
362             $re_a
363             $re_t
364             $re_n
365             $re_r
366 389     389   4234 );
  389         4368  
367              
368             #
369             # Character class
370             #
371 389         104368 use vars qw(
372             $dot
373             $dot_s
374             $eD
375             $eS
376             $eW
377             $eH
378             $eV
379             $eR
380             $eN
381             $not_alnum
382             $not_alpha
383             $not_ascii
384             $not_blank
385             $not_cntrl
386             $not_digit
387             $not_graph
388             $not_lower
389             $not_lower_i
390             $not_print
391             $not_punct
392             $not_space
393             $not_upper
394             $not_upper_i
395             $not_word
396             $not_xdigit
397             $eb
398             $eB
399 389     389   4328 );
  389         5255  
400              
401 389         4424847 use vars qw(
402             $anchor
403             $matched
404 389     389   3881 );
  389         672  
405             ${Euhc::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?}oxms;
406             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
407              
408             # Quantifiers
409             # {n,m} --- Match at least n but not more than m times
410             #
411             # n and m are limited to non-negative integral values less than a
412             # preset limit defined when perl is built. This is usually 32766 on
413             # the most common platforms.
414             #
415             # The following code is an attempt to solve the above limitations
416             # in a multi-byte anchoring.
417              
418             # avoid "Segmentation fault" and "Error: Parse exception"
419              
420             # perl5101delta
421             # http://perldoc.perl.org/perl5101delta.html
422             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
423             # [RT #60034, #60464]. For example, this match would fail:
424             # ("ab" x 32768) =~ /^(ab)*$/
425              
426             # SEE ALSO
427             #
428             # Complex regular subexpression recursion limit
429             # http://www.perlmonks.org/?node_id=810857
430             #
431             # regexp iteration limits
432             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
433             #
434             # latest Perl won't match certain regexes more than 32768 characters long
435             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
436             #
437             # Break through the limitations of regular expressions of Perl
438             # http://d.hatena.ne.jp/gfx/20110212/1297512479
439              
440             if (($] >= 5.010001) or
441             # ActivePerl 5.6 or later (include 5.10.0)
442             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
443             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
444             ) {
445             my $sbcs = ''; # Single Byte Character Set
446             for my $range (@{ $range_tr{1} }) {
447             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
448             }
449              
450             if (0) {
451             }
452              
453             # other encoding
454             else {
455             ${Euhc::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
456             # ******* octets not in multiple octet char (always char boundary)
457             # **************** 2 octet chars
458             }
459              
460             ${Euhc::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
461             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Euhc::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
462             # qr{
463             # \G # (1), (2)
464             # (? # (3)
465             # (?=.{0,32766}\z) # (4)
466             # (?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?| # (5)
467             # (?(?=[$sbcs]+\z) # (6)
468             # .*?| #(7)
469             # (?:${Euhc::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
470             # ))}oxms;
471              
472             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
473             local $^W = 0;
474              
475             if (((('A' x 32768).'B') !~ / ${Euhc::anchor} B /oxms) and
476             ((('A' x 32768).'B') =~ / ${Euhc::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
477             ) {
478             ${Euhc::anchor} = ${Euhc::anchor_SADAHIRO_Tomoyuki_2002_01_17};
479             }
480             else {
481             undef ${Euhc::q_char_SADAHIRO_Tomoyuki_2002_01_17};
482             }
483             }
484              
485             # (1)
486             # P.128 Start of match (or end of previous match): \G
487             # P.130 Advanced Use of \G with Perl
488             # in Chapter3: Over view of Regular Expression Features and Flavors
489             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
490              
491             # (2)
492             # P.255 Use leading anchors
493             # P.256 Expose ^ and \G at the front of expressions
494             # in Chapter6: Crafting an Efficient Expression
495             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
496              
497             # (3)
498             # P.138 Conditional: (? if then| else)
499             # in Chapter3: Over view of Regular Expression Features and Flavors
500             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
501              
502             # (4)
503             # perlre
504             # http://perldoc.perl.org/perlre.html
505             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
506             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
507             # integral values less than a preset limit defined when perl is built.
508             # This is usually 32766 on the most common platforms. The actual limit
509             # can be seen in the error message generated by code such as this:
510             # $_ **= $_ , / {$_} / for 2 .. 42;
511              
512             # (5)
513             # P.1023 Multiple-Byte Anchoring
514             # in Appendix W Perl Code Examples
515             # of ISBN 1-56592-224-7 CJKV Information Processing
516              
517             # (6)
518             # if string has only SBCS (Single Byte Character Set)
519              
520             # (7)
521             # then .*? (isn't limited to 32766)
522              
523             # (8)
524             # else UHC::Regexp::Const (SADAHIRO Tomoyuki)
525             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
526             # http://search.cpan.org/~sadahiro/UHC-Regexp/
527             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
528             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
529             # $PadGA = '\G(?:\A|(?:[\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE]{2})*?)';
530              
531             ${Euhc::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
532             ${Euhc::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])};
533             ${Euhc::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][\x00-\xFF])};
534              
535             # Vertical tabs are now whitespace
536             # \s in a regex now matches a vertical tab in all circumstances.
537             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
538             # ${Euhc::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
539             # ${Euhc::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
540             ${Euhc::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][\x00-\xFF])};
541              
542             ${Euhc::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][\x00-\xFF])};
543             ${Euhc::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
544             ${Euhc::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][\x00-\xFF])};
545             ${Euhc::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
546             ${Euhc::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
547             ${Euhc::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
548             ${Euhc::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
549             ${Euhc::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][\x00-\xFF])};
550             ${Euhc::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
551             ${Euhc::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][\x00-\xFF])};
552             ${Euhc::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][\x00-\xFF])};
553             ${Euhc::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][\x00-\xFF])};
554             ${Euhc::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
555             ${Euhc::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
556             # ${Euhc::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
557             ${Euhc::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][\x00-\xFF])};
558             ${Euhc::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][\x00-\xFF])};
559             ${Euhc::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][\x00-\xFF])};
560             ${Euhc::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][\x00-\xFF])};
561             ${Euhc::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
562             # ${Euhc::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
563             ${Euhc::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
564             ${Euhc::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][\x00-\xFF])};
565             ${Euhc::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))};
566             ${Euhc::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]))};
567              
568             # avoid: Name "Euhc::foo" used only once: possible typo at here.
569             ${Euhc::dot} = ${Euhc::dot};
570             ${Euhc::dot_s} = ${Euhc::dot_s};
571             ${Euhc::eD} = ${Euhc::eD};
572             ${Euhc::eS} = ${Euhc::eS};
573             ${Euhc::eW} = ${Euhc::eW};
574             ${Euhc::eH} = ${Euhc::eH};
575             ${Euhc::eV} = ${Euhc::eV};
576             ${Euhc::eR} = ${Euhc::eR};
577             ${Euhc::eN} = ${Euhc::eN};
578             ${Euhc::not_alnum} = ${Euhc::not_alnum};
579             ${Euhc::not_alpha} = ${Euhc::not_alpha};
580             ${Euhc::not_ascii} = ${Euhc::not_ascii};
581             ${Euhc::not_blank} = ${Euhc::not_blank};
582             ${Euhc::not_cntrl} = ${Euhc::not_cntrl};
583             ${Euhc::not_digit} = ${Euhc::not_digit};
584             ${Euhc::not_graph} = ${Euhc::not_graph};
585             ${Euhc::not_lower} = ${Euhc::not_lower};
586             ${Euhc::not_lower_i} = ${Euhc::not_lower_i};
587             ${Euhc::not_print} = ${Euhc::not_print};
588             ${Euhc::not_punct} = ${Euhc::not_punct};
589             ${Euhc::not_space} = ${Euhc::not_space};
590             ${Euhc::not_upper} = ${Euhc::not_upper};
591             ${Euhc::not_upper_i} = ${Euhc::not_upper_i};
592             ${Euhc::not_word} = ${Euhc::not_word};
593             ${Euhc::not_xdigit} = ${Euhc::not_xdigit};
594             ${Euhc::eb} = ${Euhc::eb};
595             ${Euhc::eB} = ${Euhc::eB};
596              
597             #
598             # UHC split
599             #
600             sub Euhc::split(;$$$) {
601              
602             # P.794 29.2.161. split
603             # in Chapter 29: Functions
604             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
605              
606             # P.951 split
607             # in Chapter 27: Functions
608             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
609              
610 5     0 0 12241 my $pattern = $_[0];
611 0         0 my $string = $_[1];
612 0         0 my $limit = $_[2];
613              
614             # if $pattern is also omitted or is the literal space, " "
615 0 0       0 if (not defined $pattern) {
616 0         0 $pattern = ' ';
617             }
618              
619             # if $string is omitted, the function splits the $_ string
620 0 0       0 if (not defined $string) {
621 0 0       0 if (defined $_) {
622 0         0 $string = $_;
623             }
624             else {
625 0         0 $string = '';
626             }
627             }
628              
629 0         0 my @split = ();
630              
631             # when string is empty
632 0 0       0 if ($string eq '') {
    0          
633              
634             # resulting list value in list context
635 0 0       0 if (wantarray) {
636 0         0 return @split;
637             }
638              
639             # count of substrings in scalar context
640             else {
641 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
642 0         0 @_ = @split;
643 0         0 return scalar @_;
644             }
645             }
646              
647             # split's first argument is more consistently interpreted
648             #
649             # After some changes earlier in v5.17, split's behavior has been simplified:
650             # if the PATTERN argument evaluates to a string containing one space, it is
651             # treated the way that a literal string containing one space once was.
652             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
653              
654             # if $pattern is also omitted or is the literal space, " ", the function splits
655             # on whitespace, /\s+/, after skipping any leading whitespace
656             # (and so on)
657              
658             elsif ($pattern eq ' ') {
659 0 0       0 if (not defined $limit) {
660 0         0 return CORE::split(' ', $string);
661             }
662             else {
663 0         0 return CORE::split(' ', $string, $limit);
664             }
665             }
666              
667 0         0 local $q_char = $q_char;
668 0 0       0 if (CORE::length($string) > 32766) {
669 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
670 0         0 $q_char = qr{.}s;
671             }
672             elsif (defined ${Euhc::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
673 0         0 $q_char = ${Euhc::q_char_SADAHIRO_Tomoyuki_2002_01_17};
674             }
675             }
676              
677             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
678 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
679              
680             # a pattern capable of matching either the null string or something longer than the
681             # null string will split the value of $string into separate characters wherever it
682             # matches the null string between characters
683             # (and so on)
684              
685 0 0       0 if ('' =~ / \A $pattern \z /xms) {
686 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
687 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
688              
689             # P.1024 Appendix W.10 Multibyte Processing
690             # of ISBN 1-56592-224-7 CJKV Information Processing
691             # (and so on)
692              
693             # the //m modifier is assumed when you split on the pattern /^/
694             # (and so on)
695              
696             # V
697 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
698              
699             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
700             # is included in the resulting list, interspersed with the fields that are ordinarily returned
701             # (and so on)
702              
703 0         0 local $@;
704 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
705 0         0 push @split, CORE::eval('$' . $digit);
706             }
707             }
708             }
709              
710             else {
711 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
712              
713             # V
714 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
715 0         0 local $@;
716 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
717 0         0 push @split, CORE::eval('$' . $digit);
718             }
719             }
720             }
721             }
722              
723             elsif ($limit > 0) {
724 0 0       0 if ('' =~ / \A $pattern \z /xms) {
725 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
726 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
727              
728             # V
729 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
730 0         0 local $@;
731 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
732 0         0 push @split, CORE::eval('$' . $digit);
733             }
734             }
735             }
736             }
737             else {
738 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
739 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
740              
741             # V
742 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
743 0         0 local $@;
744 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
745 0         0 push @split, CORE::eval('$' . $digit);
746             }
747             }
748             }
749             }
750             }
751              
752 0 0       0 if (CORE::length($string) > 0) {
753 0         0 push @split, $string;
754             }
755              
756             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
757 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
758 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
759 0         0 pop @split;
760             }
761             }
762              
763             # resulting list value in list context
764 0 0       0 if (wantarray) {
765 0         0 return @split;
766             }
767              
768             # count of substrings in scalar context
769             else {
770 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
771 0         0 @_ = @split;
772 0         0 return scalar @_;
773             }
774             }
775              
776             #
777             # get last subexpression offsets
778             #
779             sub _last_subexpression_offsets {
780 0     0   0 my $pattern = $_[0];
781              
782             # remove comment
783 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
784              
785 0         0 my $modifier = '';
786 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
787 0         0 $modifier = $1;
788 0         0 $modifier =~ s/-[A-Za-z]*//;
789             }
790              
791             # with /x modifier
792 0         0 my @char = ();
793 0 0       0 if ($modifier =~ /x/oxms) {
794 0         0 @char = $pattern =~ /\G((?>
795             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][\x00-\xFF] |
796             \\ $q_char |
797             \# (?>[^\n]*) $ |
798             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
799             \(\? |
800             $q_char
801             ))/oxmsg;
802             }
803              
804             # without /x modifier
805             else {
806 0         0 @char = $pattern =~ /\G((?>
807             [^\x81-\xFE\\\[\(]|[\x81-\xFE][\x00-\xFF] |
808             \\ $q_char |
809             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
810             \(\? |
811             $q_char
812             ))/oxmsg;
813             }
814              
815 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
816             }
817              
818             #
819             # UHC transliteration (tr///)
820             #
821             sub Euhc::tr($$$$;$) {
822              
823 0     0 0 0 my $bind_operator = $_[1];
824 0         0 my $searchlist = $_[2];
825 0         0 my $replacementlist = $_[3];
826 0   0     0 my $modifier = $_[4] || '';
827              
828 0 0       0 if ($modifier =~ /r/oxms) {
829 0 0       0 if ($bind_operator =~ / !~ /oxms) {
830 0         0 croak "Using !~ with tr///r doesn't make sense";
831             }
832             }
833              
834 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
835 0         0 my @searchlist = _charlist_tr($searchlist);
836 0         0 my @replacementlist = _charlist_tr($replacementlist);
837              
838 0         0 my %tr = ();
839 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
840 0 0       0 if (not exists $tr{$searchlist[$i]}) {
841 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
842 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
843             }
844             elsif ($modifier =~ /d/oxms) {
845 0         0 $tr{$searchlist[$i]} = '';
846             }
847             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
848 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
849             }
850             else {
851 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
852             }
853             }
854             }
855              
856 0         0 my $tr = 0;
857 0         0 my $replaced = '';
858 0 0       0 if ($modifier =~ /c/oxms) {
859 0         0 while (defined(my $char = shift @char)) {
860 0 0       0 if (not exists $tr{$char}) {
861 0 0       0 if (defined $replacementlist[0]) {
862 0         0 $replaced .= $replacementlist[0];
863             }
864 0         0 $tr++;
865 0 0       0 if ($modifier =~ /s/oxms) {
866 0   0     0 while (@char and (not exists $tr{$char[0]})) {
867 0         0 shift @char;
868 0         0 $tr++;
869             }
870             }
871             }
872             else {
873 0         0 $replaced .= $char;
874             }
875             }
876             }
877             else {
878 0         0 while (defined(my $char = shift @char)) {
879 0 0       0 if (exists $tr{$char}) {
880 0         0 $replaced .= $tr{$char};
881 0         0 $tr++;
882 0 0       0 if ($modifier =~ /s/oxms) {
883 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
884 0         0 shift @char;
885 0         0 $tr++;
886             }
887             }
888             }
889             else {
890 0         0 $replaced .= $char;
891             }
892             }
893             }
894              
895 0 0       0 if ($modifier =~ /r/oxms) {
896 0         0 return $replaced;
897             }
898             else {
899 0         0 $_[0] = $replaced;
900 0 0       0 if ($bind_operator =~ / !~ /oxms) {
901 0         0 return not $tr;
902             }
903             else {
904 0         0 return $tr;
905             }
906             }
907             }
908              
909             #
910             # UHC chop
911             #
912             sub Euhc::chop(@) {
913              
914 0     0 0 0 my $chop;
915 0 0       0 if (@_ == 0) {
916 0         0 my @char = /\G (?>$q_char) /oxmsg;
917 0         0 $chop = pop @char;
918 0         0 $_ = join '', @char;
919             }
920             else {
921 0         0 for (@_) {
922 0         0 my @char = /\G (?>$q_char) /oxmsg;
923 0         0 $chop = pop @char;
924 0         0 $_ = join '', @char;
925             }
926             }
927 0         0 return $chop;
928             }
929              
930             #
931             # UHC index by octet
932             #
933             sub Euhc::index($$;$) {
934              
935 0     2304 1 0 my($str,$substr,$position) = @_;
936 2304   50     5029 $position ||= 0;
937 2304         8571 my $pos = 0;
938              
939 2304         3389 while ($pos < CORE::length($str)) {
940 2304 50       5222 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
941 49308 0       74682 if ($pos >= $position) {
942 0         0 return $pos;
943             }
944             }
945 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
946 49308         127875 $pos += CORE::length($1);
947             }
948             else {
949 49308         84550 $pos += 1;
950             }
951             }
952 0         0 return -1;
953             }
954              
955             #
956             # UHC reverse index
957             #
958             sub Euhc::rindex($$;$) {
959              
960 2304     0 0 13346 my($str,$substr,$position) = @_;
961 0   0     0 $position ||= CORE::length($str) - 1;
962 0         0 my $pos = 0;
963 0         0 my $rindex = -1;
964              
965 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
966 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
967 0         0 $rindex = $pos;
968             }
969 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
970 0         0 $pos += CORE::length($1);
971             }
972             else {
973 0         0 $pos += 1;
974             }
975             }
976 0         0 return $rindex;
977             }
978              
979             #
980             # UHC lower case first with parameter
981             #
982             sub Euhc::lcfirst(@) {
983 0 0   0 0 0 if (@_) {
984 0         0 my $s = shift @_;
985 0 0 0     0 if (@_ and wantarray) {
986 0         0 return Euhc::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
987             }
988             else {
989 0         0 return Euhc::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
990             }
991             }
992             else {
993 0         0 return Euhc::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
994             }
995             }
996              
997             #
998             # UHC lower case first without parameter
999             #
1000             sub Euhc::lcfirst_() {
1001 0     0 0 0 return Euhc::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1002             }
1003              
1004             #
1005             # UHC lower case with parameter
1006             #
1007             sub Euhc::lc(@) {
1008 0 0   0 0 0 if (@_) {
1009 0         0 my $s = shift @_;
1010 0 0 0     0 if (@_ and wantarray) {
1011 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1012             }
1013             else {
1014 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1015             }
1016             }
1017             else {
1018 0         0 return Euhc::lc_();
1019             }
1020             }
1021              
1022             #
1023             # UHC lower case without parameter
1024             #
1025             sub Euhc::lc_() {
1026 0     0 0 0 my $s = $_;
1027 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1028             }
1029              
1030             #
1031             # UHC upper case first with parameter
1032             #
1033             sub Euhc::ucfirst(@) {
1034 0 0   0 0 0 if (@_) {
1035 0         0 my $s = shift @_;
1036 0 0 0     0 if (@_ and wantarray) {
1037 0         0 return Euhc::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1038             }
1039             else {
1040 0         0 return Euhc::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1041             }
1042             }
1043             else {
1044 0         0 return Euhc::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1045             }
1046             }
1047              
1048             #
1049             # UHC upper case first without parameter
1050             #
1051             sub Euhc::ucfirst_() {
1052 0     0 0 0 return Euhc::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1053             }
1054              
1055             #
1056             # UHC upper case with parameter
1057             #
1058             sub Euhc::uc(@) {
1059 0 50   2968 0 0 if (@_) {
1060 2968         4108 my $s = shift @_;
1061 2968 50 33     3505 if (@_ and wantarray) {
1062 2968 0       4972 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1063             }
1064             else {
1065 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         8277  
1066             }
1067             }
1068             else {
1069 2968         9720 return Euhc::uc_();
1070             }
1071             }
1072              
1073             #
1074             # UHC upper case without parameter
1075             #
1076             sub Euhc::uc_() {
1077 0     0 0 0 my $s = $_;
1078 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1079             }
1080              
1081             #
1082             # UHC fold case with parameter
1083             #
1084             sub Euhc::fc(@) {
1085 0 50   3271 0 0 if (@_) {
1086 3271         4380 my $s = shift @_;
1087 3271 50 33     3562 if (@_ and wantarray) {
1088 3271 0       5404 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1089             }
1090             else {
1091 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         7733  
1092             }
1093             }
1094             else {
1095 3271         11907 return Euhc::fc_();
1096             }
1097             }
1098              
1099             #
1100             # UHC fold case without parameter
1101             #
1102             sub Euhc::fc_() {
1103 0     0 0 0 my $s = $_;
1104 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1105             }
1106              
1107             #
1108             # UHC regexp capture
1109             #
1110             {
1111             # 10.3. Creating Persistent Private Variables
1112             # in Chapter 10. Subroutines
1113             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1114              
1115             my $last_s_matched = 0;
1116              
1117             sub Euhc::capture {
1118 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1119 0         0 return $_[0] + 1;
1120             }
1121 0         0 return $_[0];
1122             }
1123              
1124             # UHC mark last regexp matched
1125             sub Euhc::matched() {
1126 0     0 0 0 $last_s_matched = 0;
1127             }
1128              
1129             # UHC mark last s/// matched
1130             sub Euhc::s_matched() {
1131 0     0 0 0 $last_s_matched = 1;
1132             }
1133              
1134             # P.854 31.17. use re
1135             # in Chapter 31. Pragmatic Modules
1136             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1137              
1138             # P.1026 re
1139             # in Chapter 29. Pragmatic Modules
1140             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1141              
1142             $Euhc::matched = qr/(?{Euhc::matched})/;
1143             }
1144              
1145             #
1146             # UHC regexp ignore case modifier
1147             #
1148             sub Euhc::ignorecase {
1149              
1150 0     0 0 0 my @string = @_;
1151 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1152              
1153             # ignore case of $scalar or @array
1154 0         0 for my $string (@string) {
1155              
1156             # split regexp
1157 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1158              
1159             # unescape character
1160 0         0 for (my $i=0; $i <= $#char; $i++) {
1161 0 0       0 next if not defined $char[$i];
1162              
1163             # open character class [...]
1164 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1165 0         0 my $left = $i;
1166              
1167             # [] make die "unmatched [] in regexp ...\n"
1168              
1169 0 0       0 if ($char[$i+1] eq ']') {
1170 0         0 $i++;
1171             }
1172              
1173 0         0 while (1) {
1174 0 0       0 if (++$i > $#char) {
1175 0         0 croak "Unmatched [] in regexp";
1176             }
1177 0 0       0 if ($char[$i] eq ']') {
1178 0         0 my $right = $i;
1179 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1180              
1181             # escape character
1182 0         0 for my $char (@charlist) {
1183 0 0       0 if (0) {
    0          
1184             }
1185              
1186             # do not use quotemeta here
1187 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1188 0         0 $char = $1 . '\\' . $2;
1189             }
1190             elsif ($char =~ /\A [.|)] \z/oxms) {
1191 0         0 $char = '\\' . $char;
1192             }
1193             }
1194              
1195             # [...]
1196 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1197              
1198 0         0 $i = $left;
1199 0         0 last;
1200             }
1201             }
1202             }
1203              
1204             # open character class [^...]
1205             elsif ($char[$i] eq '[^') {
1206 0         0 my $left = $i;
1207              
1208             # [^] make die "unmatched [] in regexp ...\n"
1209              
1210 0 0       0 if ($char[$i+1] eq ']') {
1211 0         0 $i++;
1212             }
1213              
1214 0         0 while (1) {
1215 0 0       0 if (++$i > $#char) {
1216 0         0 croak "Unmatched [] in regexp";
1217             }
1218 0 0       0 if ($char[$i] eq ']') {
1219 0         0 my $right = $i;
1220 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1221              
1222             # escape character
1223 0         0 for my $char (@charlist) {
1224 0 0       0 if (0) {
    0          
1225             }
1226              
1227             # do not use quotemeta here
1228 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1229 0         0 $char = $1 . '\\' . $2;
1230             }
1231             elsif ($char =~ /\A [.|)] \z/oxms) {
1232 0         0 $char = '\\' . $char;
1233             }
1234             }
1235              
1236             # [^...]
1237 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1238              
1239 0         0 $i = $left;
1240 0         0 last;
1241             }
1242             }
1243             }
1244              
1245             # rewrite classic character class or escape character
1246             elsif (my $char = classic_character_class($char[$i])) {
1247 0         0 $char[$i] = $char;
1248             }
1249              
1250             # with /i modifier
1251             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1252 0         0 my $uc = Euhc::uc($char[$i]);
1253 0         0 my $fc = Euhc::fc($char[$i]);
1254 0 0       0 if ($uc ne $fc) {
1255 0 0       0 if (CORE::length($fc) == 1) {
1256 0         0 $char[$i] = '[' . $uc . $fc . ']';
1257             }
1258             else {
1259 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1260             }
1261             }
1262             }
1263             }
1264              
1265             # characterize
1266 0         0 for (my $i=0; $i <= $#char; $i++) {
1267 0 0       0 next if not defined $char[$i];
1268              
1269 0 0 0     0 if (0) {
    0          
1270             }
1271              
1272             # escape last octet of multiple-octet
1273 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1274 0         0 $char[$i] = $1 . '\\' . $2;
1275             }
1276              
1277             # quote character before ? + * {
1278             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1279 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1280 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1281             }
1282             }
1283             }
1284              
1285 0         0 $string = join '', @char;
1286             }
1287              
1288             # make regexp string
1289 0         0 return @string;
1290             }
1291              
1292             #
1293             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1294             #
1295             sub Euhc::classic_character_class {
1296 0     5319 0 0 my($char) = @_;
1297              
1298             return {
1299             '\D' => '${Euhc::eD}',
1300             '\S' => '${Euhc::eS}',
1301             '\W' => '${Euhc::eW}',
1302             '\d' => '[0-9]',
1303              
1304             # Before Perl 5.6, \s only matched the five whitespace characters
1305             # tab, newline, form-feed, carriage return, and the space character
1306             # itself, which, taken together, is the character class [\t\n\f\r ].
1307              
1308             # Vertical tabs are now whitespace
1309             # \s in a regex now matches a vertical tab in all circumstances.
1310             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1311             # \t \n \v \f \r space
1312             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1313             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1314             '\s' => '\s',
1315              
1316             '\w' => '[0-9A-Z_a-z]',
1317             '\C' => '[\x00-\xFF]',
1318             '\X' => 'X',
1319              
1320             # \h \v \H \V
1321              
1322             # P.114 Character Class Shortcuts
1323             # in Chapter 7: In the World of Regular Expressions
1324             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1325              
1326             # P.357 13.2.3 Whitespace
1327             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1328             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1329             #
1330             # 0x00009 CHARACTER TABULATION h s
1331             # 0x0000a LINE FEED (LF) vs
1332             # 0x0000b LINE TABULATION v
1333             # 0x0000c FORM FEED (FF) vs
1334             # 0x0000d CARRIAGE RETURN (CR) vs
1335             # 0x00020 SPACE h s
1336              
1337             # P.196 Table 5-9. Alphanumeric regex metasymbols
1338             # in Chapter 5. Pattern Matching
1339             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1340              
1341             # (and so on)
1342              
1343             '\H' => '${Euhc::eH}',
1344             '\V' => '${Euhc::eV}',
1345             '\h' => '[\x09\x20]',
1346             '\v' => '[\x0A\x0B\x0C\x0D]',
1347             '\R' => '${Euhc::eR}',
1348              
1349             # \N
1350             #
1351             # http://perldoc.perl.org/perlre.html
1352             # Character Classes and other Special Escapes
1353             # Any character but \n (experimental). Not affected by /s modifier
1354              
1355             '\N' => '${Euhc::eN}',
1356              
1357             # \b \B
1358              
1359             # P.180 Boundaries: The \b and \B Assertions
1360             # in Chapter 5: Pattern Matching
1361             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1362              
1363             # P.219 Boundaries: The \b and \B Assertions
1364             # in Chapter 5: Pattern Matching
1365             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1366              
1367             # \b really means (?:(?<=\w)(?!\w)|(?
1368             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1369             '\b' => '${Euhc::eb}',
1370              
1371             # \B really means (?:(?<=\w)(?=\w)|(?
1372             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1373             '\B' => '${Euhc::eB}',
1374              
1375 5319   100     7457 }->{$char} || '';
1376             }
1377              
1378             #
1379             # prepare UHC characters per length
1380             #
1381              
1382             # 1 octet characters
1383             my @chars1 = ();
1384             sub chars1 {
1385 5319 0   0 0 175086 if (@chars1) {
1386 0         0 return @chars1;
1387             }
1388 0 0       0 if (exists $range_tr{1}) {
1389 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1390 0         0 while (my @range = splice(@ranges,0,1)) {
1391 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1392 0         0 push @chars1, pack 'C', $oct0;
1393             }
1394             }
1395             }
1396 0         0 return @chars1;
1397             }
1398              
1399             # 2 octets characters
1400             my @chars2 = ();
1401             sub chars2 {
1402 0 0   0 0 0 if (@chars2) {
1403 0         0 return @chars2;
1404             }
1405 0 0       0 if (exists $range_tr{2}) {
1406 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1407 0         0 while (my @range = splice(@ranges,0,2)) {
1408 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1409 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1410 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1411             }
1412             }
1413             }
1414             }
1415 0         0 return @chars2;
1416             }
1417              
1418             # 3 octets characters
1419             my @chars3 = ();
1420             sub chars3 {
1421 0 0   0 0 0 if (@chars3) {
1422 0         0 return @chars3;
1423             }
1424 0 0       0 if (exists $range_tr{3}) {
1425 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1426 0         0 while (my @range = splice(@ranges,0,3)) {
1427 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1428 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1429 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1430 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1431             }
1432             }
1433             }
1434             }
1435             }
1436 0         0 return @chars3;
1437             }
1438              
1439             # 4 octets characters
1440             my @chars4 = ();
1441             sub chars4 {
1442 0 0   0 0 0 if (@chars4) {
1443 0         0 return @chars4;
1444             }
1445 0 0       0 if (exists $range_tr{4}) {
1446 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1447 0         0 while (my @range = splice(@ranges,0,4)) {
1448 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1449 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1450 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1451 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1452 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1453             }
1454             }
1455             }
1456             }
1457             }
1458             }
1459 0         0 return @chars4;
1460             }
1461              
1462             #
1463             # UHC open character list for tr
1464             #
1465             sub _charlist_tr {
1466              
1467 0     0   0 local $_ = shift @_;
1468              
1469             # unescape character
1470 0         0 my @char = ();
1471 0         0 while (not /\G \z/oxmsgc) {
1472 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1473 0         0 push @char, '\-';
1474             }
1475             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1476 0         0 push @char, CORE::chr(oct $1);
1477             }
1478             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1479 0         0 push @char, CORE::chr(hex $1);
1480             }
1481             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1482 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1483             }
1484             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1485             push @char, {
1486             '\0' => "\0",
1487             '\n' => "\n",
1488             '\r' => "\r",
1489             '\t' => "\t",
1490             '\f' => "\f",
1491             '\b' => "\x08", # \b means backspace in character class
1492             '\a' => "\a",
1493             '\e' => "\e",
1494 0         0 }->{$1};
1495             }
1496             elsif (/\G \\ ($q_char) /oxmsgc) {
1497 0         0 push @char, $1;
1498             }
1499             elsif (/\G ($q_char) /oxmsgc) {
1500 0         0 push @char, $1;
1501             }
1502             }
1503              
1504             # join separated multiple-octet
1505 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1506              
1507             # unescape '-'
1508 0         0 my @i = ();
1509 0         0 for my $i (0 .. $#char) {
1510 0 0       0 if ($char[$i] eq '\-') {
    0          
1511 0         0 $char[$i] = '-';
1512             }
1513             elsif ($char[$i] eq '-') {
1514 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1515 0         0 push @i, $i;
1516             }
1517             }
1518             }
1519              
1520             # open character list (reverse for splice)
1521 0         0 for my $i (CORE::reverse @i) {
1522 0         0 my @range = ();
1523              
1524             # range error
1525 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1526 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1527             }
1528              
1529             # range of multiple-octet code
1530 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1531 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1532 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1533             }
1534             elsif (CORE::length($char[$i+1]) == 2) {
1535 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1536 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1537             }
1538             elsif (CORE::length($char[$i+1]) == 3) {
1539 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1540 0         0 push @range, chars2();
1541 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1542             }
1543             elsif (CORE::length($char[$i+1]) == 4) {
1544 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1545 0         0 push @range, chars2();
1546 0         0 push @range, chars3();
1547 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1548             }
1549             else {
1550 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1551             }
1552             }
1553             elsif (CORE::length($char[$i-1]) == 2) {
1554 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1555 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1556             }
1557             elsif (CORE::length($char[$i+1]) == 3) {
1558 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1559 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1560             }
1561             elsif (CORE::length($char[$i+1]) == 4) {
1562 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1563 0         0 push @range, chars3();
1564 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1565             }
1566             else {
1567 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1568             }
1569             }
1570             elsif (CORE::length($char[$i-1]) == 3) {
1571 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1572 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1573             }
1574             elsif (CORE::length($char[$i+1]) == 4) {
1575 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1576 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1577             }
1578             else {
1579 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1580             }
1581             }
1582             elsif (CORE::length($char[$i-1]) == 4) {
1583 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1584 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1585             }
1586             else {
1587 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1588             }
1589             }
1590             else {
1591 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1592             }
1593              
1594 0         0 splice @char, $i-1, 3, @range;
1595             }
1596              
1597 0         0 return @char;
1598             }
1599              
1600             #
1601             # UHC open character class
1602             #
1603             sub _cc {
1604 0 50   906   0 if (scalar(@_) == 0) {
    100          
    50          
1605 906         1841 die __FILE__, ": subroutine cc got no parameter.\n";
1606             }
1607             elsif (scalar(@_) == 1) {
1608 0         0 return sprintf('\x%02X',$_[0]);
1609             }
1610             elsif (scalar(@_) == 2) {
1611 453 50       1344 if ($_[0] > $_[1]) {
    50          
    50          
1612 453         1039 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1613             }
1614             elsif ($_[0] == $_[1]) {
1615 0         0 return sprintf('\x%02X',$_[0]);
1616             }
1617             elsif (($_[0]+1) == $_[1]) {
1618 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1619             }
1620             else {
1621 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1622             }
1623             }
1624             else {
1625 453         2154 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1626             }
1627             }
1628              
1629             #
1630             # UHC octet range
1631             #
1632             sub _octets {
1633 0     799   0 my $length = shift @_;
1634              
1635 799 100       1256 if ($length == 1) {
    50          
    0          
    0          
1636 799         1601 my($a1) = unpack 'C', $_[0];
1637 406         1203 my($z1) = unpack 'C', $_[1];
1638              
1639 406 50       759 if ($a1 > $z1) {
1640 406         856 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1641             }
1642              
1643 0 100       0 if ($a1 == $z1) {
    50          
1644 406         1062 return sprintf('\x%02X',$a1);
1645             }
1646             elsif (($a1+1) == $z1) {
1647 20         90 return sprintf('\x%02X\x%02X',$a1,$z1);
1648             }
1649             else {
1650 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1651             }
1652             }
1653             elsif ($length == 2) {
1654 386         2677 my($a1,$a2) = unpack 'CC', $_[0];
1655 393         836 my($z1,$z2) = unpack 'CC', $_[1];
1656 393         627 my($A1,$A2) = unpack 'CC', $_[2];
1657 393         589 my($Z1,$Z2) = unpack 'CC', $_[3];
1658              
1659 393 100       561 if ($a1 == $z1) {
    50          
1660             return (
1661             # 11111111 222222222222
1662             # A A Z
1663 393         595 _cc($a1) . _cc($a2,$z2), # a2-z2
1664             );
1665             }
1666             elsif (($a1+1) == $z1) {
1667             return (
1668             # 11111111111 222222222222
1669             # A Z A Z
1670 333         482 _cc($a1) . _cc($a2,$Z2), # a2-
1671             _cc( $z1) . _cc($A2,$z2), # -z2
1672             );
1673             }
1674             else {
1675             return (
1676             # 1111111111111111 222222222222
1677             # A Z A Z
1678 60         101 _cc($a1) . _cc($a2,$Z2), # a2-
1679             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1680             _cc( $z1) . _cc($A2,$z2), # -z2
1681             );
1682             }
1683             }
1684             elsif ($length == 3) {
1685 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1686 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1687 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1688 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1689              
1690 0 0       0 if ($a1 == $z1) {
    0          
1691 0 0       0 if ($a2 == $z2) {
    0          
1692             return (
1693             # 11111111 22222222 333333333333
1694             # A A A Z
1695 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1696             );
1697             }
1698             elsif (($a2+1) == $z2) {
1699             return (
1700             # 11111111 22222222222 333333333333
1701             # A A Z A Z
1702 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1703             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1704             );
1705             }
1706             else {
1707             return (
1708             # 11111111 2222222222222222 333333333333
1709             # A A Z A Z
1710 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1711             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1712             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1713             );
1714             }
1715             }
1716             elsif (($a1+1) == $z1) {
1717             return (
1718             # 11111111111 22222222222222 333333333333
1719             # A Z A Z A Z
1720 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1721             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1722             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1723             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1724             );
1725             }
1726             else {
1727             return (
1728             # 1111111111111111 22222222222222 333333333333
1729             # A Z A Z A Z
1730 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1731             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1732             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1733             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1734             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1735             );
1736             }
1737             }
1738             elsif ($length == 4) {
1739 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1740 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1741 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1742 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1743              
1744 0 0       0 if ($a1 == $z1) {
    0          
1745 0 0       0 if ($a2 == $z2) {
    0          
1746 0 0       0 if ($a3 == $z3) {
    0          
1747             return (
1748             # 11111111 22222222 33333333 444444444444
1749             # A A A A Z
1750 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1751             );
1752             }
1753             elsif (($a3+1) == $z3) {
1754             return (
1755             # 11111111 22222222 33333333333 444444444444
1756             # A A A Z A Z
1757 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1758             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1759             );
1760             }
1761             else {
1762             return (
1763             # 11111111 22222222 3333333333333333 444444444444
1764             # A A A Z A Z
1765 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1766             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1767             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1768             );
1769             }
1770             }
1771             elsif (($a2+1) == $z2) {
1772             return (
1773             # 11111111 22222222222 33333333333333 444444444444
1774             # A A Z A Z A Z
1775 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1776             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1777             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1778             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1779             );
1780             }
1781             else {
1782             return (
1783             # 11111111 2222222222222222 33333333333333 444444444444
1784             # A A Z A Z A Z
1785 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1786             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1787             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1788             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1789             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1790             );
1791             }
1792             }
1793             elsif (($a1+1) == $z1) {
1794             return (
1795             # 11111111111 22222222222222 33333333333333 444444444444
1796             # A Z A Z A Z A Z
1797 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1798             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1799             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1800             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1801             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1802             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1803             );
1804             }
1805             else {
1806             return (
1807             # 1111111111111111 22222222222222 33333333333333 444444444444
1808             # A Z A Z A Z A Z
1809 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1810             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1811             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1812             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1813             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1814             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1815             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1816             );
1817             }
1818             }
1819             else {
1820 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1821             }
1822             }
1823              
1824             #
1825             # UHC range regexp
1826             #
1827             sub _range_regexp {
1828 0     517   0 my($length,$first,$last) = @_;
1829              
1830 517         1156 my @range_regexp = ();
1831 517 50       852 if (not exists $range_tr{$length}) {
1832 517         1346 return @range_regexp;
1833             }
1834              
1835 0         0 my @ranges = @{ $range_tr{$length} };
  517         691  
1836 517         1306 while (my @range = splice(@ranges,0,$length)) {
1837 517         1663 my $min = '';
1838 1165         1658 my $max = '';
1839 1165         1357 for (my $i=0; $i < $length; $i++) {
1840 1165         2157 $min .= pack 'C', $range[$i][0];
1841 1558         3490 $max .= pack 'C', $range[$i][-1];
1842             }
1843              
1844             # min___max
1845             # FIRST_____________LAST
1846             # (nothing)
1847              
1848 1558 50 66     3095 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1849             }
1850              
1851             # **********
1852             # min_________max
1853             # FIRST_____________LAST
1854             # **********
1855              
1856             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1857 1165         9821 push @range_regexp, _octets($length,$first,$max,$min,$max);
1858             }
1859              
1860             # **********************
1861             # min________________max
1862             # FIRST_____________LAST
1863             # **********************
1864              
1865             elsif (($min eq $first) and ($max eq $last)) {
1866 20         49 push @range_regexp, _octets($length,$first,$last,$min,$max);
1867             }
1868              
1869             # *********
1870             # min___max
1871             # FIRST_____________LAST
1872             # *********
1873              
1874             elsif (($first le $min) and ($max le $last)) {
1875 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1876             }
1877              
1878             # **********************
1879             # min__________________________max
1880             # FIRST_____________LAST
1881             # **********************
1882              
1883             elsif (($min le $first) and ($last le $max)) {
1884 20         44 push @range_regexp, _octets($length,$first,$last,$min,$max);
1885             }
1886              
1887             # *********
1888             # min________max
1889             # FIRST_____________LAST
1890             # *********
1891              
1892             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1893 699         1564 push @range_regexp, _octets($length,$min,$last,$min,$max);
1894             }
1895              
1896             # min___max
1897             # FIRST_____________LAST
1898             # (nothing)
1899              
1900             elsif ($last lt $min) {
1901             }
1902              
1903             else {
1904 60         96 die __FILE__, ": subroutine _range_regexp panic.\n";
1905             }
1906             }
1907              
1908 0         0 return @range_regexp;
1909             }
1910              
1911             #
1912             # UHC open character list for qr and not qr
1913             #
1914             sub _charlist {
1915              
1916 517     758   1246 my $modifier = pop @_;
1917 758         1199 my @char = @_;
1918              
1919 758 100       1856 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1920              
1921             # unescape character
1922 758         1854 for (my $i=0; $i <= $#char; $i++) {
1923              
1924             # escape - to ...
1925 758 100 100     2537 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1926 2648 100 100     18841 if ((0 < $i) and ($i < $#char)) {
1927 522         2065 $char[$i] = '...';
1928             }
1929             }
1930              
1931             # octal escape sequence
1932             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1933 497         1058 $char[$i] = octchr($1);
1934             }
1935              
1936             # hexadecimal escape sequence
1937             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1938 0         0 $char[$i] = hexchr($1);
1939             }
1940              
1941             # \b{...} --> b\{...}
1942             # \B{...} --> B\{...}
1943             # \N{CHARNAME} --> N\{CHARNAME}
1944             # \p{PROPERTY} --> p\{PROPERTY}
1945             # \P{PROPERTY} --> P\{PROPERTY}
1946             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1947 0         0 $char[$i] = $1 . '\\' . $2;
1948             }
1949              
1950             # \p, \P, \X --> p, P, X
1951             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1952 0         0 $char[$i] = $1;
1953             }
1954              
1955             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1956 0         0 $char[$i] = CORE::chr oct $1;
1957             }
1958             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1959 0         0 $char[$i] = CORE::chr hex $1;
1960             }
1961             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1962 206         848 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1963             }
1964             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1965             $char[$i] = {
1966             '\0' => "\0",
1967             '\n' => "\n",
1968             '\r' => "\r",
1969             '\t' => "\t",
1970             '\f' => "\f",
1971             '\b' => "\x08", # \b means backspace in character class
1972             '\a' => "\a",
1973             '\e' => "\e",
1974             '\d' => '[0-9]',
1975              
1976             # Vertical tabs are now whitespace
1977             # \s in a regex now matches a vertical tab in all circumstances.
1978             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1979             # \t \n \v \f \r space
1980             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1981             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1982             '\s' => '\s',
1983              
1984             '\w' => '[0-9A-Z_a-z]',
1985             '\D' => '${Euhc::eD}',
1986             '\S' => '${Euhc::eS}',
1987             '\W' => '${Euhc::eW}',
1988              
1989             '\H' => '${Euhc::eH}',
1990             '\V' => '${Euhc::eV}',
1991             '\h' => '[\x09\x20]',
1992             '\v' => '[\x0A\x0B\x0C\x0D]',
1993             '\R' => '${Euhc::eR}',
1994              
1995 0         0 }->{$1};
1996             }
1997              
1998             # POSIX-style character classes
1999             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2000             $char[$i] = {
2001              
2002             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2003             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2004             '[:^lower:]' => '${Euhc::not_lower_i}',
2005             '[:^upper:]' => '${Euhc::not_upper_i}',
2006              
2007 33         499 }->{$1};
2008             }
2009             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2010             $char[$i] = {
2011              
2012             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2013             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2014             '[:ascii:]' => '[\x00-\x7F]',
2015             '[:blank:]' => '[\x09\x20]',
2016             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2017             '[:digit:]' => '[\x30-\x39]',
2018             '[:graph:]' => '[\x21-\x7F]',
2019             '[:lower:]' => '[\x61-\x7A]',
2020             '[:print:]' => '[\x20-\x7F]',
2021             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2022              
2023             # P.174 POSIX-Style Character Classes
2024             # in Chapter 5: Pattern Matching
2025             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2026              
2027             # P.311 11.2.4 Character Classes and other Special Escapes
2028             # in Chapter 11: perlre: Perl regular expressions
2029             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2030              
2031             # P.210 POSIX-Style Character Classes
2032             # in Chapter 5: Pattern Matching
2033             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2034              
2035             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2036              
2037             '[:upper:]' => '[\x41-\x5A]',
2038             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2039             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2040             '[:^alnum:]' => '${Euhc::not_alnum}',
2041             '[:^alpha:]' => '${Euhc::not_alpha}',
2042             '[:^ascii:]' => '${Euhc::not_ascii}',
2043             '[:^blank:]' => '${Euhc::not_blank}',
2044             '[:^cntrl:]' => '${Euhc::not_cntrl}',
2045             '[:^digit:]' => '${Euhc::not_digit}',
2046             '[:^graph:]' => '${Euhc::not_graph}',
2047             '[:^lower:]' => '${Euhc::not_lower}',
2048             '[:^print:]' => '${Euhc::not_print}',
2049             '[:^punct:]' => '${Euhc::not_punct}',
2050             '[:^space:]' => '${Euhc::not_space}',
2051             '[:^upper:]' => '${Euhc::not_upper}',
2052             '[:^word:]' => '${Euhc::not_word}',
2053             '[:^xdigit:]' => '${Euhc::not_xdigit}',
2054              
2055 8         76 }->{$1};
2056             }
2057             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2058 70         1383 $char[$i] = $1;
2059             }
2060             }
2061              
2062             # open character list
2063 7         36 my @singleoctet = ();
2064 758         1292 my @multipleoctet = ();
2065 758         1129 for (my $i=0; $i <= $#char; ) {
2066              
2067             # escaped -
2068 758 100 100     1661 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2069 2151         8959 $i += 1;
2070 497         735 next;
2071             }
2072              
2073             # make range regexp
2074             elsif ($char[$i] eq '...') {
2075              
2076             # range error
2077 497 50       1027 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2078 497         1912 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2079             }
2080             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2081 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2082 477         1176 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2083             }
2084             }
2085              
2086             # make range regexp per length
2087 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2088 497         1588 my @regexp = ();
2089              
2090             # is first and last
2091 517 100 100     732 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2092 517         1906 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2093             }
2094              
2095             # is first
2096             elsif ($length == CORE::length($char[$i-1])) {
2097 477         1631 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2098             }
2099              
2100             # is inside in first and last
2101             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2102 20         74 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2103             }
2104              
2105             # is last
2106             elsif ($length == CORE::length($char[$i+1])) {
2107 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2108             }
2109              
2110             else {
2111 20         105 die __FILE__, ": subroutine make_regexp panic.\n";
2112             }
2113              
2114 0 100       0 if ($length == 1) {
2115 517         1058 push @singleoctet, @regexp;
2116             }
2117             else {
2118 386         962 push @multipleoctet, @regexp;
2119             }
2120             }
2121              
2122 131         339 $i += 2;
2123             }
2124              
2125             # with /i modifier
2126             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2127 497 100       1120 if ($modifier =~ /i/oxms) {
2128 764         1289 my $uc = Euhc::uc($char[$i]);
2129 192         314 my $fc = Euhc::fc($char[$i]);
2130 192 50       368 if ($uc ne $fc) {
2131 192 50       338 if (CORE::length($fc) == 1) {
2132 192         260 push @singleoctet, $uc, $fc;
2133             }
2134             else {
2135 192         351 push @singleoctet, $uc;
2136 0         0 push @multipleoctet, $fc;
2137             }
2138             }
2139             else {
2140 0         0 push @singleoctet, $char[$i];
2141             }
2142             }
2143             else {
2144 0         0 push @singleoctet, $char[$i];
2145             }
2146 572         974 $i += 1;
2147             }
2148              
2149             # single character of single octet code
2150             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2151 764         1359 push @singleoctet, "\t", "\x20";
2152 0         0 $i += 1;
2153             }
2154             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2155 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2156 0         0 $i += 1;
2157             }
2158             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2159 0         0 push @singleoctet, $char[$i];
2160 2         7 $i += 1;
2161             }
2162              
2163             # single character of multiple-octet code
2164             else {
2165 2         6 push @multipleoctet, $char[$i];
2166 391         648 $i += 1;
2167             }
2168             }
2169              
2170             # quote metachar
2171 391         634 for (@singleoctet) {
2172 758 50       1619 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2173 1364         6187 $_ = '-';
2174             }
2175             elsif (/\A \n \z/oxms) {
2176 0         0 $_ = '\n';
2177             }
2178             elsif (/\A \r \z/oxms) {
2179 8         17 $_ = '\r';
2180             }
2181             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2182 8         16 $_ = sprintf('\x%02X', CORE::ord $1);
2183             }
2184             elsif (/\A [\x00-\xFF] \z/oxms) {
2185 1         9 $_ = quotemeta $_;
2186             }
2187             }
2188 939         1448 for (@multipleoctet) {
2189 758 100       1374 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2190 844         2267 $_ = $1 . quotemeta $2;
2191             }
2192             }
2193              
2194             # return character list
2195 307         706 return \@singleoctet, \@multipleoctet;
2196             }
2197              
2198             #
2199             # UHC octal escape sequence
2200             #
2201             sub octchr {
2202 758     5 0 2979 my($octdigit) = @_;
2203              
2204 5         16 my @binary = ();
2205 5         8 for my $octal (split(//,$octdigit)) {
2206             push @binary, {
2207             '0' => '000',
2208             '1' => '001',
2209             '2' => '010',
2210             '3' => '011',
2211             '4' => '100',
2212             '5' => '101',
2213             '6' => '110',
2214             '7' => '111',
2215 5         29 }->{$octal};
2216             }
2217 50         179 my $binary = join '', @binary;
2218              
2219             my $octchr = {
2220             # 1234567
2221             1 => pack('B*', "0000000$binary"),
2222             2 => pack('B*', "000000$binary"),
2223             3 => pack('B*', "00000$binary"),
2224             4 => pack('B*', "0000$binary"),
2225             5 => pack('B*', "000$binary"),
2226             6 => pack('B*', "00$binary"),
2227             7 => pack('B*', "0$binary"),
2228             0 => pack('B*', "$binary"),
2229              
2230 5         17 }->{CORE::length($binary) % 8};
2231              
2232 5         77 return $octchr;
2233             }
2234              
2235             #
2236             # UHC hexadecimal escape sequence
2237             #
2238             sub hexchr {
2239 5     5 0 19 my($hexdigit) = @_;
2240              
2241             my $hexchr = {
2242             1 => pack('H*', "0$hexdigit"),
2243             0 => pack('H*', "$hexdigit"),
2244              
2245 5         13 }->{CORE::length($_[0]) % 2};
2246              
2247 5         45 return $hexchr;
2248             }
2249              
2250             #
2251             # UHC open character list for qr
2252             #
2253             sub charlist_qr {
2254              
2255 5     519 0 17 my $modifier = pop @_;
2256 519         1237 my @char = @_;
2257              
2258 519         1344 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2259 519         1811 my @singleoctet = @$singleoctet;
2260 519         1200 my @multipleoctet = @$multipleoctet;
2261              
2262             # return character list
2263 519 100       896 if (scalar(@singleoctet) >= 1) {
2264              
2265             # with /i modifier
2266 519 100       1269 if ($modifier =~ m/i/oxms) {
2267 384         897 my %singleoctet_ignorecase = ();
2268 107         162 for (@singleoctet) {
2269 107   100     198 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2270 272         915 for my $ord (hex($1) .. hex($2)) {
2271 80         336 my $char = CORE::chr($ord);
2272 1046         1355 my $uc = Euhc::uc($char);
2273 1046         1286 my $fc = Euhc::fc($char);
2274 1046 100       1536 if ($uc eq $fc) {
2275 1046         1475 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2276             }
2277             else {
2278 457 50       952 if (CORE::length($fc) == 1) {
2279 589         694 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2280 589         1202 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2281             }
2282             else {
2283 589         1358 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2284 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2285             }
2286             }
2287             }
2288             }
2289 0 100       0 if ($_ ne '') {
2290 272         467 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2291             }
2292             }
2293 192         497 my $i = 0;
2294 107         129 my @singleoctet_ignorecase = ();
2295 107         154 for my $ord (0 .. 255) {
2296 107 100       249 if (exists $singleoctet_ignorecase{$ord}) {
2297 27392         30078 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1413  
2298             }
2299             else {
2300 1577         2400 $i++;
2301             }
2302             }
2303 25815         24822 @singleoctet = ();
2304 107         165 for my $range (@singleoctet_ignorecase) {
2305 107 100       273 if (ref $range) {
2306 11412 100       17194 if (scalar(@{$range}) == 1) {
  214 50       251  
2307 214         348 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2308             }
2309 5         57 elsif (scalar(@{$range}) == 2) {
2310 209         360 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2311             }
2312             else {
2313 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         236  
  209         227  
2314             }
2315             }
2316             }
2317             }
2318              
2319 209         973 my $not_anchor = '';
2320 384         642 $not_anchor = '(?![\x81-\xFE])';
2321              
2322 384         691 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2323             }
2324 384 100       1293 if (scalar(@multipleoctet) >= 2) {
2325 519         1578 return '(?:' . join('|', @multipleoctet) . ')';
2326             }
2327             else {
2328 131         830 return $multipleoctet[0];
2329             }
2330             }
2331              
2332             #
2333             # UHC open character list for not qr
2334             #
2335             sub charlist_not_qr {
2336              
2337 388     239 0 1800 my $modifier = pop @_;
2338 239         447 my @char = @_;
2339              
2340 239         569 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2341 239         569 my @singleoctet = @$singleoctet;
2342 239         481 my @multipleoctet = @$multipleoctet;
2343              
2344             # with /i modifier
2345 239 100       398 if ($modifier =~ m/i/oxms) {
2346 239         553 my %singleoctet_ignorecase = ();
2347 128         220 for (@singleoctet) {
2348 128   100     186 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2349 272         846 for my $ord (hex($1) .. hex($2)) {
2350 80         263 my $char = CORE::chr($ord);
2351 1046         1313 my $uc = Euhc::uc($char);
2352 1046         1257 my $fc = Euhc::fc($char);
2353 1046 100       1493 if ($uc eq $fc) {
2354 1046         1459 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2355             }
2356             else {
2357 457 50       973 if (CORE::length($fc) == 1) {
2358 589         722 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2359 589         1080 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2360             }
2361             else {
2362 589         1417 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2363 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2364             }
2365             }
2366             }
2367             }
2368 0 100       0 if ($_ ne '') {
2369 272         405 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2370             }
2371             }
2372 192         423 my $i = 0;
2373 128         162 my @singleoctet_ignorecase = ();
2374 128         147 for my $ord (0 .. 255) {
2375 128 100       222 if (exists $singleoctet_ignorecase{$ord}) {
2376 32768         40877 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1380  
2377             }
2378             else {
2379 1577         2346 $i++;
2380             }
2381             }
2382 31191         30194 @singleoctet = ();
2383 128         200 for my $range (@singleoctet_ignorecase) {
2384 128 100       283 if (ref $range) {
2385 11412 100       16925 if (scalar(@{$range}) == 1) {
  214 50       218  
2386 214         341 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         5  
2387             }
2388 5         55 elsif (scalar(@{$range}) == 2) {
2389 209         264 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2390             }
2391             else {
2392 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         272  
  209         234  
2393             }
2394             }
2395             }
2396             }
2397              
2398             # return character list
2399 209 100       886 if (scalar(@multipleoctet) >= 1) {
2400 239 100       506 if (scalar(@singleoctet) >= 1) {
2401              
2402             # any character other than multiple-octet and single octet character class
2403 114         193 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2404             }
2405             else {
2406              
2407             # any character other than multiple-octet character class
2408 70         494 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2409             }
2410             }
2411             else {
2412 44 50       288 if (scalar(@singleoctet) >= 1) {
2413              
2414             # any character other than single octet character class
2415 125         300 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2416             }
2417             else {
2418              
2419             # any character
2420 125         703 return "(?:$your_char)";
2421             }
2422             }
2423             }
2424              
2425             #
2426             # open file in read mode
2427             #
2428             sub _open_r {
2429 0     768   0 my(undef,$file) = @_;
2430 389     389   7246 use Fcntl qw(O_RDONLY);
  389         891  
  389         64742  
2431 768         2506 return CORE::sysopen($_[0], $file, &O_RDONLY);
2432             }
2433              
2434             #
2435             # open file in append mode
2436             #
2437             sub _open_a {
2438 768     384   32875 my(undef,$file) = @_;
2439 389     389   6161 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  389         843  
  389         5446254  
2440 384         1219 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2441             }
2442              
2443             #
2444             # safe system
2445             #
2446             sub _systemx {
2447              
2448             # P.707 29.2.33. exec
2449             # in Chapter 29: Functions
2450             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2451             #
2452             # Be aware that in older releases of Perl, exec (and system) did not flush
2453             # your output buffer, so you needed to enable command buffering by setting $|
2454             # on one or more filehandles to avoid lost output in the case of exec, or
2455             # misordererd output in the case of system. This situation was largely remedied
2456             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2457              
2458             # P.855 exec
2459             # in Chapter 27: Functions
2460             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2461             #
2462             # In very old release of Perl (before v5.6), exec (and system) did not flush
2463             # your output buffer, so you needed to enable command buffering by setting $|
2464             # on one or more filehandles to avoid lost output with exec or misordered
2465             # output with system.
2466              
2467 384     384   58434 $| = 1;
2468              
2469             # P.565 23.1.2. Cleaning Up Your Environment
2470             # in Chapter 23: Security
2471             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2472              
2473             # P.656 Cleaning Up Your Environment
2474             # in Chapter 20: Security
2475             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2476              
2477             # local $ENV{'PATH'} = '.';
2478 384         1587 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2479              
2480             # P.707 29.2.33. exec
2481             # in Chapter 29: Functions
2482             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2483             #
2484             # As we mentioned earlier, exec treats a discrete list of arguments as an
2485             # indication that it should bypass shell processing. However, there is one
2486             # place where you might still get tripped up. The exec call (and system, too)
2487             # will not distinguish between a single scalar argument and an array containing
2488             # only one element.
2489             #
2490             # @args = ("echo surprise"); # just one element in list
2491             # exec @args # still subject to shell escapes
2492             # or die "exec: $!"; # because @args == 1
2493             #
2494             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2495             # first argument as the pathname, which forces the rest of the arguments to be
2496             # interpreted as a list, even if there is only one of them:
2497             #
2498             # exec { $args[0] } @args # safe even with one-argument list
2499             # or die "can't exec @args: $!";
2500              
2501             # P.855 exec
2502             # in Chapter 27: Functions
2503             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2504             #
2505             # As we mentioned earlier, exec treats a discrete list of arguments as a
2506             # directive to bypass shell processing. However, there is one place where
2507             # you might still get tripped up. The exec call (and system, too) cannot
2508             # distinguish between a single scalar argument and an array containing
2509             # only one element.
2510             #
2511             # @args = ("echo surprise"); # just one element in list
2512             # exec @args # still subject to shell escapes
2513             # || die "exec: $!"; # because @args == 1
2514             #
2515             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2516             # argument as the pathname, which forces the rest of the arguments to be
2517             # interpreted as a list, even if there is only one of them:
2518             #
2519             # exec { $args[0] } @args # safe even with one-argument list
2520             # || die "can't exec @args: $!";
2521              
2522 384         3900 return CORE::system { $_[0] } @_; # safe even with one-argument list
  384         975  
2523             }
2524              
2525             #
2526             # UHC order to character (with parameter)
2527             #
2528             sub Euhc::chr(;$) {
2529              
2530 384 0   0 0 47310558 my $c = @_ ? $_[0] : $_;
2531              
2532 0 0       0 if ($c == 0x00) {
2533 0         0 return "\x00";
2534             }
2535             else {
2536 0         0 my @chr = ();
2537 0         0 while ($c > 0) {
2538 0         0 unshift @chr, ($c % 0x100);
2539 0         0 $c = int($c / 0x100);
2540             }
2541 0         0 return pack 'C*', @chr;
2542             }
2543             }
2544              
2545             #
2546             # UHC order to character (without parameter)
2547             #
2548             sub Euhc::chr_() {
2549              
2550 0     0 0 0 my $c = $_;
2551              
2552 0 0       0 if ($c == 0x00) {
2553 0         0 return "\x00";
2554             }
2555             else {
2556 0         0 my @chr = ();
2557 0         0 while ($c > 0) {
2558 0         0 unshift @chr, ($c % 0x100);
2559 0         0 $c = int($c / 0x100);
2560             }
2561 0         0 return pack 'C*', @chr;
2562             }
2563             }
2564              
2565             #
2566             # UHC stacked file test expr
2567             #
2568             sub Euhc::filetest {
2569              
2570 0     0 0 0 my $file = pop @_;
2571 0         0 my $filetest = substr(pop @_, 1);
2572              
2573 0 0       0 unless (CORE::eval qq{Euhc::$filetest(\$file)}) {
2574 0         0 return '';
2575             }
2576 0         0 for my $filetest (CORE::reverse @_) {
2577 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2578 0         0 return '';
2579             }
2580             }
2581 0         0 return 1;
2582             }
2583              
2584             #
2585             # UHC file test -r expr
2586             #
2587             sub Euhc::r(;*@) {
2588              
2589 0 0   0 0 0 local $_ = shift if @_;
2590 0 0 0     0 croak 'Too many arguments for -r (Euhc::r)' if @_ and not wantarray;
2591              
2592 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2593 0 0       0 return wantarray ? (-r _,@_) : -r _;
2594             }
2595              
2596             # P.908 32.39. Symbol
2597             # in Chapter 32: Standard Modules
2598             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2599              
2600             # P.326 Prototypes
2601             # in Chapter 7: Subroutines
2602             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2603              
2604             # (and so on)
2605              
2606             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2607 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2608             }
2609             elsif (-e $_) {
2610 0 0       0 return wantarray ? (-r _,@_) : -r _;
2611             }
2612             elsif (_MSWin32_5Cended_path($_)) {
2613 0 0       0 if (-d "$_/.") {
2614 0 0       0 return wantarray ? (-r _,@_) : -r _;
2615             }
2616             else {
2617              
2618             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Euhc::*()
2619             # on Windows opens the file for the path which has 5c at end.
2620             # (and so on)
2621              
2622 0         0 my $fh = gensym();
2623 0 0       0 if (_open_r($fh, $_)) {
2624 0         0 my $r = -r $fh;
2625 0         0 close $fh;
2626 0 0       0 return wantarray ? ($r,@_) : $r;
2627             }
2628             }
2629             }
2630 0 0       0 return wantarray ? (undef,@_) : undef;
2631             }
2632              
2633             #
2634             # UHC file test -w expr
2635             #
2636             sub Euhc::w(;*@) {
2637              
2638 0 0   0 0 0 local $_ = shift if @_;
2639 0 0 0     0 croak 'Too many arguments for -w (Euhc::w)' if @_ and not wantarray;
2640              
2641 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2642 0 0       0 return wantarray ? (-w _,@_) : -w _;
2643             }
2644             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2645 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2646             }
2647             elsif (-e $_) {
2648 0 0       0 return wantarray ? (-w _,@_) : -w _;
2649             }
2650             elsif (_MSWin32_5Cended_path($_)) {
2651 0 0       0 if (-d "$_/.") {
2652 0 0       0 return wantarray ? (-w _,@_) : -w _;
2653             }
2654             else {
2655 0         0 my $fh = gensym();
2656 0 0       0 if (_open_a($fh, $_)) {
2657 0         0 my $w = -w $fh;
2658 0         0 close $fh;
2659 0 0       0 return wantarray ? ($w,@_) : $w;
2660             }
2661             }
2662             }
2663 0 0       0 return wantarray ? (undef,@_) : undef;
2664             }
2665              
2666             #
2667             # UHC file test -x expr
2668             #
2669             sub Euhc::x(;*@) {
2670              
2671 0 0   0 0 0 local $_ = shift if @_;
2672 0 0 0     0 croak 'Too many arguments for -x (Euhc::x)' if @_ and not wantarray;
2673              
2674 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2675 0 0       0 return wantarray ? (-x _,@_) : -x _;
2676             }
2677             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2678 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2679             }
2680             elsif (-e $_) {
2681 0 0       0 return wantarray ? (-x _,@_) : -x _;
2682             }
2683             elsif (_MSWin32_5Cended_path($_)) {
2684 0 0       0 if (-d "$_/.") {
2685 0 0       0 return wantarray ? (-x _,@_) : -x _;
2686             }
2687             else {
2688 0         0 my $fh = gensym();
2689 0 0       0 if (_open_r($fh, $_)) {
2690 0         0 my $dummy_for_underline_cache = -x $fh;
2691 0         0 close $fh;
2692             }
2693              
2694             # filename is not .COM .EXE .BAT .CMD
2695 0 0       0 return wantarray ? ('',@_) : '';
2696             }
2697             }
2698 0 0       0 return wantarray ? (undef,@_) : undef;
2699             }
2700              
2701             #
2702             # UHC file test -o expr
2703             #
2704             sub Euhc::o(;*@) {
2705              
2706 0 0   0 0 0 local $_ = shift if @_;
2707 0 0 0     0 croak 'Too many arguments for -o (Euhc::o)' if @_ and not wantarray;
2708              
2709 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2710 0 0       0 return wantarray ? (-o _,@_) : -o _;
2711             }
2712             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2713 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2714             }
2715             elsif (-e $_) {
2716 0 0       0 return wantarray ? (-o _,@_) : -o _;
2717             }
2718             elsif (_MSWin32_5Cended_path($_)) {
2719 0 0       0 if (-d "$_/.") {
2720 0 0       0 return wantarray ? (-o _,@_) : -o _;
2721             }
2722             else {
2723 0         0 my $fh = gensym();
2724 0 0       0 if (_open_r($fh, $_)) {
2725 0         0 my $o = -o $fh;
2726 0         0 close $fh;
2727 0 0       0 return wantarray ? ($o,@_) : $o;
2728             }
2729             }
2730             }
2731 0 0       0 return wantarray ? (undef,@_) : undef;
2732             }
2733              
2734             #
2735             # UHC file test -R expr
2736             #
2737             sub Euhc::R(;*@) {
2738              
2739 0 0   0 0 0 local $_ = shift if @_;
2740 0 0 0     0 croak 'Too many arguments for -R (Euhc::R)' if @_ and not wantarray;
2741              
2742 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2743 0 0       0 return wantarray ? (-R _,@_) : -R _;
2744             }
2745             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2746 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2747             }
2748             elsif (-e $_) {
2749 0 0       0 return wantarray ? (-R _,@_) : -R _;
2750             }
2751             elsif (_MSWin32_5Cended_path($_)) {
2752 0 0       0 if (-d "$_/.") {
2753 0 0       0 return wantarray ? (-R _,@_) : -R _;
2754             }
2755             else {
2756 0         0 my $fh = gensym();
2757 0 0       0 if (_open_r($fh, $_)) {
2758 0         0 my $R = -R $fh;
2759 0         0 close $fh;
2760 0 0       0 return wantarray ? ($R,@_) : $R;
2761             }
2762             }
2763             }
2764 0 0       0 return wantarray ? (undef,@_) : undef;
2765             }
2766              
2767             #
2768             # UHC file test -W expr
2769             #
2770             sub Euhc::W(;*@) {
2771              
2772 0 0   0 0 0 local $_ = shift if @_;
2773 0 0 0     0 croak 'Too many arguments for -W (Euhc::W)' if @_ and not wantarray;
2774              
2775 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2776 0 0       0 return wantarray ? (-W _,@_) : -W _;
2777             }
2778             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2779 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2780             }
2781             elsif (-e $_) {
2782 0 0       0 return wantarray ? (-W _,@_) : -W _;
2783             }
2784             elsif (_MSWin32_5Cended_path($_)) {
2785 0 0       0 if (-d "$_/.") {
2786 0 0       0 return wantarray ? (-W _,@_) : -W _;
2787             }
2788             else {
2789 0         0 my $fh = gensym();
2790 0 0       0 if (_open_a($fh, $_)) {
2791 0         0 my $W = -W $fh;
2792 0         0 close $fh;
2793 0 0       0 return wantarray ? ($W,@_) : $W;
2794             }
2795             }
2796             }
2797 0 0       0 return wantarray ? (undef,@_) : undef;
2798             }
2799              
2800             #
2801             # UHC file test -X expr
2802             #
2803             sub Euhc::X(;*@) {
2804              
2805 0 0   0 1 0 local $_ = shift if @_;
2806 0 0 0     0 croak 'Too many arguments for -X (Euhc::X)' if @_ and not wantarray;
2807              
2808 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2809 0 0       0 return wantarray ? (-X _,@_) : -X _;
2810             }
2811             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2812 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2813             }
2814             elsif (-e $_) {
2815 0 0       0 return wantarray ? (-X _,@_) : -X _;
2816             }
2817             elsif (_MSWin32_5Cended_path($_)) {
2818 0 0       0 if (-d "$_/.") {
2819 0 0       0 return wantarray ? (-X _,@_) : -X _;
2820             }
2821             else {
2822 0         0 my $fh = gensym();
2823 0 0       0 if (_open_r($fh, $_)) {
2824 0         0 my $dummy_for_underline_cache = -X $fh;
2825 0         0 close $fh;
2826             }
2827              
2828             # filename is not .COM .EXE .BAT .CMD
2829 0 0       0 return wantarray ? ('',@_) : '';
2830             }
2831             }
2832 0 0       0 return wantarray ? (undef,@_) : undef;
2833             }
2834              
2835             #
2836             # UHC file test -O expr
2837             #
2838             sub Euhc::O(;*@) {
2839              
2840 0 0   0 0 0 local $_ = shift if @_;
2841 0 0 0     0 croak 'Too many arguments for -O (Euhc::O)' if @_ and not wantarray;
2842              
2843 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2844 0 0       0 return wantarray ? (-O _,@_) : -O _;
2845             }
2846             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2847 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2848             }
2849             elsif (-e $_) {
2850 0 0       0 return wantarray ? (-O _,@_) : -O _;
2851             }
2852             elsif (_MSWin32_5Cended_path($_)) {
2853 0 0       0 if (-d "$_/.") {
2854 0 0       0 return wantarray ? (-O _,@_) : -O _;
2855             }
2856             else {
2857 0         0 my $fh = gensym();
2858 0 0       0 if (_open_r($fh, $_)) {
2859 0         0 my $O = -O $fh;
2860 0         0 close $fh;
2861 0 0       0 return wantarray ? ($O,@_) : $O;
2862             }
2863             }
2864             }
2865 0 0       0 return wantarray ? (undef,@_) : undef;
2866             }
2867              
2868             #
2869             # UHC file test -e expr
2870             #
2871             sub Euhc::e(;*@) {
2872              
2873 0 50   768 0 0 local $_ = shift if @_;
2874 768 50 33     2991 croak 'Too many arguments for -e (Euhc::e)' if @_ and not wantarray;
2875              
2876 768         3311 local $^W = 0;
2877              
2878 768         2590 my $fh = qualify_to_ref $_;
2879 768 50       2258 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2880 768 0       3274 return wantarray ? (-e _,@_) : -e _;
2881             }
2882              
2883             # return false if directory handle
2884             elsif (defined Euhc::telldir($fh)) {
2885 0 0       0 return wantarray ? ('',@_) : '';
2886             }
2887              
2888             # return true if file handle
2889             elsif (defined fileno $fh) {
2890 0 0       0 return wantarray ? (1,@_) : 1;
2891             }
2892              
2893             elsif (-e $_) {
2894 0 0       0 return wantarray ? (1,@_) : 1;
2895             }
2896             elsif (_MSWin32_5Cended_path($_)) {
2897 0 0       0 if (-d "$_/.") {
2898 0 0       0 return wantarray ? (1,@_) : 1;
2899             }
2900             else {
2901 0         0 my $fh = gensym();
2902 0 0       0 if (_open_r($fh, $_)) {
2903 0         0 my $e = -e $fh;
2904 0         0 close $fh;
2905 0 0       0 return wantarray ? ($e,@_) : $e;
2906             }
2907             }
2908             }
2909 0 50       0 return wantarray ? (undef,@_) : undef;
2910             }
2911              
2912             #
2913             # UHC file test -z expr
2914             #
2915             sub Euhc::z(;*@) {
2916              
2917 768 0   0 0 4488 local $_ = shift if @_;
2918 0 0 0     0 croak 'Too many arguments for -z (Euhc::z)' if @_ and not wantarray;
2919              
2920 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2921 0 0       0 return wantarray ? (-z _,@_) : -z _;
2922             }
2923             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2924 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2925             }
2926             elsif (-e $_) {
2927 0 0       0 return wantarray ? (-z _,@_) : -z _;
2928             }
2929             elsif (_MSWin32_5Cended_path($_)) {
2930 0 0       0 if (-d "$_/.") {
2931 0 0       0 return wantarray ? (-z _,@_) : -z _;
2932             }
2933             else {
2934 0         0 my $fh = gensym();
2935 0 0       0 if (_open_r($fh, $_)) {
2936 0         0 my $z = -z $fh;
2937 0         0 close $fh;
2938 0 0       0 return wantarray ? ($z,@_) : $z;
2939             }
2940             }
2941             }
2942 0 0       0 return wantarray ? (undef,@_) : undef;
2943             }
2944              
2945             #
2946             # UHC file test -s expr
2947             #
2948             sub Euhc::s(;*@) {
2949              
2950 0 0   0 0 0 local $_ = shift if @_;
2951 0 0 0     0 croak 'Too many arguments for -s (Euhc::s)' if @_ and not wantarray;
2952              
2953 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2954 0 0       0 return wantarray ? (-s _,@_) : -s _;
2955             }
2956             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2957 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2958             }
2959             elsif (-e $_) {
2960 0 0       0 return wantarray ? (-s _,@_) : -s _;
2961             }
2962             elsif (_MSWin32_5Cended_path($_)) {
2963 0 0       0 if (-d "$_/.") {
2964 0 0       0 return wantarray ? (-s _,@_) : -s _;
2965             }
2966             else {
2967 0         0 my $fh = gensym();
2968 0 0       0 if (_open_r($fh, $_)) {
2969 0         0 my $s = -s $fh;
2970 0         0 close $fh;
2971 0 0       0 return wantarray ? ($s,@_) : $s;
2972             }
2973             }
2974             }
2975 0 0       0 return wantarray ? (undef,@_) : undef;
2976             }
2977              
2978             #
2979             # UHC file test -f expr
2980             #
2981             sub Euhc::f(;*@) {
2982              
2983 0 0   0 0 0 local $_ = shift if @_;
2984 0 0 0     0 croak 'Too many arguments for -f (Euhc::f)' if @_ and not wantarray;
2985              
2986 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2987 0 0       0 return wantarray ? (-f _,@_) : -f _;
2988             }
2989             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2990 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
2991             }
2992             elsif (-e $_) {
2993 0 0       0 return wantarray ? (-f _,@_) : -f _;
2994             }
2995             elsif (_MSWin32_5Cended_path($_)) {
2996 0 0       0 if (-d "$_/.") {
2997 0 0       0 return wantarray ? ('',@_) : '';
2998             }
2999             else {
3000 0         0 my $fh = gensym();
3001 0 0       0 if (_open_r($fh, $_)) {
3002 0         0 my $f = -f $fh;
3003 0         0 close $fh;
3004 0 0       0 return wantarray ? ($f,@_) : $f;
3005             }
3006             }
3007             }
3008 0 0       0 return wantarray ? (undef,@_) : undef;
3009             }
3010              
3011             #
3012             # UHC file test -d expr
3013             #
3014             sub Euhc::d(;*@) {
3015              
3016 0 0   0 0 0 local $_ = shift if @_;
3017 0 0 0     0 croak 'Too many arguments for -d (Euhc::d)' if @_ and not wantarray;
3018              
3019 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3020 0 0       0 return wantarray ? (-d _,@_) : -d _;
3021             }
3022              
3023             # return false if file handle or directory handle
3024             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3025 0 0       0 return wantarray ? ('',@_) : '';
3026             }
3027             elsif (-e $_) {
3028 0 0       0 return wantarray ? (-d _,@_) : -d _;
3029             }
3030             elsif (_MSWin32_5Cended_path($_)) {
3031 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3032             }
3033 0 0       0 return wantarray ? (undef,@_) : undef;
3034             }
3035              
3036             #
3037             # UHC file test -l expr
3038             #
3039             sub Euhc::l(;*@) {
3040              
3041 0 0   0 0 0 local $_ = shift if @_;
3042 0 0 0     0 croak 'Too many arguments for -l (Euhc::l)' if @_ and not wantarray;
3043              
3044 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3045 0 0       0 return wantarray ? (-l _,@_) : -l _;
3046             }
3047             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3048 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3049             }
3050             elsif (-e $_) {
3051 0 0       0 return wantarray ? (-l _,@_) : -l _;
3052             }
3053             elsif (_MSWin32_5Cended_path($_)) {
3054 0 0       0 if (-d "$_/.") {
3055 0 0       0 return wantarray ? (-l _,@_) : -l _;
3056             }
3057             else {
3058 0         0 my $fh = gensym();
3059 0 0       0 if (_open_r($fh, $_)) {
3060 0         0 my $l = -l $fh;
3061 0         0 close $fh;
3062 0 0       0 return wantarray ? ($l,@_) : $l;
3063             }
3064             }
3065             }
3066 0 0       0 return wantarray ? (undef,@_) : undef;
3067             }
3068              
3069             #
3070             # UHC file test -p expr
3071             #
3072             sub Euhc::p(;*@) {
3073              
3074 0 0   0 0 0 local $_ = shift if @_;
3075 0 0 0     0 croak 'Too many arguments for -p (Euhc::p)' if @_ and not wantarray;
3076              
3077 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3078 0 0       0 return wantarray ? (-p _,@_) : -p _;
3079             }
3080             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3081 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3082             }
3083             elsif (-e $_) {
3084 0 0       0 return wantarray ? (-p _,@_) : -p _;
3085             }
3086             elsif (_MSWin32_5Cended_path($_)) {
3087 0 0       0 if (-d "$_/.") {
3088 0 0       0 return wantarray ? (-p _,@_) : -p _;
3089             }
3090             else {
3091 0         0 my $fh = gensym();
3092 0 0       0 if (_open_r($fh, $_)) {
3093 0         0 my $p = -p $fh;
3094 0         0 close $fh;
3095 0 0       0 return wantarray ? ($p,@_) : $p;
3096             }
3097             }
3098             }
3099 0 0       0 return wantarray ? (undef,@_) : undef;
3100             }
3101              
3102             #
3103             # UHC file test -S expr
3104             #
3105             sub Euhc::S(;*@) {
3106              
3107 0 0   0 0 0 local $_ = shift if @_;
3108 0 0 0     0 croak 'Too many arguments for -S (Euhc::S)' if @_ and not wantarray;
3109              
3110 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3111 0 0       0 return wantarray ? (-S _,@_) : -S _;
3112             }
3113             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3114 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3115             }
3116             elsif (-e $_) {
3117 0 0       0 return wantarray ? (-S _,@_) : -S _;
3118             }
3119             elsif (_MSWin32_5Cended_path($_)) {
3120 0 0       0 if (-d "$_/.") {
3121 0 0       0 return wantarray ? (-S _,@_) : -S _;
3122             }
3123             else {
3124 0         0 my $fh = gensym();
3125 0 0       0 if (_open_r($fh, $_)) {
3126 0         0 my $S = -S $fh;
3127 0         0 close $fh;
3128 0 0       0 return wantarray ? ($S,@_) : $S;
3129             }
3130             }
3131             }
3132 0 0       0 return wantarray ? (undef,@_) : undef;
3133             }
3134              
3135             #
3136             # UHC file test -b expr
3137             #
3138             sub Euhc::b(;*@) {
3139              
3140 0 0   0 0 0 local $_ = shift if @_;
3141 0 0 0     0 croak 'Too many arguments for -b (Euhc::b)' if @_ and not wantarray;
3142              
3143 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3144 0 0       0 return wantarray ? (-b _,@_) : -b _;
3145             }
3146             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3147 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3148             }
3149             elsif (-e $_) {
3150 0 0       0 return wantarray ? (-b _,@_) : -b _;
3151             }
3152             elsif (_MSWin32_5Cended_path($_)) {
3153 0 0       0 if (-d "$_/.") {
3154 0 0       0 return wantarray ? (-b _,@_) : -b _;
3155             }
3156             else {
3157 0         0 my $fh = gensym();
3158 0 0       0 if (_open_r($fh, $_)) {
3159 0         0 my $b = -b $fh;
3160 0         0 close $fh;
3161 0 0       0 return wantarray ? ($b,@_) : $b;
3162             }
3163             }
3164             }
3165 0 0       0 return wantarray ? (undef,@_) : undef;
3166             }
3167              
3168             #
3169             # UHC file test -c expr
3170             #
3171             sub Euhc::c(;*@) {
3172              
3173 0 0   0 0 0 local $_ = shift if @_;
3174 0 0 0     0 croak 'Too many arguments for -c (Euhc::c)' if @_ and not wantarray;
3175              
3176 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3177 0 0       0 return wantarray ? (-c _,@_) : -c _;
3178             }
3179             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3180 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3181             }
3182             elsif (-e $_) {
3183 0 0       0 return wantarray ? (-c _,@_) : -c _;
3184             }
3185             elsif (_MSWin32_5Cended_path($_)) {
3186 0 0       0 if (-d "$_/.") {
3187 0 0       0 return wantarray ? (-c _,@_) : -c _;
3188             }
3189             else {
3190 0         0 my $fh = gensym();
3191 0 0       0 if (_open_r($fh, $_)) {
3192 0         0 my $c = -c $fh;
3193 0         0 close $fh;
3194 0 0       0 return wantarray ? ($c,@_) : $c;
3195             }
3196             }
3197             }
3198 0 0       0 return wantarray ? (undef,@_) : undef;
3199             }
3200              
3201             #
3202             # UHC file test -u expr
3203             #
3204             sub Euhc::u(;*@) {
3205              
3206 0 0   0 0 0 local $_ = shift if @_;
3207 0 0 0     0 croak 'Too many arguments for -u (Euhc::u)' if @_ and not wantarray;
3208              
3209 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3210 0 0       0 return wantarray ? (-u _,@_) : -u _;
3211             }
3212             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3213 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3214             }
3215             elsif (-e $_) {
3216 0 0       0 return wantarray ? (-u _,@_) : -u _;
3217             }
3218             elsif (_MSWin32_5Cended_path($_)) {
3219 0 0       0 if (-d "$_/.") {
3220 0 0       0 return wantarray ? (-u _,@_) : -u _;
3221             }
3222             else {
3223 0         0 my $fh = gensym();
3224 0 0       0 if (_open_r($fh, $_)) {
3225 0         0 my $u = -u $fh;
3226 0         0 close $fh;
3227 0 0       0 return wantarray ? ($u,@_) : $u;
3228             }
3229             }
3230             }
3231 0 0       0 return wantarray ? (undef,@_) : undef;
3232             }
3233              
3234             #
3235             # UHC file test -g expr
3236             #
3237             sub Euhc::g(;*@) {
3238              
3239 0 0   0 0 0 local $_ = shift if @_;
3240 0 0 0     0 croak 'Too many arguments for -g (Euhc::g)' if @_ and not wantarray;
3241              
3242 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3243 0 0       0 return wantarray ? (-g _,@_) : -g _;
3244             }
3245             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3246 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3247             }
3248             elsif (-e $_) {
3249 0 0       0 return wantarray ? (-g _,@_) : -g _;
3250             }
3251             elsif (_MSWin32_5Cended_path($_)) {
3252 0 0       0 if (-d "$_/.") {
3253 0 0       0 return wantarray ? (-g _,@_) : -g _;
3254             }
3255             else {
3256 0         0 my $fh = gensym();
3257 0 0       0 if (_open_r($fh, $_)) {
3258 0         0 my $g = -g $fh;
3259 0         0 close $fh;
3260 0 0       0 return wantarray ? ($g,@_) : $g;
3261             }
3262             }
3263             }
3264 0 0       0 return wantarray ? (undef,@_) : undef;
3265             }
3266              
3267             #
3268             # UHC file test -k expr
3269             #
3270             sub Euhc::k(;*@) {
3271              
3272 0 0   0 0 0 local $_ = shift if @_;
3273 0 0 0     0 croak 'Too many arguments for -k (Euhc::k)' if @_ and not wantarray;
3274              
3275 0 0       0 if ($_ eq '_') {
    0          
    0          
3276 0 0       0 return wantarray ? ('',@_) : '';
3277             }
3278             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3279 0 0       0 return wantarray ? ('',@_) : '';
3280             }
3281             elsif ($] =~ /^5\.008/oxms) {
3282 0 0       0 return wantarray ? ('',@_) : '';
3283             }
3284 0 0       0 return wantarray ? ($_,@_) : $_;
3285             }
3286              
3287             #
3288             # UHC file test -T expr
3289             #
3290             sub Euhc::T(;*@) {
3291              
3292 0 0   0 0 0 local $_ = shift if @_;
3293              
3294             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3295             # croak 'Too many arguments for -T (Euhc::T)';
3296             # Must be used by parentheses like:
3297             # croak('Too many arguments for -T (Euhc::T)');
3298              
3299 0 0 0     0 if (@_ and not wantarray) {
3300 0         0 croak('Too many arguments for -T (Euhc::T)');
3301             }
3302              
3303 0         0 my $T = 1;
3304              
3305 0         0 my $fh = qualify_to_ref $_;
3306 0 0       0 if (defined fileno $fh) {
3307              
3308 0 0       0 if (defined Euhc::telldir($fh)) {
3309 0 0       0 return wantarray ? (undef,@_) : undef;
3310             }
3311              
3312             # P.813 29.2.176. tell
3313             # in Chapter 29: Functions
3314             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3315              
3316             # P.970 tell
3317             # in Chapter 27: Functions
3318             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3319              
3320             # (and so on)
3321              
3322 0         0 my $systell = sysseek $fh, 0, 1;
3323              
3324 0 0       0 if (sysread $fh, my $block, 512) {
3325              
3326             # P.163 Binary file check in Little Perl Parlor 16
3327             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3328             # (and so on)
3329              
3330 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3331 0         0 $T = '';
3332             }
3333             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3334 0         0 $T = '';
3335             }
3336             }
3337              
3338             # 0 byte or eof
3339             else {
3340 0         0 $T = 1;
3341             }
3342              
3343 0         0 my $dummy_for_underline_cache = -T $fh;
3344 0         0 sysseek $fh, $systell, 0;
3345             }
3346             else {
3347 0 0 0     0 if (-d $_ or -d "$_/.") {
3348 0 0       0 return wantarray ? (undef,@_) : undef;
3349             }
3350              
3351 0         0 $fh = gensym();
3352 0 0       0 if (_open_r($fh, $_)) {
3353             }
3354             else {
3355 0 0       0 return wantarray ? (undef,@_) : undef;
3356             }
3357 0 0       0 if (sysread $fh, my $block, 512) {
3358 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3359 0         0 $T = '';
3360             }
3361             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3362 0         0 $T = '';
3363             }
3364             }
3365              
3366             # 0 byte or eof
3367             else {
3368 0         0 $T = 1;
3369             }
3370 0         0 my $dummy_for_underline_cache = -T $fh;
3371 0         0 close $fh;
3372             }
3373              
3374 0 0       0 return wantarray ? ($T,@_) : $T;
3375             }
3376              
3377             #
3378             # UHC file test -B expr
3379             #
3380             sub Euhc::B(;*@) {
3381              
3382 0 0   0 0 0 local $_ = shift if @_;
3383 0 0 0     0 croak 'Too many arguments for -B (Euhc::B)' if @_ and not wantarray;
3384 0         0 my $B = '';
3385              
3386 0         0 my $fh = qualify_to_ref $_;
3387 0 0       0 if (defined fileno $fh) {
3388              
3389 0 0       0 if (defined Euhc::telldir($fh)) {
3390 0 0       0 return wantarray ? (undef,@_) : undef;
3391             }
3392              
3393 0         0 my $systell = sysseek $fh, 0, 1;
3394              
3395 0 0       0 if (sysread $fh, my $block, 512) {
3396 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3397 0         0 $B = 1;
3398             }
3399             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3400 0         0 $B = 1;
3401             }
3402             }
3403              
3404             # 0 byte or eof
3405             else {
3406 0         0 $B = 1;
3407             }
3408              
3409 0         0 my $dummy_for_underline_cache = -B $fh;
3410 0         0 sysseek $fh, $systell, 0;
3411             }
3412             else {
3413 0 0 0     0 if (-d $_ or -d "$_/.") {
3414 0 0       0 return wantarray ? (undef,@_) : undef;
3415             }
3416              
3417 0         0 $fh = gensym();
3418 0 0       0 if (_open_r($fh, $_)) {
3419             }
3420             else {
3421 0 0       0 return wantarray ? (undef,@_) : undef;
3422             }
3423 0 0       0 if (sysread $fh, my $block, 512) {
3424 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3425 0         0 $B = 1;
3426             }
3427             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3428 0         0 $B = 1;
3429             }
3430             }
3431              
3432             # 0 byte or eof
3433             else {
3434 0         0 $B = 1;
3435             }
3436 0         0 my $dummy_for_underline_cache = -B $fh;
3437 0         0 close $fh;
3438             }
3439              
3440 0 0       0 return wantarray ? ($B,@_) : $B;
3441             }
3442              
3443             #
3444             # UHC file test -M expr
3445             #
3446             sub Euhc::M(;*@) {
3447              
3448 0 0   0 0 0 local $_ = shift if @_;
3449 0 0 0     0 croak 'Too many arguments for -M (Euhc::M)' if @_ and not wantarray;
3450              
3451 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3452 0 0       0 return wantarray ? (-M _,@_) : -M _;
3453             }
3454             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3455 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3456             }
3457             elsif (-e $_) {
3458 0 0       0 return wantarray ? (-M _,@_) : -M _;
3459             }
3460             elsif (_MSWin32_5Cended_path($_)) {
3461 0 0       0 if (-d "$_/.") {
3462 0 0       0 return wantarray ? (-M _,@_) : -M _;
3463             }
3464             else {
3465 0         0 my $fh = gensym();
3466 0 0       0 if (_open_r($fh, $_)) {
3467 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3468 0         0 close $fh;
3469 0         0 my $M = ($^T - $mtime) / (24*60*60);
3470 0 0       0 return wantarray ? ($M,@_) : $M;
3471             }
3472             }
3473             }
3474 0 0       0 return wantarray ? (undef,@_) : undef;
3475             }
3476              
3477             #
3478             # UHC file test -A expr
3479             #
3480             sub Euhc::A(;*@) {
3481              
3482 0 0   0 0 0 local $_ = shift if @_;
3483 0 0 0     0 croak 'Too many arguments for -A (Euhc::A)' if @_ and not wantarray;
3484              
3485 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3486 0 0       0 return wantarray ? (-A _,@_) : -A _;
3487             }
3488             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3489 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3490             }
3491             elsif (-e $_) {
3492 0 0       0 return wantarray ? (-A _,@_) : -A _;
3493             }
3494             elsif (_MSWin32_5Cended_path($_)) {
3495 0 0       0 if (-d "$_/.") {
3496 0 0       0 return wantarray ? (-A _,@_) : -A _;
3497             }
3498             else {
3499 0         0 my $fh = gensym();
3500 0 0       0 if (_open_r($fh, $_)) {
3501 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3502 0         0 close $fh;
3503 0         0 my $A = ($^T - $atime) / (24*60*60);
3504 0 0       0 return wantarray ? ($A,@_) : $A;
3505             }
3506             }
3507             }
3508 0 0       0 return wantarray ? (undef,@_) : undef;
3509             }
3510              
3511             #
3512             # UHC file test -C expr
3513             #
3514             sub Euhc::C(;*@) {
3515              
3516 0 0   0 0 0 local $_ = shift if @_;
3517 0 0 0     0 croak 'Too many arguments for -C (Euhc::C)' if @_ and not wantarray;
3518              
3519 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3520 0 0       0 return wantarray ? (-C _,@_) : -C _;
3521             }
3522             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3523 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3524             }
3525             elsif (-e $_) {
3526 0 0       0 return wantarray ? (-C _,@_) : -C _;
3527             }
3528             elsif (_MSWin32_5Cended_path($_)) {
3529 0 0       0 if (-d "$_/.") {
3530 0 0       0 return wantarray ? (-C _,@_) : -C _;
3531             }
3532             else {
3533 0         0 my $fh = gensym();
3534 0 0       0 if (_open_r($fh, $_)) {
3535 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3536 0         0 close $fh;
3537 0         0 my $C = ($^T - $ctime) / (24*60*60);
3538 0 0       0 return wantarray ? ($C,@_) : $C;
3539             }
3540             }
3541             }
3542 0 0       0 return wantarray ? (undef,@_) : undef;
3543             }
3544              
3545             #
3546             # UHC stacked file test $_
3547             #
3548             sub Euhc::filetest_ {
3549              
3550 0     0 0 0 my $filetest = substr(pop @_, 1);
3551              
3552 0 0       0 unless (CORE::eval qq{Euhc::${filetest}_}) {
3553 0         0 return '';
3554             }
3555 0         0 for my $filetest (CORE::reverse @_) {
3556 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3557 0         0 return '';
3558             }
3559             }
3560 0         0 return 1;
3561             }
3562              
3563             #
3564             # UHC file test -r $_
3565             #
3566             sub Euhc::r_() {
3567              
3568 0 0   0 0 0 if (-e $_) {
    0          
3569 0 0       0 return -r _ ? 1 : '';
3570             }
3571             elsif (_MSWin32_5Cended_path($_)) {
3572 0 0       0 if (-d "$_/.") {
3573 0 0       0 return -r _ ? 1 : '';
3574             }
3575             else {
3576 0         0 my $fh = gensym();
3577 0 0       0 if (_open_r($fh, $_)) {
3578 0         0 my $r = -r $fh;
3579 0         0 close $fh;
3580 0 0       0 return $r ? 1 : '';
3581             }
3582             }
3583             }
3584              
3585             # 10.10. Returning Failure
3586             # in Chapter 10. Subroutines
3587             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3588             # (and so on)
3589              
3590             # 2010-01-26 The difference of "return;" and "return undef;"
3591             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3592             #
3593             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3594             # it might be wrong in some cases. If you use this idiom for those functions
3595             # which are expected to return a scalar value, e.g. searching functions, the
3596             # user of those functions will be surprised at what they return in list
3597             # context, an empty list - note that many functions and all the methods
3598             # evaluate their arguments in list context. You'd better to use "return undef;"
3599             # for such scalar functions.
3600             #
3601             # sub search_something {
3602             # my($arg) = @_;
3603             # # search_something...
3604             # if(defined $found){
3605             # return $found;
3606             # }
3607             # return; # XXX: you'd better to "return undef;"
3608             # }
3609             #
3610             # # ...
3611             #
3612             # # you'll get what you want, but ...
3613             # my $something = search_something($source);
3614             #
3615             # # you won't get what you want here.
3616             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3617             # $obj->doit(search_something($source), -option=> $optval);
3618             #
3619             # # you have to use the "scalar" operator in such a case.
3620             # $obj->doit(scalar search_something($source), ...);
3621             #
3622             # *1: it returns an empty list in list context, or returns undef in scalar
3623             # context
3624             #
3625             # (and so on)
3626              
3627 0         0 return undef;
3628             }
3629              
3630             #
3631             # UHC file test -w $_
3632             #
3633             sub Euhc::w_() {
3634              
3635 0 0   0 0 0 if (-e $_) {
    0          
3636 0 0       0 return -w _ ? 1 : '';
3637             }
3638             elsif (_MSWin32_5Cended_path($_)) {
3639 0 0       0 if (-d "$_/.") {
3640 0 0       0 return -w _ ? 1 : '';
3641             }
3642             else {
3643 0         0 my $fh = gensym();
3644 0 0       0 if (_open_a($fh, $_)) {
3645 0         0 my $w = -w $fh;
3646 0         0 close $fh;
3647 0 0       0 return $w ? 1 : '';
3648             }
3649             }
3650             }
3651 0         0 return undef;
3652             }
3653              
3654             #
3655             # UHC file test -x $_
3656             #
3657             sub Euhc::x_() {
3658              
3659 0 0   0 0 0 if (-e $_) {
    0          
3660 0 0       0 return -x _ ? 1 : '';
3661             }
3662             elsif (_MSWin32_5Cended_path($_)) {
3663 0 0       0 if (-d "$_/.") {
3664 0 0       0 return -x _ ? 1 : '';
3665             }
3666             else {
3667 0         0 my $fh = gensym();
3668 0 0       0 if (_open_r($fh, $_)) {
3669 0         0 my $dummy_for_underline_cache = -x $fh;
3670 0         0 close $fh;
3671             }
3672              
3673             # filename is not .COM .EXE .BAT .CMD
3674 0         0 return '';
3675             }
3676             }
3677 0         0 return undef;
3678             }
3679              
3680             #
3681             # UHC file test -o $_
3682             #
3683             sub Euhc::o_() {
3684              
3685 0 0   0 0 0 if (-e $_) {
    0          
3686 0 0       0 return -o _ ? 1 : '';
3687             }
3688             elsif (_MSWin32_5Cended_path($_)) {
3689 0 0       0 if (-d "$_/.") {
3690 0 0       0 return -o _ ? 1 : '';
3691             }
3692             else {
3693 0         0 my $fh = gensym();
3694 0 0       0 if (_open_r($fh, $_)) {
3695 0         0 my $o = -o $fh;
3696 0         0 close $fh;
3697 0 0       0 return $o ? 1 : '';
3698             }
3699             }
3700             }
3701 0         0 return undef;
3702             }
3703              
3704             #
3705             # UHC file test -R $_
3706             #
3707             sub Euhc::R_() {
3708              
3709 0 0   0 0 0 if (-e $_) {
    0          
3710 0 0       0 return -R _ ? 1 : '';
3711             }
3712             elsif (_MSWin32_5Cended_path($_)) {
3713 0 0       0 if (-d "$_/.") {
3714 0 0       0 return -R _ ? 1 : '';
3715             }
3716             else {
3717 0         0 my $fh = gensym();
3718 0 0       0 if (_open_r($fh, $_)) {
3719 0         0 my $R = -R $fh;
3720 0         0 close $fh;
3721 0 0       0 return $R ? 1 : '';
3722             }
3723             }
3724             }
3725 0         0 return undef;
3726             }
3727              
3728             #
3729             # UHC file test -W $_
3730             #
3731             sub Euhc::W_() {
3732              
3733 0 0   0 0 0 if (-e $_) {
    0          
3734 0 0       0 return -W _ ? 1 : '';
3735             }
3736             elsif (_MSWin32_5Cended_path($_)) {
3737 0 0       0 if (-d "$_/.") {
3738 0 0       0 return -W _ ? 1 : '';
3739             }
3740             else {
3741 0         0 my $fh = gensym();
3742 0 0       0 if (_open_a($fh, $_)) {
3743 0         0 my $W = -W $fh;
3744 0         0 close $fh;
3745 0 0       0 return $W ? 1 : '';
3746             }
3747             }
3748             }
3749 0         0 return undef;
3750             }
3751              
3752             #
3753             # UHC file test -X $_
3754             #
3755             sub Euhc::X_() {
3756              
3757 0 0   0 0 0 if (-e $_) {
    0          
3758 0 0       0 return -X _ ? 1 : '';
3759             }
3760             elsif (_MSWin32_5Cended_path($_)) {
3761 0 0       0 if (-d "$_/.") {
3762 0 0       0 return -X _ ? 1 : '';
3763             }
3764             else {
3765 0         0 my $fh = gensym();
3766 0 0       0 if (_open_r($fh, $_)) {
3767 0         0 my $dummy_for_underline_cache = -X $fh;
3768 0         0 close $fh;
3769             }
3770              
3771             # filename is not .COM .EXE .BAT .CMD
3772 0         0 return '';
3773             }
3774             }
3775 0         0 return undef;
3776             }
3777              
3778             #
3779             # UHC file test -O $_
3780             #
3781             sub Euhc::O_() {
3782              
3783 0 0   0 0 0 if (-e $_) {
    0          
3784 0 0       0 return -O _ ? 1 : '';
3785             }
3786             elsif (_MSWin32_5Cended_path($_)) {
3787 0 0       0 if (-d "$_/.") {
3788 0 0       0 return -O _ ? 1 : '';
3789             }
3790             else {
3791 0         0 my $fh = gensym();
3792 0 0       0 if (_open_r($fh, $_)) {
3793 0         0 my $O = -O $fh;
3794 0         0 close $fh;
3795 0 0       0 return $O ? 1 : '';
3796             }
3797             }
3798             }
3799 0         0 return undef;
3800             }
3801              
3802             #
3803             # UHC file test -e $_
3804             #
3805             sub Euhc::e_() {
3806              
3807 0 0   0 0 0 if (-e $_) {
    0          
3808 0         0 return 1;
3809             }
3810             elsif (_MSWin32_5Cended_path($_)) {
3811 0 0       0 if (-d "$_/.") {
3812 0         0 return 1;
3813             }
3814             else {
3815 0         0 my $fh = gensym();
3816 0 0       0 if (_open_r($fh, $_)) {
3817 0         0 my $e = -e $fh;
3818 0         0 close $fh;
3819 0 0       0 return $e ? 1 : '';
3820             }
3821             }
3822             }
3823 0         0 return undef;
3824             }
3825              
3826             #
3827             # UHC file test -z $_
3828             #
3829             sub Euhc::z_() {
3830              
3831 0 0   0 0 0 if (-e $_) {
    0          
3832 0 0       0 return -z _ ? 1 : '';
3833             }
3834             elsif (_MSWin32_5Cended_path($_)) {
3835 0 0       0 if (-d "$_/.") {
3836 0 0       0 return -z _ ? 1 : '';
3837             }
3838             else {
3839 0         0 my $fh = gensym();
3840 0 0       0 if (_open_r($fh, $_)) {
3841 0         0 my $z = -z $fh;
3842 0         0 close $fh;
3843 0 0       0 return $z ? 1 : '';
3844             }
3845             }
3846             }
3847 0         0 return undef;
3848             }
3849              
3850             #
3851             # UHC file test -s $_
3852             #
3853             sub Euhc::s_() {
3854              
3855 0 0   0 0 0 if (-e $_) {
    0          
3856 0         0 return -s _;
3857             }
3858             elsif (_MSWin32_5Cended_path($_)) {
3859 0 0       0 if (-d "$_/.") {
3860 0         0 return -s _;
3861             }
3862             else {
3863 0         0 my $fh = gensym();
3864 0 0       0 if (_open_r($fh, $_)) {
3865 0         0 my $s = -s $fh;
3866 0         0 close $fh;
3867 0         0 return $s;
3868             }
3869             }
3870             }
3871 0         0 return undef;
3872             }
3873              
3874             #
3875             # UHC file test -f $_
3876             #
3877             sub Euhc::f_() {
3878              
3879 0 0   0 0 0 if (-e $_) {
    0          
3880 0 0       0 return -f _ ? 1 : '';
3881             }
3882             elsif (_MSWin32_5Cended_path($_)) {
3883 0 0       0 if (-d "$_/.") {
3884 0         0 return '';
3885             }
3886             else {
3887 0         0 my $fh = gensym();
3888 0 0       0 if (_open_r($fh, $_)) {
3889 0         0 my $f = -f $fh;
3890 0         0 close $fh;
3891 0 0       0 return $f ? 1 : '';
3892             }
3893             }
3894             }
3895 0         0 return undef;
3896             }
3897              
3898             #
3899             # UHC file test -d $_
3900             #
3901             sub Euhc::d_() {
3902              
3903 0 0   0 0 0 if (-e $_) {
    0          
3904 0 0       0 return -d _ ? 1 : '';
3905             }
3906             elsif (_MSWin32_5Cended_path($_)) {
3907 0 0       0 return -d "$_/." ? 1 : '';
3908             }
3909 0         0 return undef;
3910             }
3911              
3912             #
3913             # UHC file test -l $_
3914             #
3915             sub Euhc::l_() {
3916              
3917 0 0   0 0 0 if (-e $_) {
    0          
3918 0 0       0 return -l _ ? 1 : '';
3919             }
3920             elsif (_MSWin32_5Cended_path($_)) {
3921 0 0       0 if (-d "$_/.") {
3922 0 0       0 return -l _ ? 1 : '';
3923             }
3924             else {
3925 0         0 my $fh = gensym();
3926 0 0       0 if (_open_r($fh, $_)) {
3927 0         0 my $l = -l $fh;
3928 0         0 close $fh;
3929 0 0       0 return $l ? 1 : '';
3930             }
3931             }
3932             }
3933 0         0 return undef;
3934             }
3935              
3936             #
3937             # UHC file test -p $_
3938             #
3939             sub Euhc::p_() {
3940              
3941 0 0   0 0 0 if (-e $_) {
    0          
3942 0 0       0 return -p _ ? 1 : '';
3943             }
3944             elsif (_MSWin32_5Cended_path($_)) {
3945 0 0       0 if (-d "$_/.") {
3946 0 0       0 return -p _ ? 1 : '';
3947             }
3948             else {
3949 0         0 my $fh = gensym();
3950 0 0       0 if (_open_r($fh, $_)) {
3951 0         0 my $p = -p $fh;
3952 0         0 close $fh;
3953 0 0       0 return $p ? 1 : '';
3954             }
3955             }
3956             }
3957 0         0 return undef;
3958             }
3959              
3960             #
3961             # UHC file test -S $_
3962             #
3963             sub Euhc::S_() {
3964              
3965 0 0   0 0 0 if (-e $_) {
    0          
3966 0 0       0 return -S _ ? 1 : '';
3967             }
3968             elsif (_MSWin32_5Cended_path($_)) {
3969 0 0       0 if (-d "$_/.") {
3970 0 0       0 return -S _ ? 1 : '';
3971             }
3972             else {
3973 0         0 my $fh = gensym();
3974 0 0       0 if (_open_r($fh, $_)) {
3975 0         0 my $S = -S $fh;
3976 0         0 close $fh;
3977 0 0       0 return $S ? 1 : '';
3978             }
3979             }
3980             }
3981 0         0 return undef;
3982             }
3983              
3984             #
3985             # UHC file test -b $_
3986             #
3987             sub Euhc::b_() {
3988              
3989 0 0   0 0 0 if (-e $_) {
    0          
3990 0 0       0 return -b _ ? 1 : '';
3991             }
3992             elsif (_MSWin32_5Cended_path($_)) {
3993 0 0       0 if (-d "$_/.") {
3994 0 0       0 return -b _ ? 1 : '';
3995             }
3996             else {
3997 0         0 my $fh = gensym();
3998 0 0       0 if (_open_r($fh, $_)) {
3999 0         0 my $b = -b $fh;
4000 0         0 close $fh;
4001 0 0       0 return $b ? 1 : '';
4002             }
4003             }
4004             }
4005 0         0 return undef;
4006             }
4007              
4008             #
4009             # UHC file test -c $_
4010             #
4011             sub Euhc::c_() {
4012              
4013 0 0   0 0 0 if (-e $_) {
    0          
4014 0 0       0 return -c _ ? 1 : '';
4015             }
4016             elsif (_MSWin32_5Cended_path($_)) {
4017 0 0       0 if (-d "$_/.") {
4018 0 0       0 return -c _ ? 1 : '';
4019             }
4020             else {
4021 0         0 my $fh = gensym();
4022 0 0       0 if (_open_r($fh, $_)) {
4023 0         0 my $c = -c $fh;
4024 0         0 close $fh;
4025 0 0       0 return $c ? 1 : '';
4026             }
4027             }
4028             }
4029 0         0 return undef;
4030             }
4031              
4032             #
4033             # UHC file test -u $_
4034             #
4035             sub Euhc::u_() {
4036              
4037 0 0   0 0 0 if (-e $_) {
    0          
4038 0 0       0 return -u _ ? 1 : '';
4039             }
4040             elsif (_MSWin32_5Cended_path($_)) {
4041 0 0       0 if (-d "$_/.") {
4042 0 0       0 return -u _ ? 1 : '';
4043             }
4044             else {
4045 0         0 my $fh = gensym();
4046 0 0       0 if (_open_r($fh, $_)) {
4047 0         0 my $u = -u $fh;
4048 0         0 close $fh;
4049 0 0       0 return $u ? 1 : '';
4050             }
4051             }
4052             }
4053 0         0 return undef;
4054             }
4055              
4056             #
4057             # UHC file test -g $_
4058             #
4059             sub Euhc::g_() {
4060              
4061 0 0   0 0 0 if (-e $_) {
    0          
4062 0 0       0 return -g _ ? 1 : '';
4063             }
4064             elsif (_MSWin32_5Cended_path($_)) {
4065 0 0       0 if (-d "$_/.") {
4066 0 0       0 return -g _ ? 1 : '';
4067             }
4068             else {
4069 0         0 my $fh = gensym();
4070 0 0       0 if (_open_r($fh, $_)) {
4071 0         0 my $g = -g $fh;
4072 0         0 close $fh;
4073 0 0       0 return $g ? 1 : '';
4074             }
4075             }
4076             }
4077 0         0 return undef;
4078             }
4079              
4080             #
4081             # UHC file test -k $_
4082             #
4083             sub Euhc::k_() {
4084              
4085 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4086 0 0       0 return wantarray ? ('',@_) : '';
4087             }
4088 0 0       0 return wantarray ? ($_,@_) : $_;
4089             }
4090              
4091             #
4092             # UHC file test -T $_
4093             #
4094             sub Euhc::T_() {
4095              
4096 0     0 0 0 my $T = 1;
4097              
4098 0 0 0     0 if (-d $_ or -d "$_/.") {
4099 0         0 return undef;
4100             }
4101 0         0 my $fh = gensym();
4102 0 0       0 if (_open_r($fh, $_)) {
4103             }
4104             else {
4105 0         0 return undef;
4106             }
4107              
4108 0 0       0 if (sysread $fh, my $block, 512) {
4109 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4110 0         0 $T = '';
4111             }
4112             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4113 0         0 $T = '';
4114             }
4115             }
4116              
4117             # 0 byte or eof
4118             else {
4119 0         0 $T = 1;
4120             }
4121 0         0 my $dummy_for_underline_cache = -T $fh;
4122 0         0 close $fh;
4123              
4124 0         0 return $T;
4125             }
4126              
4127             #
4128             # UHC file test -B $_
4129             #
4130             sub Euhc::B_() {
4131              
4132 0     0 0 0 my $B = '';
4133              
4134 0 0 0     0 if (-d $_ or -d "$_/.") {
4135 0         0 return undef;
4136             }
4137 0         0 my $fh = gensym();
4138 0 0       0 if (_open_r($fh, $_)) {
4139             }
4140             else {
4141 0         0 return undef;
4142             }
4143              
4144 0 0       0 if (sysread $fh, my $block, 512) {
4145 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4146 0         0 $B = 1;
4147             }
4148             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4149 0         0 $B = 1;
4150             }
4151             }
4152              
4153             # 0 byte or eof
4154             else {
4155 0         0 $B = 1;
4156             }
4157 0         0 my $dummy_for_underline_cache = -B $fh;
4158 0         0 close $fh;
4159              
4160 0         0 return $B;
4161             }
4162              
4163             #
4164             # UHC file test -M $_
4165             #
4166             sub Euhc::M_() {
4167              
4168 0 0   0 0 0 if (-e $_) {
    0          
4169 0         0 return -M _;
4170             }
4171             elsif (_MSWin32_5Cended_path($_)) {
4172 0 0       0 if (-d "$_/.") {
4173 0         0 return -M _;
4174             }
4175             else {
4176 0         0 my $fh = gensym();
4177 0 0       0 if (_open_r($fh, $_)) {
4178 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4179 0         0 close $fh;
4180 0         0 my $M = ($^T - $mtime) / (24*60*60);
4181 0         0 return $M;
4182             }
4183             }
4184             }
4185 0         0 return undef;
4186             }
4187              
4188             #
4189             # UHC file test -A $_
4190             #
4191             sub Euhc::A_() {
4192              
4193 0 0   0 0 0 if (-e $_) {
    0          
4194 0         0 return -A _;
4195             }
4196             elsif (_MSWin32_5Cended_path($_)) {
4197 0 0       0 if (-d "$_/.") {
4198 0         0 return -A _;
4199             }
4200             else {
4201 0         0 my $fh = gensym();
4202 0 0       0 if (_open_r($fh, $_)) {
4203 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4204 0         0 close $fh;
4205 0         0 my $A = ($^T - $atime) / (24*60*60);
4206 0         0 return $A;
4207             }
4208             }
4209             }
4210 0         0 return undef;
4211             }
4212              
4213             #
4214             # UHC file test -C $_
4215             #
4216             sub Euhc::C_() {
4217              
4218 0 0   0 0 0 if (-e $_) {
    0          
4219 0         0 return -C _;
4220             }
4221             elsif (_MSWin32_5Cended_path($_)) {
4222 0 0       0 if (-d "$_/.") {
4223 0         0 return -C _;
4224             }
4225             else {
4226 0         0 my $fh = gensym();
4227 0 0       0 if (_open_r($fh, $_)) {
4228 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4229 0         0 close $fh;
4230 0         0 my $C = ($^T - $ctime) / (24*60*60);
4231 0         0 return $C;
4232             }
4233             }
4234             }
4235 0         0 return undef;
4236             }
4237              
4238             #
4239             # UHC path globbing (with parameter)
4240             #
4241             sub Euhc::glob($) {
4242              
4243 0 0   0 0 0 if (wantarray) {
4244 0         0 my @glob = _DOS_like_glob(@_);
4245 0         0 for my $glob (@glob) {
4246 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4247             }
4248 0         0 return @glob;
4249             }
4250             else {
4251 0         0 my $glob = _DOS_like_glob(@_);
4252 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4253 0         0 return $glob;
4254             }
4255             }
4256              
4257             #
4258             # UHC path globbing (without parameter)
4259             #
4260             sub Euhc::glob_() {
4261              
4262 0 0   0 0 0 if (wantarray) {
4263 0         0 my @glob = _DOS_like_glob();
4264 0         0 for my $glob (@glob) {
4265 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4266             }
4267 0         0 return @glob;
4268             }
4269             else {
4270 0         0 my $glob = _DOS_like_glob();
4271 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4272 0         0 return $glob;
4273             }
4274             }
4275              
4276             #
4277             # UHC path globbing via File::DosGlob 1.10
4278             #
4279             # Often I confuse "_dosglob" and "_doglob".
4280             # So, I renamed "_dosglob" to "_DOS_like_glob".
4281             #
4282             my %iter;
4283             my %entries;
4284             sub _DOS_like_glob {
4285              
4286             # context (keyed by second cxix argument provided by core)
4287 0     0   0 my($expr,$cxix) = @_;
4288              
4289             # glob without args defaults to $_
4290 0 0       0 $expr = $_ if not defined $expr;
4291              
4292             # represents the current user's home directory
4293             #
4294             # 7.3. Expanding Tildes in Filenames
4295             # in Chapter 7. File Access
4296             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4297             #
4298             # and File::HomeDir, File::HomeDir::Windows module
4299              
4300             # DOS-like system
4301 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4302 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4303             { my_home_MSWin32() }oxmse;
4304             }
4305              
4306             # UNIX-like system
4307 0 0 0     0 else {
  0         0  
4308             $expr =~ s{ \A ~ ( (?:[^\x81-\xFE/]|[\x81-\xFE][\x00-\xFF])* ) }
4309             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4310             }
4311 0 0       0  
4312 0 0       0 # assume global context if not provided one
4313             $cxix = '_G_' if not defined $cxix;
4314             $iter{$cxix} = 0 if not exists $iter{$cxix};
4315 0 0       0  
4316 0         0 # if we're just beginning, do it all first
4317             if ($iter{$cxix} == 0) {
4318             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4319             }
4320 0 0       0  
4321 0         0 # chuck it all out, quick or slow
4322 0         0 if (wantarray) {
  0         0  
4323             delete $iter{$cxix};
4324             return @{delete $entries{$cxix}};
4325 0 0       0 }
  0         0  
4326 0         0 else {
  0         0  
4327             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4328             return shift @{$entries{$cxix}};
4329             }
4330 0         0 else {
4331 0         0 # return undef for EOL
4332 0         0 delete $iter{$cxix};
4333             delete $entries{$cxix};
4334             return undef;
4335             }
4336             }
4337             }
4338              
4339             #
4340             # UHC path globbing subroutine
4341             #
4342 0     0   0 sub _do_glob {
4343 0         0  
4344 0         0 my($cond,@expr) = @_;
4345             my @glob = ();
4346             my $fix_drive_relative_paths = 0;
4347 0         0  
4348 0 0       0 OUTER:
4349 0 0       0 for my $expr (@expr) {
4350             next OUTER if not defined $expr;
4351 0         0 next OUTER if $expr eq '';
4352 0         0  
4353 0         0 my @matched = ();
4354 0         0 my @globdir = ();
4355 0         0 my $head = '.';
4356             my $pathsep = '/';
4357             my $tail;
4358 0 0       0  
4359 0         0 # if argument is within quotes strip em and do no globbing
4360 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4361 0 0       0 $expr = $1;
4362 0         0 if ($cond eq 'd') {
4363             if (Euhc::d $expr) {
4364             push @glob, $expr;
4365             }
4366 0 0       0 }
4367 0         0 else {
4368             if (Euhc::e $expr) {
4369             push @glob, $expr;
4370 0         0 }
4371             }
4372             next OUTER;
4373             }
4374              
4375 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4376 0 0       0 # to h:./*.pm to expand correctly
4377 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4378             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\xFE/\\]|[\x81-\xFE][\x00-\xFF]) #$1./$2#oxms) {
4379             $fix_drive_relative_paths = 1;
4380             }
4381 0 0       0 }
4382 0 0       0  
4383 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4384 0         0 if ($tail eq '') {
4385             push @glob, $expr;
4386 0 0       0 next OUTER;
4387 0 0       0 }
4388 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
  0         0  
4389 0         0 if (@globdir = _do_glob('d', $head)) {
4390             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4391             next OUTER;
4392 0 0 0     0 }
4393 0         0 }
4394             if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4395 0         0 $head .= $pathsep;
4396             }
4397             $expr = $tail;
4398             }
4399 0 0       0  
4400 0 0       0 # If file component has no wildcards, we can avoid opendir
4401 0         0 if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4402             if ($head eq '.') {
4403 0 0 0     0 $head = '';
4404 0         0 }
4405             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4406 0         0 $head .= $pathsep;
4407 0 0       0 }
4408 0 0       0 $head .= $expr;
4409 0         0 if ($cond eq 'd') {
4410             if (Euhc::d $head) {
4411             push @glob, $head;
4412             }
4413 0 0       0 }
4414 0         0 else {
4415             if (Euhc::e $head) {
4416             push @glob, $head;
4417 0         0 }
4418             }
4419 0 0       0 next OUTER;
4420 0         0 }
4421 0         0 Euhc::opendir(*DIR, $head) or next OUTER;
4422             my @leaf = readdir DIR;
4423 0 0       0 closedir DIR;
4424 0         0  
4425             if ($head eq '.') {
4426 0 0 0     0 $head = '';
4427 0         0 }
4428             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4429             $head .= $pathsep;
4430 0         0 }
4431 0         0  
4432 0         0 my $pattern = '';
4433             while ($expr =~ / \G ($q_char) /oxgc) {
4434             my $char = $1;
4435              
4436             # 6.9. Matching Shell Globs as Regular Expressions
4437             # in Chapter 6. Pattern Matching
4438             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4439 0 0       0 # (and so on)
    0          
    0          
4440 0         0  
4441             if ($char eq '*') {
4442             $pattern .= "(?:$your_char)*",
4443 0         0 }
4444             elsif ($char eq '?') {
4445             $pattern .= "(?:$your_char)?", # DOS style
4446             # $pattern .= "(?:$your_char)", # UNIX style
4447 0         0 }
4448             elsif ((my $fc = Euhc::fc($char)) ne $char) {
4449             $pattern .= $fc;
4450 0         0 }
4451             else {
4452             $pattern .= quotemeta $char;
4453 0     0   0 }
  0         0  
4454             }
4455             my $matchsub = sub { Euhc::fc($_[0]) =~ /\A $pattern \z/xms };
4456              
4457             # if ($@) {
4458             # print STDERR "$0: $@\n";
4459             # next OUTER;
4460             # }
4461 0         0  
4462 0 0 0     0 INNER:
4463 0         0 for my $leaf (@leaf) {
4464             if ($leaf eq '.' or $leaf eq '..') {
4465 0 0 0     0 next INNER;
4466 0         0 }
4467             if ($cond eq 'd' and not Euhc::d "$head$leaf") {
4468             next INNER;
4469 0 0       0 }
4470 0         0  
4471 0         0 if (&$matchsub($leaf)) {
4472             push @matched, "$head$leaf";
4473             next INNER;
4474             }
4475              
4476             # [DOS compatibility special case]
4477 0 0 0     0 # Failed, add a trailing dot and try again, but only...
      0        
4478              
4479             if (Euhc::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4480             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4481 0 0       0 Euhc::index($pattern,'\\.') != -1 # pattern has a dot.
4482 0         0 ) {
4483 0         0 if (&$matchsub("$leaf.")) {
4484             push @matched, "$head$leaf";
4485             next INNER;
4486             }
4487 0 0       0 }
4488 0         0 }
4489             if (@matched) {
4490             push @glob, @matched;
4491 0 0       0 }
4492 0         0 }
4493 0         0 if ($fix_drive_relative_paths) {
4494             for my $glob (@glob) {
4495             $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4496 0         0 }
4497             }
4498             return @glob;
4499             }
4500              
4501             #
4502             # UHC parse line
4503             #
4504 0     0   0 sub _parse_line {
4505              
4506 0         0 my($line) = @_;
4507 0         0  
4508 0         0 $line .= ' ';
4509             my @piece = ();
4510             while ($line =~ /
4511             " ( (?>(?: [^\x81-\xFE"] |[\x81-\xFE][\x00-\xFF] )* ) ) " (?>\s+) |
4512             ( (?>(?: [^\x81-\xFE"\s]|[\x81-\xFE][\x00-\xFF] )* ) ) (?>\s+)
4513 0 0       0 /oxmsg
4514             ) {
4515 0         0 push @piece, defined($1) ? $1 : $2;
4516             }
4517             return @piece;
4518             }
4519              
4520             #
4521             # UHC parse path
4522             #
4523 0     0   0 sub _parse_path {
4524              
4525 0         0 my($path,$pathsep) = @_;
4526 0         0  
4527 0         0 $path .= '/';
4528             my @subpath = ();
4529             while ($path =~ /
4530             ((?: [^\x81-\xFE\/\\]|[\x81-\xFE][\x00-\xFF] )+?) [\/\\]
4531 0         0 /oxmsg
4532             ) {
4533             push @subpath, $1;
4534 0         0 }
4535 0         0  
4536 0         0 my $tail = pop @subpath;
4537             my $head = join $pathsep, @subpath;
4538             return $head, $tail;
4539             }
4540              
4541             #
4542             # via File::HomeDir::Windows 1.00
4543             #
4544             sub my_home_MSWin32 {
4545              
4546             # A lot of unix people and unix-derived tools rely on
4547 0 0 0 0 0 0 # the ability to overload HOME. We will support it too
    0 0        
    0 0        
      0        
      0        
4548 0         0 # so that they can replace raw HOME calls with File::HomeDir.
4549             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4550             return $ENV{'HOME'};
4551             }
4552              
4553 0         0 # Do we have a user profile?
4554             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4555             return $ENV{'USERPROFILE'};
4556             }
4557              
4558 0         0 # Some Windows use something like $ENV{'HOME'}
4559             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4560             return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4561 0         0 }
4562              
4563             return undef;
4564             }
4565              
4566             #
4567             # via File::HomeDir::Unix 1.00
4568 0     0 0 0 #
4569             sub my_home {
4570 0 0 0     0 my $home;
    0 0        
4571 0         0  
4572             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4573             $home = $ENV{'HOME'};
4574             }
4575              
4576             # This is from the original code, but I'm guessing
4577 0         0 # it means "login directory" and exists on some Unixes.
4578             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4579             $home = $ENV{'LOGDIR'};
4580             }
4581              
4582             ### More-desperate methods
4583              
4584 0         0 # Light desperation on any (Unixish) platform
4585             else {
4586             $home = CORE::eval q{ (getpwuid($<))[7] };
4587             }
4588              
4589 0 0 0     0 # On Unix in general, a non-existant home means "no home"
4590 0         0 # For example, "nobody"-like users might use /nonexistant
4591             if (defined $home and ! Euhc::d($home)) {
4592 0         0 $home = undef;
4593             }
4594             return $home;
4595             }
4596              
4597             #
4598             # UHC file lstat (with parameter)
4599             #
4600 0 0   0 0 0 sub Euhc::lstat(*) {
4601              
4602 0 0       0 local $_ = shift if @_;
    0          
4603 0         0  
4604             if (-e $_) {
4605             return CORE::lstat _;
4606             }
4607             elsif (_MSWin32_5Cended_path($_)) {
4608              
4609             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Euhc::lstat()
4610             # on Windows opens the file for the path which has 5c at end.
4611 0         0 # (and so on)
4612 0 0       0  
4613 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4614 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4615 0         0 if (wantarray) {
4616 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4617             close MUST_BE_BAREWORD_AT_HERE;
4618             return @stat;
4619 0         0 }
4620 0         0 else {
4621 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4622             close MUST_BE_BAREWORD_AT_HERE;
4623             return $stat;
4624             }
4625 0 0       0 }
4626             }
4627             return wantarray ? () : undef;
4628             }
4629              
4630             #
4631             # UHC file lstat (without parameter)
4632             #
4633 0 0   0 0 0 sub Euhc::lstat_() {
    0          
4634 0         0  
4635             if (-e $_) {
4636             return CORE::lstat _;
4637 0         0 }
4638 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4639 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4640 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4641 0         0 if (wantarray) {
4642 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4643             close MUST_BE_BAREWORD_AT_HERE;
4644             return @stat;
4645 0         0 }
4646 0         0 else {
4647 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4648             close MUST_BE_BAREWORD_AT_HERE;
4649             return $stat;
4650             }
4651 0 0       0 }
4652             }
4653             return wantarray ? () : undef;
4654             }
4655              
4656             #
4657             # UHC path opendir
4658             #
4659 0     0 0 0 sub Euhc::opendir(*$) {
4660 0 0       0  
    0          
4661 0         0 my $dh = qualify_to_ref $_[0];
4662             if (CORE::opendir $dh, $_[1]) {
4663             return 1;
4664 0 0       0 }
4665 0         0 elsif (_MSWin32_5Cended_path($_[1])) {
4666             if (CORE::opendir $dh, "$_[1]/.") {
4667             return 1;
4668 0         0 }
4669             }
4670             return undef;
4671             }
4672              
4673             #
4674             # UHC file stat (with parameter)
4675             #
4676 0 50   384 0 0 sub Euhc::stat(*) {
4677              
4678 384         2606 local $_ = shift if @_;
4679 384 50       2653  
    50          
    0          
4680 384         15388 my $fh = qualify_to_ref $_;
4681             if (defined fileno $fh) {
4682             return CORE::stat $fh;
4683 0         0 }
4684             elsif (-e $_) {
4685             return CORE::stat _;
4686             }
4687             elsif (_MSWin32_5Cended_path($_)) {
4688              
4689             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Euhc::stat()
4690             # on Windows opens the file for the path which has 5c at end.
4691 384         4772 # (and so on)
4692 0 0       0  
4693 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4694 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4695 0         0 if (wantarray) {
4696 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4697             close MUST_BE_BAREWORD_AT_HERE;
4698             return @stat;
4699 0         0 }
4700 0         0 else {
4701 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4702             close MUST_BE_BAREWORD_AT_HERE;
4703             return $stat;
4704             }
4705 0 0       0 }
4706             }
4707             return wantarray ? () : undef;
4708             }
4709              
4710             #
4711             # UHC file stat (without parameter)
4712             #
4713 0     0 0 0 sub Euhc::stat_() {
4714 0 0       0  
    0          
    0          
4715 0         0 my $fh = qualify_to_ref $_;
4716             if (defined fileno $fh) {
4717             return CORE::stat $fh;
4718 0         0 }
4719             elsif (-e $_) {
4720             return CORE::stat _;
4721 0         0 }
4722 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4723 0 0       0 local *MUST_BE_BAREWORD_AT_HERE;
4724 0         0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4725 0         0 if (wantarray) {
4726 0         0 my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4727             close MUST_BE_BAREWORD_AT_HERE;
4728             return @stat;
4729 0         0 }
4730 0         0 else {
4731 0         0 my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
4732             close MUST_BE_BAREWORD_AT_HERE;
4733             return $stat;
4734             }
4735 0 0       0 }
4736             }
4737             return wantarray ? () : undef;
4738             }
4739              
4740             #
4741             # UHC path unlink
4742             #
4743 0 0   0 0 0 sub Euhc::unlink(@) {
4744              
4745 0         0 local @_ = ($_) unless @_;
4746 0         0  
4747 0 0       0 my $unlink = 0;
    0          
    0          
4748 0         0 for (@_) {
4749             if (CORE::unlink) {
4750             $unlink++;
4751             }
4752             elsif (Euhc::d($_)) {
4753 0         0 }
4754 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
  0         0  
4755 0 0       0 my @char = /\G (?>$q_char) /oxmsg;
4756 0         0 my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
4757             if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
4758 0         0 $file = qq{"$file"};
4759 0 0       0 }
4760 0         0 my $fh = gensym();
4761             if (_open_r($fh, $_)) {
4762             close $fh;
4763 0 0 0     0  
    0          
4764 0         0 # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
4765             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
4766             CORE::system 'DEL', '/F', $file, '2>NUL';
4767             }
4768              
4769 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
4770             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
4771             CORE::system 'DEL', '/F', $file, '2>NUL';
4772             }
4773              
4774             # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
4775 0         0 # command.com can not "2>NUL"
4776 0         0 else {
4777             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
4778             CORE::system 'DEL', $file;
4779 0 0       0 }
4780 0         0  
4781             if (_open_r($fh, $_)) {
4782             close $fh;
4783 0         0 }
4784             else {
4785             $unlink++;
4786             }
4787             }
4788 0         0 }
4789             }
4790             return $unlink;
4791             }
4792              
4793             #
4794             # UHC chdir
4795             #
4796 0 0   0 0 0 sub Euhc::chdir(;$) {
4797 0         0  
4798             if (@_ == 0) {
4799             return CORE::chdir;
4800 0         0 }
4801              
4802 0 0       0 my($dir) = @_;
4803 0 0       0  
4804 0         0 if (_MSWin32_5Cended_path($dir)) {
4805             if (not Euhc::d $dir) {
4806             return 0;
4807 0 0 0     0 }
    0          
4808 0         0  
4809             if ($] =~ /^5\.005/oxms) {
4810             return CORE::chdir $dir;
4811 0         0 }
4812 0         0 elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
4813             local $@;
4814             my $chdir = CORE::eval q{
4815             CORE::require 'jacode.pl';
4816              
4817             # P.676 ${^WIDE_SYSTEM_CALLS}
4818             # in Chapter 28: Special Names
4819             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4820              
4821             # P.790 ${^WIDE_SYSTEM_CALLS}
4822             # in Chapter 25: Special Names
4823             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4824              
4825             local ${^WIDE_SYSTEM_CALLS} = 1;
4826 0 0       0 return CORE::chdir jcode::utf8($dir,'sjis');
4827 0         0 };
4828             if (not $@) {
4829             return $chdir;
4830             }
4831             }
4832              
4833             # old idea (Win32 module required)
4834             elsif (0) {
4835             local $@;
4836             my $shortdir = '';
4837             my $chdir = CORE::eval q{
4838             use Win32;
4839             $shortdir = Win32::GetShortPathName($dir);
4840             if ($shortdir ne $dir) {
4841             return CORE::chdir $shortdir;
4842             }
4843             else {
4844             return 0;
4845             }
4846             };
4847             if ($@) {
4848             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4849             while ($char[-1] eq "\x5C") {
4850             pop @char;
4851             }
4852             $dir = join '', @char;
4853             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
4854             }
4855             elsif ($shortdir eq $dir) {
4856             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
4857             while ($char[-1] eq "\x5C") {
4858             pop @char;
4859             }
4860             $dir = join '', @char;
4861             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
4862             }
4863             return $chdir;
4864             }
4865 0         0  
4866             # rejected idea ...
4867             elsif (0) {
4868              
4869             # MSDN SetCurrentDirectory function
4870             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
4871             #
4872             # Data Execution Prevention (DEP)
4873             # http://vlaurie.com/computers2/Articles/dep.htm
4874             #
4875             # Learning x86 assembler with Perl -- Shibuya.pm#11
4876             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
4877             #
4878             # Introduction to Win32::API programming in Perl
4879             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
4880             #
4881             # DynaLoader - Dynamically load C libraries into Perl code
4882             # http://perldoc.perl.org/DynaLoader.html
4883             #
4884             # Basic knowledge of DynaLoader
4885             # http://blog.64p.org/entry/20090313/1236934042
4886              
4887             if (($] =~ /^5\.006/oxms) and
4888             ($^O eq 'MSWin32') and
4889             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
4890             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
4891             ) {
4892             my $x86 = join('',
4893              
4894             # PUSH Iv
4895             "\x68", pack('P', "$dir\\\0"),
4896              
4897             # MOV eAX, Iv
4898             "\xb8", pack('L',
4899             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
4900             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
4901             'SetCurrentDirectoryA'
4902             )
4903             ),
4904              
4905             # CALL eAX
4906             "\xff\xd0",
4907              
4908             # RETN
4909             "\xc3",
4910             );
4911             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
4912             _SetCurrentDirectoryA();
4913             chomp(my $chdir = qx{chdir});
4914             if (Euhc::fc($chdir) eq Euhc::fc($dir)) {
4915             return 1;
4916             }
4917             else {
4918             return 0;
4919             }
4920             }
4921             }
4922              
4923             # COMMAND.COM's unhelpful tips:
4924             # Displays a list of files and subdirectories in a directory.
4925             # http://www.lagmonster.org/docs/DOS7/z-dir.html
4926             #
4927             # Syntax:
4928             #
4929             # DIR [drive:] [path] [filename] [/Switches]
4930             #
4931             # /Z Long file names are not displayed in the file listing
4932             #
4933             # Limitations
4934             # The undocumented /Z switch (no long names) would appear to
4935             # have been not fully developed and has a couple of problems:
4936             #
4937             # 1. It will only work if:
4938             # There is no path specified (ie. for the current directory in
4939             # the current drive)
4940             # The path is specified as the root directory of any drive
4941             # (eg. C:\, D:\, etc.)
4942             # The path is specified as the current directory of any drive
4943             # by using the drive letter only (eg. C:, D:, etc.)
4944             # The path is specified as the parent directory using the ..
4945             # notation (eg. DIR .. /Z)
4946             # Any other syntax results in a "File Not Found" error message.
4947             #
4948             # 2. The /Z switch is compatable with the /S switch to show
4949             # subdirectories (as long as the above rules are followed) and
4950             # all the files are shown with short names only. The
4951             # subdirectories are also shown with short names only. However,
4952             # the header for each subdirectory after the first level gives
4953             # the subdirectory's long name.
4954             #
4955             # 3. The /Z switch is also compatable with the /B switch to give
4956             # a simple list of files with short names only. When used with
4957             # the /S switch as well, all files are listed with their full
4958             # paths. The file names themselves are all in short form, and
4959             # the path of those files in the current directory are in short
4960             # form, but the paths of any files in subdirectories are in
4961 0         0 # long filename form.
4962 0         0  
4963 0         0 my $shortdir = '';
4964 0         0 my $i = 0;
4965 0         0 my @subdir = ();
4966 0 0 0     0 while ($dir =~ / \G ($q_char) /oxgc) {
4967 0         0 my $char = $1;
4968 0         0 if (($char eq '\\') or ($char eq '/')) {
4969 0         0 $i++;
4970             $subdir[$i] = $char;
4971             $i++;
4972 0         0 }
4973             else {
4974             $subdir[$i] .= $char;
4975 0 0 0     0 }
4976 0         0 }
4977             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
4978             pop @subdir;
4979             }
4980              
4981             # P.504 PERL5SHELL (Microsoft ports only)
4982             # in Chapter 19: The Command-Line Interface
4983             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
4984              
4985             # P.597 PERL5SHELL (Microsoft ports only)
4986             # in Chapter 17: The Command-Line Interface
4987             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
4988              
4989 0 0 0     0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
    0          
4990 0         0 # cmd.exe on Windows NT, Windows 2000
4991 0         0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
  0         0  
4992 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
4993             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
4994             if (Euhc::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Euhc::fc($subdir[-1])) {
4995 0         0  
4996 0         0 # short file name (8dot3name) here-----vv
4997 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
4998 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
4999             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5000             last;
5001             }
5002             }
5003             }
5004              
5005             # an idea (not so portable, only Windows 2000 or later)
5006             elsif (0) {
5007             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5008             }
5009              
5010 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5011 0         0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
  0         0  
5012 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5013             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5014             if (Euhc::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Euhc::fc($subdir[-1])) {
5015 0         0  
5016 0         0 # short file name (8dot3name) here-----vv
5017 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5018 0         0 $shortleafdir =~ s/ [ ]+ \z//oxms;
5019             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5020             last;
5021             }
5022             }
5023             }
5024              
5025 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5026 0         0 else {
  0         0  
5027 0 0       0 chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5028             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5029             if (Euhc::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Euhc::fc($subdir[-1])) {
5030 0         0  
5031 0         0 # short file name (8dot3name) here-----v
5032 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5033 0         0 CORE::substr($shortleafdir,8,1) = '.';
5034 0         0 $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5035             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5036             last;
5037             }
5038             }
5039 0 0       0 }
    0          
5040 0         0  
5041             if ($shortdir eq '') {
5042             return 0;
5043 0         0 }
5044             elsif (Euhc::fc($shortdir) eq Euhc::fc($dir)) {
5045 0         0 return 0;
5046             }
5047             return CORE::chdir $shortdir;
5048 0         0 }
5049             else {
5050             return CORE::chdir $dir;
5051             }
5052             }
5053              
5054             #
5055             # UHC chr(0x5C) ended path on MSWin32
5056             #
5057 0 50 33 768   0 sub _MSWin32_5Cended_path {
5058 768 50       5049  
5059 768         4698 if ((@_ >= 1) and ($_[0] ne '')) {
5060 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5061 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5062             if ($char[-1] =~ / \x5C \z/oxms) {
5063             return 1;
5064             }
5065 0         0 }
5066             }
5067             return undef;
5068             }
5069              
5070             #
5071             # do UHC file
5072             #
5073 768     0 0 2118 sub Euhc::do($) {
5074              
5075 0         0 my($filename) = @_;
5076              
5077             my $realfilename;
5078             my $result;
5079 0         0 ITER_DO:
  0         0  
5080 0 0       0 {
5081 0         0 for my $prefix (@INC) {
5082             if ($^O eq 'MacOS') {
5083             $realfilename = "$prefix$filename";
5084 0         0 }
5085             else {
5086             $realfilename = "$prefix/$filename";
5087 0 0       0 }
5088              
5089 0         0 if (Euhc::f($realfilename)) {
5090              
5091 0 0       0 my $script = '';
5092 0         0  
5093 0         0 if (Euhc::e("$realfilename.e")) {
5094 0         0 my $e_mtime = (Euhc::stat("$realfilename.e"))[9];
5095 0 0 0     0 my $mtime = (Euhc::stat($realfilename))[9];
5096 0         0 my $module_mtime = (Euhc::stat(__FILE__))[9];
5097             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5098             Euhc::unlink "$realfilename.e";
5099             }
5100 0 0       0 }
5101 0         0  
5102 0 0       0 if (Euhc::e("$realfilename.e")) {
5103 0 0       0 my $fh = gensym();
    0          
5104 0         0 if (_open_r($fh, "$realfilename.e")) {
5105             if ($^O eq 'MacOS') {
5106             CORE::eval q{
5107             CORE::require Mac::Files;
5108             Mac::Files::FSpSetFLock("$realfilename.e");
5109             };
5110             }
5111             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5112              
5113             # P.419 File Locking
5114             # in Chapter 16: Interprocess Communication
5115             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5116              
5117             # P.524 File Locking
5118             # in Chapter 15: Interprocess Communication
5119             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5120              
5121 0         0 # (and so on)
5122 0 0       0  
5123 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5124             if ($@) {
5125             carp "Can't immediately read-lock the file: $realfilename.e";
5126             }
5127 0         0 }
5128             else {
5129 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5130 0         0 }
5131 0 0       0 local $/ = undef; # slurp mode
5132 0         0 $script = <$fh>;
5133             if ($^O eq 'MacOS') {
5134             CORE::eval q{
5135             CORE::require Mac::Files;
5136             Mac::Files::FSpRstFLock("$realfilename.e");
5137 0         0 };
5138             }
5139             close $fh;
5140             }
5141 0         0 }
5142 0 0       0 else {
5143 0 0       0 my $fh = gensym();
    0          
5144 0         0 if (_open_r($fh, $realfilename)) {
5145             if ($^O eq 'MacOS') {
5146             CORE::eval q{
5147             CORE::require Mac::Files;
5148             Mac::Files::FSpSetFLock($realfilename);
5149             };
5150 0         0 }
5151 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5152 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5153             if ($@) {
5154             carp "Can't immediately read-lock the file: $realfilename";
5155             }
5156 0         0 }
5157             else {
5158 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5159 0         0 }
5160 0 0       0 local $/ = undef; # slurp mode
5161 0         0 $script = <$fh>;
5162             if ($^O eq 'MacOS') {
5163             CORE::eval q{
5164             CORE::require Mac::Files;
5165             Mac::Files::FSpRstFLock($realfilename);
5166 0         0 };
5167             }
5168             close $fh;
5169 0 0       0 }
5170 0         0  
5171 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5172 0         0 CORE::require UHC;
5173 0 0       0 $script = UHC::escape_script($script);
5174 0 0       0 my $fh = gensym();
    0          
5175 0         0 open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5176             if ($^O eq 'MacOS') {
5177             CORE::eval q{
5178             CORE::require Mac::Files;
5179             Mac::Files::FSpSetFLock("$realfilename.e");
5180             };
5181 0         0 }
5182 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5183 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5184             if ($@) {
5185             carp "Can't immediately write-lock the file: $realfilename.e";
5186             }
5187 0         0 }
5188             else {
5189 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5190 0 0       0 }
5191 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5192 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5193 0         0 print {$fh} $script;
5194             if ($^O eq 'MacOS') {
5195             CORE::eval q{
5196             CORE::require Mac::Files;
5197             Mac::Files::FSpRstFLock("$realfilename.e");
5198 0         0 };
5199             }
5200             close $fh;
5201             }
5202             }
5203 389     389   14671  
  389         1118  
  389         352463  
  0         0  
5204 0         0 {
5205             no strict;
5206 0         0 $result = scalar CORE::eval $script;
5207             }
5208             last ITER_DO;
5209             }
5210             }
5211 0 0       0 }
    0          
5212 0         0  
5213 0         0 if ($@) {
5214             $INC{$filename} = undef;
5215             return undef;
5216 0         0 }
5217             elsif (not $result) {
5218             return undef;
5219 0         0 }
5220 0         0 else {
5221             $INC{$filename} = $realfilename;
5222             return $result;
5223             }
5224             }
5225              
5226             #
5227             # require UHC file
5228             #
5229              
5230             # require
5231             # in Chapter 3: Functions
5232             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5233             #
5234             # sub require {
5235             # my($filename) = @_;
5236             # return 1 if $INC{$filename};
5237             # my($realfilename, $result);
5238             # ITER: {
5239             # foreach $prefix (@INC) {
5240             # $realfilename = "$prefix/$filename";
5241             # if (-f $realfilename) {
5242             # $result = CORE::eval `cat $realfilename`;
5243             # last ITER;
5244             # }
5245             # }
5246             # die "Can't find $filename in \@INC";
5247             # }
5248             # die $@ if $@;
5249             # die "$filename did not return true value" unless $result;
5250             # $INC{$filename} = $realfilename;
5251             # return $result;
5252             # }
5253              
5254             # require
5255             # in Chapter 9: perlfunc: Perl builtin functions
5256             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5257             #
5258             # sub require {
5259             # my($filename) = @_;
5260             # if (exists $INC{$filename}) {
5261             # return 1 if $INC{$filename};
5262             # die "Compilation failed in require";
5263             # }
5264             # my($realfilename, $result);
5265             # ITER: {
5266             # foreach $prefix (@INC) {
5267             # $realfilename = "$prefix/$filename";
5268             # if (-f $realfilename) {
5269             # $INC{$filename} = $realfilename;
5270             # $result = do $realfilename;
5271             # last ITER;
5272             # }
5273             # }
5274             # die "Can't find $filename in \@INC";
5275             # }
5276             # if ($@) {
5277             # $INC{$filename} = undef;
5278             # die $@;
5279             # }
5280             # elsif (!$result) {
5281             # delete $INC{$filename};
5282             # die "$filename did not return true value";
5283             # }
5284             # else {
5285             # return $result;
5286             # }
5287             # }
5288              
5289 0 0   0 0 0 sub Euhc::require(;$) {
5290              
5291 0 0       0 local $_ = shift if @_;
5292 0 0       0  
5293 0         0 if (exists $INC{$_}) {
5294             return 1 if $INC{$_};
5295             croak "Compilation failed in require: $_";
5296             }
5297              
5298             # jcode.pl
5299             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5300              
5301             # jacode.pl
5302 0 0       0 # http://search.cpan.org/dist/jacode/
5303 0         0  
5304             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5305             return CORE::require($_);
5306 0         0 }
5307              
5308             my $realfilename;
5309             my $result;
5310 0         0 ITER_REQUIRE:
  0         0  
5311 0 0       0 {
5312 0         0 for my $prefix (@INC) {
5313             if ($^O eq 'MacOS') {
5314             $realfilename = "$prefix$_";
5315 0         0 }
5316             else {
5317             $realfilename = "$prefix/$_";
5318 0 0       0 }
5319 0         0  
5320             if (Euhc::f($realfilename)) {
5321 0         0 $INC{$_} = $realfilename;
5322              
5323 0 0       0 my $script = '';
5324 0         0  
5325 0         0 if (Euhc::e("$realfilename.e")) {
5326 0         0 my $e_mtime = (Euhc::stat("$realfilename.e"))[9];
5327 0 0 0     0 my $mtime = (Euhc::stat($realfilename))[9];
5328 0         0 my $module_mtime = (Euhc::stat(__FILE__))[9];
5329             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5330             Euhc::unlink "$realfilename.e";
5331             }
5332 0 0       0 }
5333 0         0  
5334 0 0       0 if (Euhc::e("$realfilename.e")) {
5335 0 0       0 my $fh = gensym();
    0          
5336 0         0 _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5337             if ($^O eq 'MacOS') {
5338             CORE::eval q{
5339             CORE::require Mac::Files;
5340             Mac::Files::FSpSetFLock("$realfilename.e");
5341             };
5342 0         0 }
5343 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5344 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5345             if ($@) {
5346             carp "Can't immediately read-lock the file: $realfilename.e";
5347             }
5348 0         0 }
5349             else {
5350 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5351 0         0 }
5352 0 0       0 local $/ = undef; # slurp mode
5353 0         0 $script = <$fh>;
5354             if ($^O eq 'MacOS') {
5355             CORE::eval q{
5356             CORE::require Mac::Files;
5357             Mac::Files::FSpRstFLock("$realfilename.e");
5358 0 0       0 };
5359             }
5360             close($fh) or croak "Can't close file: $realfilename";
5361 0         0 }
5362 0 0       0 else {
5363 0 0       0 my $fh = gensym();
    0          
5364 0         0 _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5365             if ($^O eq 'MacOS') {
5366             CORE::eval q{
5367             CORE::require Mac::Files;
5368             Mac::Files::FSpSetFLock($realfilename);
5369             };
5370 0         0 }
5371 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5372 0         0 CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5373             if ($@) {
5374             carp "Can't immediately read-lock the file: $realfilename";
5375             }
5376 0         0 }
5377             else {
5378 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5379 0         0 }
5380 0 0       0 local $/ = undef; # slurp mode
5381 0         0 $script = <$fh>;
5382             if ($^O eq 'MacOS') {
5383             CORE::eval q{
5384             CORE::require Mac::Files;
5385             Mac::Files::FSpRstFLock($realfilename);
5386 0 0       0 };
5387             }
5388 0 0       0 close($fh) or croak "Can't close file: $realfilename";
5389 0         0  
5390 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
5391 0         0 CORE::require UHC;
5392 0 0       0 $script = UHC::escape_script($script);
5393 0 0       0 my $fh = gensym();
    0          
5394 0         0 open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5395             if ($^O eq 'MacOS') {
5396             CORE::eval q{
5397             CORE::require Mac::Files;
5398             Mac::Files::FSpSetFLock("$realfilename.e");
5399             };
5400 0         0 }
5401 0 0       0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5402 0         0 CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5403             if ($@) {
5404             carp "Can't immediately write-lock the file: $realfilename.e";
5405             }
5406 0         0 }
5407             else {
5408 0         0 CORE::eval q{ flock($fh, LOCK_EX) };
5409 0 0       0 }
5410 0         0 CORE::eval q{ truncate($fh, 0) };
  0         0  
5411 0 0       0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5412 0         0 print {$fh} $script;
5413             if ($^O eq 'MacOS') {
5414             CORE::eval q{
5415             CORE::require Mac::Files;
5416             Mac::Files::FSpRstFLock("$realfilename.e");
5417 0 0       0 };
5418             }
5419             close($fh) or croak "Can't close file: $realfilename";
5420             }
5421             }
5422 389     389   5839  
  389         2377  
  389         373755  
  0         0  
5423 0         0 {
5424             no strict;
5425 0         0 $result = scalar CORE::eval $script;
5426             }
5427             last ITER_REQUIRE;
5428 0         0 }
5429             }
5430             croak "Can't find $_ in \@INC";
5431 0 0       0 }
    0          
5432 0         0  
5433 0         0 if ($@) {
5434             $INC{$_} = undef;
5435             croak $@;
5436 0         0 }
5437 0         0 elsif (not $result) {
5438             delete $INC{$_};
5439             croak "$_ did not return true value";
5440 0         0 }
5441             else {
5442             return $result;
5443             }
5444             }
5445              
5446             #
5447             # UHC telldir avoid warning
5448             #
5449 0     768 0 0 sub Euhc::telldir(*) {
5450              
5451 768         2455 local $^W = 0;
5452              
5453             return CORE::telldir $_[0];
5454             }
5455              
5456             #
5457             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5458 768 0   0 0 33718 #
5459 0 0 0     0 sub Euhc::PREMATCH {
5460 0         0 if (defined($&)) {
5461             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5462             return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5463 0         0 }
5464             else {
5465             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5466             }
5467 0         0 }
5468             else {
5469 0         0 return '';
5470             }
5471             return $`;
5472             }
5473              
5474             #
5475             # ${^MATCH}, $MATCH, $& the string that matched
5476 0 0   0 0 0 #
5477 0 0       0 sub Euhc::MATCH {
5478 0         0 if (defined($&)) {
5479             if (defined($1)) {
5480             return $1;
5481 0         0 }
5482             else {
5483             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5484             }
5485 0         0 }
5486             else {
5487 0         0 return '';
5488             }
5489             return $&;
5490             }
5491              
5492             #
5493             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5494 0     0 0 0 #
5495             sub Euhc::POSTMATCH {
5496             return $';
5497             }
5498              
5499             #
5500             # UHC character to order (with parameter)
5501             #
5502 0 0   0 1 0 sub UHC::ord(;$) {
5503              
5504 0 0       0 local $_ = shift if @_;
5505 0         0  
5506 0         0 if (/\A ($q_char) /oxms) {
5507 0         0 my @ord = unpack 'C*', $1;
5508 0         0 my $ord = 0;
5509             while (my $o = shift @ord) {
5510 0         0 $ord = $ord * 0x100 + $o;
5511             }
5512             return $ord;
5513 0         0 }
5514             else {
5515             return CORE::ord $_;
5516             }
5517             }
5518              
5519             #
5520             # UHC character to order (without parameter)
5521             #
5522 0 0   0 0 0 sub UHC::ord_() {
5523 0         0  
5524 0         0 if (/\A ($q_char) /oxms) {
5525 0         0 my @ord = unpack 'C*', $1;
5526 0         0 my $ord = 0;
5527             while (my $o = shift @ord) {
5528 0         0 $ord = $ord * 0x100 + $o;
5529             }
5530             return $ord;
5531 0         0 }
5532             else {
5533             return CORE::ord $_;
5534             }
5535             }
5536              
5537             #
5538             # UHC reverse
5539             #
5540 0 0   0 0 0 sub UHC::reverse(@) {
5541 0         0  
5542             if (wantarray) {
5543             return CORE::reverse @_;
5544             }
5545             else {
5546              
5547             # One of us once cornered Larry in an elevator and asked him what
5548             # problem he was solving with this, but he looked as far off into
5549             # the distance as he could in an elevator and said, "It seemed like
5550 0         0 # a good idea at the time."
5551              
5552             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5553             }
5554             }
5555              
5556             #
5557             # UHC getc (with parameter, without parameter)
5558             #
5559 0     0 0 0 sub UHC::getc(;*@) {
5560 0 0       0  
5561 0 0 0     0 my($package) = caller;
5562             my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
5563 0         0 croak 'Too many arguments for UHC::getc' if @_ and not wantarray;
  0         0  
5564 0         0  
5565 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5566 0         0 my $getc = '';
5567 0 0       0 for my $length ($length[0] .. $length[-1]) {
5568 0 0       0 $getc .= CORE::getc($fh);
5569 0 0       0 if (exists $range_tr{CORE::length($getc)}) {
5570             if ($getc =~ /\A ${Euhc::dot_s} \z/oxms) {
5571             return wantarray ? ($getc,@_) : $getc;
5572             }
5573 0 0       0 }
5574             }
5575             return wantarray ? ($getc,@_) : $getc;
5576             }
5577              
5578             #
5579             # UHC length by character
5580             #
5581 0 0   0 1 0 sub UHC::length(;$) {
5582              
5583 0         0 local $_ = shift if @_;
5584 0         0  
5585             local @_ = /\G ($q_char) /oxmsg;
5586             return scalar @_;
5587             }
5588              
5589             #
5590             # UHC substr by character
5591             #
5592             BEGIN {
5593              
5594             # P.232 The lvalue Attribute
5595             # in Chapter 6: Subroutines
5596             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5597              
5598             # P.336 The lvalue Attribute
5599             # in Chapter 7: Subroutines
5600             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5601              
5602             # P.144 8.4 Lvalue subroutines
5603             # in Chapter 8: perlsub: Perl subroutines
5604 389 50 0 389 1 230027 # 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  
5605              
5606             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5607             # vv----------------------*******
5608             sub UHC::substr($$;$$) %s {
5609              
5610             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5611              
5612             # If the substring is beyond either end of the string, substr() returns the undefined
5613             # value and produces a warning. When used as an lvalue, specifying a substring that
5614             # is entirely outside the string raises an exception.
5615             # http://perldoc.perl.org/functions/substr.html
5616              
5617             # A return with no argument returns the scalar value undef in scalar context,
5618             # an empty list () in list context, and (naturally) nothing at all in void
5619             # context.
5620              
5621             my $offset = $_[1];
5622             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5623             return;
5624             }
5625              
5626             # substr($string,$offset,$length,$replacement)
5627             if (@_ == 4) {
5628             my(undef,undef,$length,$replacement) = @_;
5629             my $substr = join '', splice(@char, $offset, $length, $replacement);
5630             $_[0] = join '', @char;
5631              
5632             # return $substr; this doesn't work, don't say "return"
5633             $substr;
5634             }
5635              
5636             # substr($string,$offset,$length)
5637             elsif (@_ == 3) {
5638             my(undef,undef,$length) = @_;
5639             my $octet_offset = 0;
5640             my $octet_length = 0;
5641             if ($offset == 0) {
5642             $octet_offset = 0;
5643             }
5644             elsif ($offset > 0) {
5645             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5646             }
5647             else {
5648             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5649             }
5650             if ($length == 0) {
5651             $octet_length = 0;
5652             }
5653             elsif ($length > 0) {
5654             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
5655             }
5656             else {
5657             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
5658             }
5659             CORE::substr($_[0], $octet_offset, $octet_length);
5660             }
5661              
5662             # substr($string,$offset)
5663             else {
5664             my $octet_offset = 0;
5665             if ($offset == 0) {
5666             $octet_offset = 0;
5667             }
5668             elsif ($offset > 0) {
5669             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
5670             }
5671             else {
5672             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
5673             }
5674             CORE::substr($_[0], $octet_offset);
5675             }
5676             }
5677             END
5678             }
5679              
5680             #
5681             # UHC index by character
5682             #
5683 0     0 1 0 sub UHC::index($$;$) {
5684 0 0       0  
5685 0         0 my $index;
5686             if (@_ == 3) {
5687             $index = Euhc::index($_[0], $_[1], CORE::length(UHC::substr($_[0], 0, $_[2])));
5688 0         0 }
5689             else {
5690             $index = Euhc::index($_[0], $_[1]);
5691 0 0       0 }
5692 0         0  
5693             if ($index == -1) {
5694             return -1;
5695 0         0 }
5696             else {
5697             return UHC::length(CORE::substr $_[0], 0, $index);
5698             }
5699             }
5700              
5701             #
5702             # UHC rindex by character
5703             #
5704 0     0 1 0 sub UHC::rindex($$;$) {
5705 0 0       0  
5706 0         0 my $rindex;
5707             if (@_ == 3) {
5708             $rindex = Euhc::rindex($_[0], $_[1], CORE::length(UHC::substr($_[0], 0, $_[2])));
5709 0         0 }
5710             else {
5711             $rindex = Euhc::rindex($_[0], $_[1]);
5712 0 0       0 }
5713 0         0  
5714             if ($rindex == -1) {
5715             return -1;
5716 0         0 }
5717             else {
5718             return UHC::length(CORE::substr $_[0], 0, $rindex);
5719             }
5720             }
5721              
5722 389     389   6942 # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
  389         2365  
  389         44597  
5723             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
5724             use vars qw($slash); $slash = 'm//';
5725              
5726             # ord() to ord() or UHC::ord()
5727             my $function_ord = 'ord';
5728              
5729             # ord to ord or UHC::ord_
5730             my $function_ord_ = 'ord';
5731              
5732             # reverse to reverse or UHC::reverse
5733             my $function_reverse = 'reverse';
5734              
5735             # getc to getc or UHC::getc
5736             my $function_getc = 'getc';
5737              
5738             # P.1023 Appendix W.9 Multibyte Anchoring
5739             # of ISBN 1-56592-224-7 CJKV Information Processing
5740              
5741             my $anchor = '';
5742 389     389   4257 $anchor = q{${Euhc::anchor}};
  389     0   4064  
  389         22527577  
5743              
5744             use vars qw($nest);
5745              
5746             # regexp of nested parens in qqXX
5747              
5748             # P.340 Matching Nested Constructs with Embedded Code
5749             # in Chapter 7: Perl
5750             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5751              
5752             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
5753             [^\x81-\xFE\\()] |
5754             \( (?{$nest++}) |
5755             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5756             [\x81-\xFE][\x00-\xFF] |
5757             \\ [^\x81-\xFEc] |
5758             \\c[\x40-\x5F] |
5759             \\ [\x81-\xFE][\x00-\xFF] |
5760             [\x00-\xFF]
5761             }xms;
5762              
5763             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
5764             [^\x81-\xFE\\{}] |
5765             \{ (?{$nest++}) |
5766             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5767             [\x81-\xFE][\x00-\xFF] |
5768             \\ [^\x81-\xFEc] |
5769             \\c[\x40-\x5F] |
5770             \\ [\x81-\xFE][\x00-\xFF] |
5771             [\x00-\xFF]
5772             }xms;
5773              
5774             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
5775             [^\x81-\xFE\\\[\]] |
5776             \[ (?{$nest++}) |
5777             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5778             [\x81-\xFE][\x00-\xFF] |
5779             \\ [^\x81-\xFEc] |
5780             \\c[\x40-\x5F] |
5781             \\ [\x81-\xFE][\x00-\xFF] |
5782             [\x00-\xFF]
5783             }xms;
5784              
5785             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
5786             [^\x81-\xFE\\<>] |
5787             \< (?{$nest++}) |
5788             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5789             [\x81-\xFE][\x00-\xFF] |
5790             \\ [^\x81-\xFEc] |
5791             \\c[\x40-\x5F] |
5792             \\ [\x81-\xFE][\x00-\xFF] |
5793             [\x00-\xFF]
5794             }xms;
5795              
5796             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
5797             (?: ::)? (?:
5798             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5799             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5800             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5801             ))
5802             }xms;
5803              
5804             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
5805             (?: ::)? (?:
5806             (?>[0-9]+) |
5807             [^\x81-\xFEa-zA-Z_0-9\[\]] |
5808             ^[A-Z] |
5809             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
5810             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
5811             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
5812             ))
5813             }xms;
5814              
5815             my $qq_substr = qr{(?> Char::substr | UHC::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
5816             }xms;
5817              
5818             # regexp of nested parens in qXX
5819             my $q_paren = qr{(?{local $nest=0}) (?>(?:
5820             [^\x81-\xFE()] |
5821             [\x81-\xFE][\x00-\xFF] |
5822             \( (?{$nest++}) |
5823             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5824             [\x00-\xFF]
5825             }xms;
5826              
5827             my $q_brace = qr{(?{local $nest=0}) (?>(?:
5828             [^\x81-\xFE\{\}] |
5829             [\x81-\xFE][\x00-\xFF] |
5830             \{ (?{$nest++}) |
5831             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5832             [\x00-\xFF]
5833             }xms;
5834              
5835             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
5836             [^\x81-\xFE\[\]] |
5837             [\x81-\xFE][\x00-\xFF] |
5838             \[ (?{$nest++}) |
5839             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5840             [\x00-\xFF]
5841             }xms;
5842              
5843             my $q_angle = qr{(?{local $nest=0}) (?>(?:
5844             [^\x81-\xFE<>] |
5845             [\x81-\xFE][\x00-\xFF] |
5846             \< (?{$nest++}) |
5847             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
5848             [\x00-\xFF]
5849             }xms;
5850              
5851             my $matched = '';
5852             my $s_matched = '';
5853             $matched = q{$Euhc::matched};
5854             $s_matched = q{ Euhc::s_matched();};
5855              
5856             my $tr_variable = ''; # variable of tr///
5857             my $sub_variable = ''; # variable of s///
5858             my $bind_operator = ''; # =~ or !~
5859              
5860             my @heredoc = (); # here document
5861             my @heredoc_delimiter = ();
5862             my $here_script = ''; # here script
5863              
5864             #
5865             # escape UHC script
5866 0 50   384 0 0 #
5867             sub UHC::escape(;$) {
5868             local($_) = $_[0] if @_;
5869              
5870             # P.359 The Study Function
5871             # in Chapter 7: Perl
5872 384         1275 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5873              
5874             study $_; # Yes, I studied study yesterday.
5875              
5876             # while all script
5877              
5878             # 6.14. Matching from Where the Last Pattern Left Off
5879             # in Chapter 6. Pattern Matching
5880             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
5881             # (and so on)
5882              
5883             # one member of Tag-team
5884             #
5885             # P.128 Start of match (or end of previous match): \G
5886             # P.130 Advanced Use of \G with Perl
5887             # in Chapter 3: Overview of Regular Expression Features and Flavors
5888             # P.255 Use leading anchors
5889             # P.256 Expose ^ and \G at the front expressions
5890             # in Chapter 6: Crafting an Efficient Expression
5891             # P.315 "Tag-team" matching with /gc
5892             # in Chapter 7: Perl
5893 384         800 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
5894 384         717  
5895 384         1617 my $e_script = '';
5896             while (not /\G \z/oxgc) { # member
5897             $e_script .= UHC::escape_token();
5898 186412         304835 }
5899              
5900             return $e_script;
5901             }
5902              
5903             #
5904             # escape UHC token of script
5905             #
5906             sub UHC::escape_token {
5907              
5908 384     186412 0 6420 # \n output here document
5909              
5910             my $ignore_modules = join('|', qw(
5911             utf8
5912             bytes
5913             charnames
5914             I18N::Japanese
5915             I18N::Collate
5916             I18N::JExt
5917             File::DosGlob
5918             Wild
5919             Wildcard
5920             Japanese
5921             ));
5922              
5923             # another member of Tag-team
5924             #
5925             # P.315 "Tag-team" matching with /gc
5926             # in Chapter 7: Perl
5927 186412 100 100     228863 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
    100 100        
    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          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    50          
    50          
    100          
    50          
    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          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    50          
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    100          
    100          
    50          
5928 186412         14768114  
5929 31404 100       42059 if (/\G ( \n ) /oxgc) { # another member (and so on)
5930 31404         56967 my $heredoc = '';
5931             if (scalar(@heredoc_delimiter) >= 1) {
5932 197         286 $slash = 'm//';
5933 197         441  
5934             $heredoc = join '', @heredoc;
5935             @heredoc = ();
5936 197         368  
5937 197         392 # skip here document
5938             for my $heredoc_delimiter (@heredoc_delimiter) {
5939 205         1392 /\G .*? \n $heredoc_delimiter \n/xmsgc;
5940             }
5941 197         448 @heredoc_delimiter = ();
5942              
5943 197         301 $here_script = '';
5944             }
5945             return "\n" . $heredoc;
5946             }
5947 31404         95362  
5948             # ignore space, comment
5949             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
5950              
5951             # if (, elsif (, unless (, while (, until (, given (, and when (
5952              
5953             # given, when
5954              
5955             # P.225 The given Statement
5956             # in Chapter 15: Smart Matching and given-when
5957             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5958              
5959             # P.133 The given Statement
5960             # in Chapter 4: Statements and Declarations
5961             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5962 42620         137049  
5963 3773         5926 elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
5964             $slash = 'm//';
5965             return $1;
5966             }
5967              
5968             # scalar variable ($scalar = ...) =~ tr///;
5969             # scalar variable ($scalar = ...) =~ s///;
5970              
5971             # state
5972              
5973             # P.68 Persistent, Private Variables
5974             # in Chapter 4: Subroutines
5975             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
5976              
5977             # P.160 Persistent Lexically Scoped Variables: state
5978             # in Chapter 4: Statements and Declarations
5979             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5980              
5981             # (and so on)
5982 3773         12711  
5983             elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
5984 170 50       448 my $e_string = e_string($1);
    50          
5985 170         6863  
5986 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
5987 0         0 $tr_variable = $e_string . e_string($1);
5988 0         0 $bind_operator = $2;
5989             $slash = 'm//';
5990             return '';
5991 0         0 }
5992 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
5993 0         0 $sub_variable = $e_string . e_string($1);
5994 0         0 $bind_operator = $2;
5995             $slash = 'm//';
5996             return '';
5997 0         0 }
5998 170         358 else {
5999             $slash = 'div';
6000             return $e_string;
6001             }
6002             }
6003              
6004 170         661 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Euhc::PREMATCH()
6005 4         12 elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6006             $slash = 'div';
6007             return q{Euhc::PREMATCH()};
6008             }
6009              
6010 4         16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Euhc::MATCH()
6011 28         71 elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6012             $slash = 'div';
6013             return q{Euhc::MATCH()};
6014             }
6015              
6016 28         112 # $', ${'} --> $', ${'}
6017 1         2 elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6018             $slash = 'div';
6019             return $1;
6020             }
6021              
6022 1         4 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Euhc::POSTMATCH()
6023 3         6 elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6024             $slash = 'div';
6025             return q{Euhc::POSTMATCH()};
6026             }
6027              
6028             # scalar variable $scalar =~ tr///;
6029             # scalar variable $scalar =~ s///;
6030             # substr() =~ tr///;
6031 3         12 # substr() =~ s///;
6032             elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
6033 2878 100       7384 my $scalar = e_string($1);
    100          
6034 2878         12040  
6035 9         19 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6036 9         18 $tr_variable = $scalar;
6037 9         16 $bind_operator = $1;
6038             $slash = 'm//';
6039             return '';
6040 9         29 }
6041 253         445 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6042 253         497 $sub_variable = $scalar;
6043 253         356 $bind_operator = $1;
6044             $slash = 'm//';
6045             return '';
6046 253         731 }
6047 2616         3967 else {
6048             $slash = 'div';
6049             return $scalar;
6050             }
6051             }
6052              
6053 2616         7601 # end of statement
6054             elsif (/\G ( [,;] ) /oxgc) {
6055             $slash = 'm//';
6056 12209         20058  
6057             # clear tr/// variable
6058             $tr_variable = '';
6059 12209         15029  
6060             # clear s/// variable
6061 12209         15016 $sub_variable = '';
6062              
6063 12209         13986 $bind_operator = '';
6064              
6065             return $1;
6066             }
6067              
6068 12209         43051 # bareword
6069             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6070             return $1;
6071             }
6072              
6073 0         0 # $0 --> $0
6074 2         5 elsif (/\G ( \$ 0 ) /oxmsgc) {
6075             $slash = 'div';
6076             return $1;
6077 2         7 }
6078 0         0 elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6079             $slash = 'div';
6080             return $1;
6081             }
6082              
6083 0         0 # $$ --> $$
6084 1         2 elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6085             $slash = 'div';
6086             return $1;
6087             }
6088              
6089             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6090 1         7 # $1, $2, $3 --> $1, $2, $3 otherwise
6091 219         408 elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6092             $slash = 'div';
6093             return e_capture($1);
6094 219         578 }
6095 0         0 elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6096             $slash = 'div';
6097             return e_capture($1);
6098             }
6099              
6100 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6101 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6102             $slash = 'div';
6103             return e_capture($1.'->'.$2);
6104             }
6105              
6106 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6107 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6108             $slash = 'div';
6109             return e_capture($1.'->'.$2);
6110             }
6111              
6112 0         0 # $$foo
6113 0         0 elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6114             $slash = 'div';
6115             return e_capture($1);
6116             }
6117              
6118 0         0 # ${ foo }
6119 0         0 elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6120             $slash = 'div';
6121             return '${' . $1 . '}';
6122             }
6123              
6124 0         0 # ${ ... }
6125 0         0 elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6126             $slash = 'div';
6127             return e_capture($1);
6128             }
6129              
6130             # variable or function
6131 0         0 # $ @ % & * $ #
6132 605         1095 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) {
6133             $slash = 'div';
6134             return $1;
6135             }
6136             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6137 605         2281 # $ @ # \ ' " / ? ( ) [ ] < >
6138 103         222 elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6139             $slash = 'div';
6140             return $1;
6141             }
6142              
6143 103         387 # while ()
6144             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6145             return $1;
6146             }
6147              
6148             # while () --- glob
6149              
6150             # avoid "Error: Runtime exception" of perl version 5.005_03
6151 0         0  
6152             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6153             return 'while ($_ = Euhc::glob("' . $1 . '"))';
6154             }
6155              
6156 0         0 # while (glob)
6157             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6158             return 'while ($_ = Euhc::glob_)';
6159             }
6160              
6161 0         0 # while (glob(WILDCARD))
6162             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6163             return 'while ($_ = Euhc::glob';
6164             }
6165 0         0  
  482         1159  
6166             # doit if, doit unless, doit while, doit until, doit for, doit when
6167             elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
6168 482         1815  
  19         34  
6169 19         68 # subroutines of package Euhc
  0         0  
6170 0         0 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  13         25  
6171 13         42 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  0         0  
6172 0         0 elsif (/\G \b UHC::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         191  
6173 114         331 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
6174 2         7 elsif (/\G \b UHC::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval UHC::escape'; }
  2         5  
6175 2         7 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  2         5  
6176 2         7 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::chop'; }
  0         0  
6177 0         0 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
6178 2         6 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         5  
6179 2         6 elsif (/\G \b UHC::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'UHC::index'; }
  2         5  
6180 2         8 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::index'; }
  0         0  
6181 0         0 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         7  
6182 2         15 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  2         6  
6183 2         7 elsif (/\G \b UHC::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'UHC::rindex'; }
  1         3  
6184 1         3 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::rindex'; }
  0         0  
6185 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::lc'; }
  0         0  
6186 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::lcfirst'; }
  0         0  
6187 0         0 elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::uc'; }
  3         5  
6188             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::ucfirst'; }
6189             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::fc'; }
6190              
6191             # stacked file test operators
6192              
6193             # P.179 File Test Operators
6194             # in Chapter 12: File Tests
6195             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6196              
6197             # P.106 Named Unary and File Test Operators
6198             # in Chapter 3: Unary and Binary Operators
6199             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6200              
6201             # (and so on)
6202 3         11  
  0         0  
6203 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6204 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6205 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6206 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6207 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6208 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         4  
6209             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6210             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6211 1         8  
  5         15  
6212 5         25 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6213 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6214 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6215 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6216 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6217 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         5  
6218             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6219             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6220 1         10  
  0         0  
6221 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6222 0         0 { $slash = 'm//'; return "Euhc::filetest(qw($1),$2)"; }
  0         0  
6223 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1),$2)"; }
  0         0  
6224             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Euhc::filetest qw($1),"; }
6225 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Euhc::filetest(qw($1),$2)"; }
  0         0  
6226 0         0  
  0         0  
6227 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6228 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6229 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6230 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6231 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         7  
6232             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6233 2         12 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         199  
6234 103         366  
  0         0  
6235 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6236 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6237 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6238 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6239 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         8  
6240             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6241             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6242 2         50  
  6         12  
6243 6         30 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6244 0         0 { $slash = 'm//'; return "Euhc::$1($2)"; }
  0         0  
6245 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Euhc::$1($2)"; }
  50         93  
6246 50         250 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Euhc::$1"; }
  2         8  
6247 2         9 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Euhc::$1(::"."$2)"; }
  1         4  
6248 1         5 elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
  3         10  
6249             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::lstat'; }
6250             elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::stat'; }
6251 3         13  
  0         0  
6252 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6253 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6254 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6255 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6256 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6257 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6258             elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6259 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  
6260 0         0  
  0         0  
6261 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6262 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6263 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6264 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6265 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6266             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6267             elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6268 0         0  
  0         0  
6269 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6270 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6271 0         0 elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
  0         0  
6272             elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
6273 0         0 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         8  
6274 2         9  
  2         8  
6275 2         10 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  36         87  
6276 36         176 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         6  
6277 2         7 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::chr'; }
  2         4  
6278 2         9 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  8         23  
6279 8         32 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6280 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Euhc::glob'; }
  0         0  
6281 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::lc_'; }
  0         0  
6282 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::lcfirst_'; }
  0         0  
6283 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::uc_'; }
  0         0  
6284 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::ucfirst_'; }
  0         0  
6285 0         0 elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::fc_'; }
  0         0  
6286             elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::lstat_'; }
6287 0         0 elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::stat_'; }
  0         0  
6288             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
6289 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Euhc::filetest_(qw($1))"; }
  0         0  
6290             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
6291 0         0 \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Euhc::${1}_"; }
  0         0  
6292              
6293 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6294 0         0  
  0         0  
6295 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6296 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  0         0  
6297 0         0 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::chr_'; }
  2         6  
6298 2         8 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6299 0         0 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  4         11  
6300 4         18 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::glob_'; }
  8         22  
6301 8         30 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  2         9  
6302 2         14 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  0         0  
6303 0         0 elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Euhc::opendir$1*"; }
  87         252  
6304             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Euhc::opendir$1*"; }
6305             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Euhc::unlink'; }
6306              
6307 87         359 # chdir
6308             elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6309 3         9 $slash = 'm//';
6310              
6311 3         5 my $e = 'Euhc::chdir';
6312 3         15  
6313             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6314             $e .= $1;
6315             }
6316 3 50       13  
  3 100       234  
    50          
    50          
    50          
    0          
6317             # end of chdir
6318             if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6319 0         0  
6320             # chdir scalar value
6321             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6322              
6323 1 0       6 # chdir qq//
  0         0  
6324             elsif (/\G \b (qq) \b /oxgc) {
6325 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
6326 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6327 0         0 while (not /\G \z/oxgc) {
6328 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6329 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6330 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6331 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6332 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6333             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6334 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6335             }
6336             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6337             }
6338             }
6339              
6340 0 0       0 # chdir q//
  0         0  
6341             elsif (/\G \b (q) \b /oxgc) {
6342 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
6343 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6344 0         0 while (not /\G \z/oxgc) {
6345 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6346 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6347 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6348 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6349 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6350             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6351 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6352             }
6353             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6354             }
6355             }
6356              
6357 0         0 # chdir ''
6358 2         6 elsif (/\G (\') /oxgc) {
6359 2 50       7 my $q_string = '';
  13 50       68  
    100          
    50          
6360 0         0 while (not /\G \z/oxgc) {
6361 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6362 2         6 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6363             elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6364 11         26 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6365             }
6366             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6367             }
6368              
6369 0         0 # chdir ""
6370 0         0 elsif (/\G (\") /oxgc) {
6371 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6372 0         0 while (not /\G \z/oxgc) {
6373 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6374 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6375             elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6376 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6377             }
6378             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6379             }
6380             }
6381              
6382 0         0 # split
6383             elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6384 404         1060 $slash = 'm//';
6385 404         724  
6386 404         1685 my $e = '';
6387             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6388             $e .= $1;
6389             }
6390 401 100       1818  
  404 100       20957  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6391             # end of split
6392             if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Euhc::split' . $e; }
6393 3         67  
6394             # split scalar value
6395             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Euhc::split' . $e . e_string($1); }
6396 1         7  
6397 0         0 # split literal space
6398 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Euhc::split' . $e . qq {qq$1 $2}; }
6399 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Euhc::split' . $e . qq{$1qq$2 $3}; }
6400 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Euhc::split' . $e . qq{$1qq$2 $3}; }
6401 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Euhc::split' . $e . qq{$1qq$2 $3}; }
6402 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Euhc::split' . $e . qq{$1qq$2 $3}; }
6403 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Euhc::split' . $e . qq{$1qq$2 $3}; }
6404 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Euhc::split' . $e . qq {q$1 $2}; }
6405 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Euhc::split' . $e . qq {$1q$2 $3}; }
6406 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Euhc::split' . $e . qq {$1q$2 $3}; }
6407 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Euhc::split' . $e . qq {$1q$2 $3}; }
6408 0         0 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Euhc::split' . $e . qq {$1q$2 $3}; }
6409 13         75 elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Euhc::split' . $e . qq {$1q$2 $3}; }
6410             elsif (/\G ' [ ] ' /oxgc) { return 'Euhc::split' . $e . qq {' '}; }
6411             elsif (/\G " [ ] " /oxgc) { return 'Euhc::split' . $e . qq {" "}; }
6412              
6413 2 0       11 # split qq//
  0         0  
6414             elsif (/\G \b (qq) \b /oxgc) {
6415 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
6416 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6417 0         0 while (not /\G \z/oxgc) {
6418 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6419 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6420 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6421 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6422 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6423             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6424 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6425             }
6426             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6427             }
6428             }
6429              
6430 0 50       0 # split qr//
  124         1067  
6431             elsif (/\G \b (qr) \b /oxgc) {
6432 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
6433 124 50       403 else {
  124 50       6977  
    50          
    50          
    50          
    100          
    50          
    50          
6434 0         0 while (not /\G \z/oxgc) {
6435 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6436 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6437 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6438 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6439 56         249 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6440 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6441             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6442 68         419 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6443             }
6444             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6445             }
6446             }
6447              
6448 0 0       0 # split q//
  0         0  
6449             elsif (/\G \b (q) \b /oxgc) {
6450 0         0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
6451 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6452 0         0 while (not /\G \z/oxgc) {
6453 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6454 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6455 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6456 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6457 0         0 elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6458             elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6459 0         0 elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6460             }
6461             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6462             }
6463             }
6464              
6465 0 50       0 # split m//
  136         1140  
6466             elsif (/\G \b (m) \b /oxgc) {
6467 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
6468 136 50       453 else {
  136 50       7396  
    50          
    50          
    50          
    100          
    50          
    50          
6469 0         0 while (not /\G \z/oxgc) {
6470 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6471 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6472 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6473 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6474 56         336 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6475 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6476             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6477 80         399 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6478             }
6479             die __FILE__, ": Search pattern not terminated\n";
6480             }
6481             }
6482              
6483 0         0 # split ''
6484 0         0 elsif (/\G (\') /oxgc) {
6485 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6486 0         0 while (not /\G \z/oxgc) {
6487 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6488 0         0 elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6489             elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6490 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6491             }
6492             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6493             }
6494              
6495 0         0 # split ""
6496 0         0 elsif (/\G (\") /oxgc) {
6497 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
6498 0         0 while (not /\G \z/oxgc) {
6499 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6500 0         0 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6501             elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6502 0         0 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6503             }
6504             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6505             }
6506              
6507 0         0 # split //
6508 125         318 elsif (/\G (\/) /oxgc) {
6509 125 50       446 my $regexp = '';
  558 50       2751  
    100          
    50          
6510 0         0 while (not /\G \z/oxgc) {
6511 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6512 125         520 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6513             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6514 433         1040 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6515             }
6516             die __FILE__, ": Search pattern not terminated\n";
6517             }
6518             }
6519              
6520             # tr/// or y///
6521              
6522             # about [cdsrbB]* (/B modifier)
6523             #
6524             # P.559 appendix C
6525             # of ISBN 4-89052-384-7 Programming perl
6526             # (Japanese title is: Perl puroguramingu)
6527 0         0  
6528             elsif (/\G \b ( tr | y ) \b /oxgc) {
6529             my $ope = $1;
6530 11 50       38  
6531 11         250 # $1 $2 $3 $4 $5 $6
6532 0         0 if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6533             my @tr = ($tr_variable,$2);
6534             return e_tr(@tr,'',$4,$6);
6535 0         0 }
6536 11         25 else {
6537 11 50       37 my $e = '';
  11 50       1768  
    50          
    50          
    50          
    50          
6538             while (not /\G \z/oxgc) {
6539 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6540 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6541 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6542 0         0 while (not /\G \z/oxgc) {
6543 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6544 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6545 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6546 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6547             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6548 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6549             }
6550             die __FILE__, ": Transliteration replacement not terminated\n";
6551 0         0 }
6552 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6553 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6554 0         0 while (not /\G \z/oxgc) {
6555 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6556 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6557 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6558 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6559             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6560 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6561             }
6562             die __FILE__, ": Transliteration replacement not terminated\n";
6563 0         0 }
6564 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6565 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6566 0         0 while (not /\G \z/oxgc) {
6567 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6568 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6569 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6570 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6571             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6572 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6573             }
6574             die __FILE__, ": Transliteration replacement not terminated\n";
6575 0         0 }
6576 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6577 0 0       0 my @tr = ($tr_variable,$2);
  0 0       0  
    0          
    0          
    0          
    0          
6578 0         0 while (not /\G \z/oxgc) {
6579 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6580 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6581 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6582 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6583             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6584 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6585             }
6586             die __FILE__, ": Transliteration replacement not terminated\n";
6587             }
6588 0         0 # $1 $2 $3 $4 $5 $6
6589 11         51 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6590             my @tr = ($tr_variable,$2);
6591             return e_tr(@tr,'',$4,$6);
6592 11         75 }
6593             }
6594             die __FILE__, ": Transliteration pattern not terminated\n";
6595             }
6596             }
6597              
6598 0         0 # qq//
6599             elsif (/\G \b (qq) \b /oxgc) {
6600             my $ope = $1;
6601 5897 100       16784  
6602 5897         12181 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6603 40         61 if (/\G (\#) /oxgc) { # qq# #
6604 40 100       138 my $qq_string = '';
  1948 50       5406  
    100          
    50          
6605 80         138 while (not /\G \z/oxgc) {
6606 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6607 40         88 elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6608             elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6609 1828         4446 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6610             }
6611             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6612             }
6613 0         0  
6614 5857         9690 else {
6615 5857 50       14990 my $e = '';
  5857 50       26159  
    100          
    50          
    100          
    50          
6616             while (not /\G \z/oxgc) {
6617             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6618              
6619 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6620 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6621 0         0 my $qq_string = '';
6622 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6623 0         0 while (not /\G \z/oxgc) {
6624 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6625             elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
6626 0 0       0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6627 0         0 elsif (/\G (\)) /oxgc) {
6628             if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6629 0         0 else { $qq_string .= $1; }
6630             }
6631 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6632             }
6633             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6634             }
6635              
6636 0         0 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6637 5775         9041 elsif (/\G (\{) /oxgc) { # qq { }
6638 5775         8861 my $qq_string = '';
6639 5775 100       12834 local $nest = 1;
  245875 50       805568  
    100          
    100          
    50          
6640 720         1420 while (not /\G \z/oxgc) {
6641 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  1384         2028  
6642             elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
6643 1384 100       2536 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
  7159         11878  
6644 5775         14080 elsif (/\G (\}) /oxgc) {
6645             if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
6646 1384         3024 else { $qq_string .= $1; }
6647             }
6648 236612         480789 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6649             }
6650             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6651             }
6652              
6653 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
6654 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
6655 0         0 my $qq_string = '';
6656 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
6657 0         0 while (not /\G \z/oxgc) {
6658 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
6659             elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
6660 0 0       0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
  0         0  
6661 0         0 elsif (/\G (\]) /oxgc) {
6662             if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
6663 0         0 else { $qq_string .= $1; }
6664             }
6665 0         0 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6666             }
6667             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6668             }
6669              
6670 0         0 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
6671 62         102 elsif (/\G (\<) /oxgc) { # qq < >
6672 62         116 my $qq_string = '';
6673 62 100       184 local $nest = 1;
  2040 50       7326  
    100          
    100          
    50          
6674 22         53 while (not /\G \z/oxgc) {
6675 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
  2         4  
6676             elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
6677 2 100       3 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
  64         141  
6678 62         174 elsif (/\G (\>) /oxgc) {
6679             if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
6680 2         3 else { $qq_string .= $1; }
6681             }
6682 1952         3674 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6683             }
6684             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6685             }
6686              
6687 0         0 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
6688 20         27 elsif (/\G (\S) /oxgc) { # qq * *
6689 20         23 my $delimiter = $1;
6690 20 50       38 my $qq_string = '';
  840 50       2567  
    100          
    50          
6691 0         0 while (not /\G \z/oxgc) {
6692 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6693 20         39 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
6694             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
6695 820         2618 elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6696             }
6697             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6698 0         0 }
6699             }
6700             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6701             }
6702             }
6703              
6704 0         0 # qr//
6705 184 50       519 elsif (/\G \b (qr) \b /oxgc) {
6706 184         799 my $ope = $1;
6707             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
6708             return e_qr($ope,$1,$3,$2,$4);
6709 0         0 }
6710 184         296 else {
6711 184 50       468 my $e = '';
  184 50       4892  
    100          
    50          
    50          
    100          
    50          
    50          
6712 0         0 while (not /\G \z/oxgc) {
6713 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6714 1         5 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
6715 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
6716 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
6717 76         277 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
6718 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
6719             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
6720 107         315 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
6721             }
6722             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6723             }
6724             }
6725              
6726 0         0 # qw//
6727 34 50       104 elsif (/\G \b (qw) \b /oxgc) {
6728 34         107 my $ope = $1;
6729             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
6730             return e_qw($ope,$1,$3,$2);
6731 0         0 }
6732 34         66 else {
6733 34 50       129 my $e = '';
  34 50       241  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6734             while (not /\G \z/oxgc) {
6735 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6736 34         135  
6737             elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6738 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
6739 0         0  
6740             elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6741 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
6742 0         0  
6743             elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6744 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
6745 0         0  
6746             elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6747 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
6748 0         0  
6749             elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6750 0         0 elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
6751             }
6752             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6753             }
6754             }
6755              
6756 0         0 # qx//
6757 3 50       11 elsif (/\G \b (qx) \b /oxgc) {
6758 3         68 my $ope = $1;
6759             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
6760             return e_qq($ope,$1,$3,$2);
6761 0         0 }
6762 3         6 else {
6763 3 50       13 my $e = '';
  3 50       348  
    100          
    50          
    50          
    50          
    50          
6764 0         0 while (not /\G \z/oxgc) {
6765 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6766 2         6 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
6767 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
6768 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
6769 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
6770             elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
6771 1         4 elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
6772             }
6773             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6774             }
6775             }
6776              
6777 0         0 # q//
6778             elsif (/\G \b (q) \b /oxgc) {
6779             my $ope = $1;
6780              
6781             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
6782              
6783             # avoid "Error: Runtime exception" of perl version 5.005_03
6784 606 50       2121 # (and so on)
6785 606         1934  
6786 0         0 if (/\G (\#) /oxgc) { # q# #
6787 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
6788 0         0 while (not /\G \z/oxgc) {
6789 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6790 0         0 elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
6791             elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
6792 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6793             }
6794             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6795             }
6796 0         0  
6797 606         1168 else {
6798 606 50       2278 my $e = '';
  606 100       3814  
    100          
    50          
    100          
    50          
6799             while (not /\G \z/oxgc) {
6800             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6801              
6802 0         0 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
6803 1         3 elsif (/\G (\() /oxgc) { # q ( )
6804 1         2 my $q_string = '';
6805 1 50       4 local $nest = 1;
  7 50       50  
    50          
    50          
    100          
    50          
6806 0         0 while (not /\G \z/oxgc) {
6807 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6808 0         0 elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
  0         0  
6809             elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
6810 0 50       0 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
  1         3  
6811 1         4 elsif (/\G (\)) /oxgc) {
6812             if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
6813 0         0 else { $q_string .= $1; }
6814             }
6815 6         67 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6816             }
6817             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6818             }
6819              
6820 0         0 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
6821 599         1181 elsif (/\G (\{) /oxgc) { # q { }
6822 599         1252 my $q_string = '';
6823 599 50       1989 local $nest = 1;
  8189 50       40403  
    50          
    100          
    100          
    50          
6824 0         0 while (not /\G \z/oxgc) {
6825 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6826 0         0 elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
  114         243  
6827             elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
6828 114 100       229 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
  713         1870  
6829 599         2179 elsif (/\G (\}) /oxgc) {
6830             if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
6831 114         255 else { $q_string .= $1; }
6832             }
6833 7362         16634 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6834             }
6835             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6836             }
6837              
6838 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
6839 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
6840 0         0 my $q_string = '';
6841 0 0       0 local $nest = 1;
  0 0       0  
    0          
    0          
    0          
    0          
6842 0         0 while (not /\G \z/oxgc) {
6843 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6844 0         0 elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
  0         0  
6845             elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
6846 0 0       0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
  0         0  
6847 0         0 elsif (/\G (\]) /oxgc) {
6848             if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
6849 0         0 else { $q_string .= $1; }
6850             }
6851 0         0 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6852             }
6853             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6854             }
6855              
6856 0         0 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
6857 5         12 elsif (/\G (\<) /oxgc) { # q < >
6858 5         11 my $q_string = '';
6859 5 50       16 local $nest = 1;
  82 50       392  
    50          
    50          
    100          
    50          
6860 0         0 while (not /\G \z/oxgc) {
6861 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6862 0         0 elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
  0         0  
6863             elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
6864 0 50       0 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
  5         12  
6865 5         14 elsif (/\G (\>) /oxgc) {
6866             if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
6867 0         0 else { $q_string .= $1; }
6868             }
6869 77         156 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6870             }
6871             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6872             }
6873              
6874 0         0 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
6875 1         2 elsif (/\G (\S) /oxgc) { # q * *
6876 1         3 my $delimiter = $1;
6877 1 50       4 my $q_string = '';
  14 50       77  
    100          
    50          
6878 0         0 while (not /\G \z/oxgc) {
6879 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6880 1         4 elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
6881             elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
6882 13         23 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6883             }
6884             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6885 0         0 }
6886             }
6887             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6888             }
6889             }
6890              
6891 0         0 # m//
6892 491 50       1580 elsif (/\G \b (m) \b /oxgc) {
6893 491         3233 my $ope = $1;
6894             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
6895             return e_qr($ope,$1,$3,$2,$4);
6896 0         0 }
6897 491         819 else {
6898 491 50       1458 my $e = '';
  491 50       22860  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6899 0         0 while (not /\G \z/oxgc) {
6900 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6901 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
6902 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
6903 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
6904 92         283 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
6905 87         500 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
6906 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
6907             elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
6908 312         1396 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
6909             }
6910             die __FILE__, ": Search pattern not terminated\n";
6911             }
6912             }
6913              
6914             # s///
6915              
6916             # about [cegimosxpradlunbB]* (/cg modifier)
6917             #
6918             # P.67 Pattern-Matching Operators
6919             # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
6920 0         0  
6921             elsif (/\G \b (s) \b /oxgc) {
6922             my $ope = $1;
6923 290 100       853  
6924 290         4446 # $1 $2 $3 $4 $5 $6
6925             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
6926             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
6927 1         4 }
6928 289         630 else {
6929 289 50       940 my $e = '';
  289 50       28921  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
6930             while (not /\G \z/oxgc) {
6931 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6932 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
6933 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6934             while (not /\G \z/oxgc) {
6935 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6936 0         0 # $1 $2 $3 $4
6937 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6938 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6939 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6940 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6941 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6942 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6943 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6944             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6945 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6946             }
6947             die __FILE__, ": Substitution replacement not terminated\n";
6948 0         0 }
6949 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
6950 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6951             while (not /\G \z/oxgc) {
6952 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6953 0         0 # $1 $2 $3 $4
6954 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6955 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6956 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6957 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6958 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6959 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6960 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6961             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6962 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6963             }
6964             die __FILE__, ": Substitution replacement not terminated\n";
6965 0         0 }
6966 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
6967 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
6968             while (not /\G \z/oxgc) {
6969 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6970 0         0 # $1 $2 $3 $4
6971 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6972 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6973 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6974 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6975 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6976             elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6977 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6978             }
6979             die __FILE__, ": Substitution replacement not terminated\n";
6980 0         0 }
6981 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
6982 0 0       0 my @s = ($1,$2,$3);
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
6983             while (not /\G \z/oxgc) {
6984 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6985 0         0 # $1 $2 $3 $4
6986 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6987 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6988 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6989 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6990 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6991 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6992 0         0 elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6993             elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6994 0         0 elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
6995             }
6996             die __FILE__, ": Substitution replacement not terminated\n";
6997             }
6998 0         0 # $1 $2 $3 $4 $5 $6
6999             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7000             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7001             }
7002 96         312 # $1 $2 $3 $4 $5 $6
7003             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7004             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7005             }
7006 2         34 # $1 $2 $3 $4 $5 $6
7007             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7008             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7009             }
7010 0         0 # $1 $2 $3 $4 $5 $6
7011             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7012             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7013 191         855 }
7014             }
7015             die __FILE__, ": Substitution pattern not terminated\n";
7016             }
7017             }
7018 0         0  
7019 1         6 # do
7020 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7021 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Euhc::do'; }
7022 0         0 elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7023             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7024             elsif (/\G \b do \b /oxmsgc) { return 'Euhc::do'; }
7025 2         9  
7026 0         0 # require ignore module
7027 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7028             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# require$1\n$2"; }
7029             elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7030 0         0  
7031 0         0 # require version number
7032 0         0 elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7033             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7034             elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7035 0         0  
7036             # require bare package name
7037             elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7038 18         123  
7039 0         0 # require else
7040             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Euhc::require;'; }
7041             elsif (/\G \b require \b /oxmsgc) { return 'Euhc::require'; }
7042 1         5  
7043 70         658 # use strict; --> use strict; no strict qw(refs);
7044 0         0 elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7045             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7046             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7047              
7048 0 50 33     0 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
      33        
7049 3         41 elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7050             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7051             return "use $1; no strict qw(refs);";
7052 0         0 }
7053             else {
7054             return "use $1;";
7055             }
7056 3 0 0     20 }
      0        
7057 0         0 elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7058             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7059             return "use $1; no strict qw(refs);";
7060 0         0 }
7061             else {
7062             return "use $1;";
7063             }
7064             }
7065 0         0  
7066 2         15 # ignore use module
7067 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7068             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# use$1\n$2"; }
7069             elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7070 0         0  
7071 0         0 # ignore no module
7072 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7073             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\xFE#]) /oxmsgc) { return "# no$1\n$2"; }
7074             elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7075 0         0  
7076 0         0 # use without import
7077 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7078 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7079 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7080 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7081 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7082 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7083 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7084 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7085             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7086             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7087 0         0  
7088             # use with import no parameter
7089             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7090 0         0  
7091 0         0 # use with import parameters
7092 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7093 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7094 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7095 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7096 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7097 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7098 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7099             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7100             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7101 0         0  
7102 0         0 # no without unimport
7103 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7104 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7105 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7106 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7107 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7108 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7109 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7110 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7111             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7112             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7113 0         0  
7114             # no with unimport no parameter
7115             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7116 0         0  
7117 0         0 # no with unimport parameters
7118 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7119 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\xFE']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7120 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\xFE"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7121 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\xFE)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7122 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\{) (?:$q_char)*? \}) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7123 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\[) (?:$q_char)*? \]) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7124 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\xFE>]* \>) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7125             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7126             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\S) (?:$q_char)*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7127 0         0  
7128             # use else
7129             elsif (/\G \b use \b /oxmsgc) { return "use"; }
7130 0         0  
7131             # use else
7132             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7133              
7134 2         11 # ''
7135 3177         7848 elsif (/\G (?
7136 3177 100       9044 my $q_string = '';
  15630 100       57151  
    100          
    50          
7137 8         21 while (not /\G \z/oxgc) {
7138 48         118 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7139 3177         8416 elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7140             elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7141 12397         28889 elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7142             }
7143             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7144             }
7145              
7146 0         0 # ""
7147 3404         8316 elsif (/\G (\") /oxgc) {
7148 3404 100       9077 my $qq_string = '';
  69438 100       201766  
    100          
    50          
7149 109         241 while (not /\G \z/oxgc) {
7150 14         28 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7151 3404         8919 elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7152             elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7153 65911         129788 elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7154             }
7155             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7156             }
7157              
7158 0         0 # ``
7159 37         102 elsif (/\G (\`) /oxgc) {
7160 37 50       140 my $qx_string = '';
  313 50       1733  
    100          
    50          
7161 0         0 while (not /\G \z/oxgc) {
7162 0         0 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7163 37         166 elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7164             elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7165 276         629 elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7166             }
7167             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7168             }
7169              
7170 0         0 # // --- not divide operator (num / num), not defined-or
7171 1231         3231 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
7172 1231 100       3446 my $regexp = '';
  12602 50       43278  
    100          
    50          
7173 11         33 while (not /\G \z/oxgc) {
7174 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7175 1231         3494 elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7176             elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7177 11360         23327 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7178             }
7179             die __FILE__, ": Search pattern not terminated\n";
7180             }
7181              
7182 0         0 # ?? --- not conditional operator (condition ? then : else)
7183 92         229 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
7184 92 50       304 my $regexp = '';
  266 50       1101  
    100          
    50          
7185 0         0 while (not /\G \z/oxgc) {
7186 0         0 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7187 92         256 elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7188             elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7189 174         459 elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7190             }
7191             die __FILE__, ": Search pattern not terminated\n";
7192             }
7193 0         0  
  0         0  
7194             # <<>> (a safer ARGV)
7195             elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
7196 0         0  
  0         0  
7197             # << (bit shift) --- not here document
7198             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7199              
7200 0         0 # <<~'HEREDOC'
7201 6         17 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7202 6         13 $slash = 'm//';
7203             my $here_quote = $1;
7204             my $delimiter = $2;
7205 6 50       11  
7206 6         15 # get here document
7207 6         41 if ($here_script eq '') {
7208             $here_script = CORE::substr $_, pos $_;
7209 6 50       40 $here_script =~ s/.*?\n//oxm;
7210 6         82 }
7211 6         25 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7212 6         11 my $heredoc = $1;
7213 6         59 my $indent = $2;
7214 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
7215             push @heredoc, $heredoc . qq{\n$delimiter\n};
7216             push @heredoc_delimiter, qq{\\s*$delimiter};
7217 6         17 }
7218             else {
7219 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7220             }
7221             return qq{<<'$delimiter'};
7222             }
7223              
7224             # <<~\HEREDOC
7225              
7226             # P.66 2.6.6. "Here" Documents
7227             # in Chapter 2: Bits and Pieces
7228             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7229              
7230             # P.73 "Here" Documents
7231             # in Chapter 2: Bits and Pieces
7232             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7233 6         30  
7234 3         9 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7235 3         9 $slash = 'm//';
7236             my $here_quote = $1;
7237             my $delimiter = $2;
7238 3 50       7  
7239 3         8 # get here document
7240 3         27 if ($here_script eq '') {
7241             $here_script = CORE::substr $_, pos $_;
7242 3 50       21 $here_script =~ s/.*?\n//oxm;
7243 3         44 }
7244 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7245 3         5 my $heredoc = $1;
7246 3         43 my $indent = $2;
7247 3         13 $heredoc =~ s{^$indent}{}msg; # no /ox
7248             push @heredoc, $heredoc . qq{\n$delimiter\n};
7249             push @heredoc_delimiter, qq{\\s*$delimiter};
7250 3         9 }
7251             else {
7252 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7253             }
7254             return qq{<<\\$delimiter};
7255             }
7256              
7257 3         15 # <<~"HEREDOC"
7258 6         17 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7259 6         15 $slash = 'm//';
7260             my $here_quote = $1;
7261             my $delimiter = $2;
7262 6 50       25  
7263 6         15 # get here document
7264 6         31 if ($here_script eq '') {
7265             $here_script = CORE::substr $_, pos $_;
7266 6 50       40 $here_script =~ s/.*?\n//oxm;
7267 6         75 }
7268 6         16 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7269 6         13 my $heredoc = $1;
7270 6         58 my $indent = $2;
7271 6         22 $heredoc =~ s{^$indent}{}msg; # no /ox
7272             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7273             push @heredoc_delimiter, qq{\\s*$delimiter};
7274 6         18 }
7275             else {
7276 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7277             }
7278             return qq{<<"$delimiter"};
7279             }
7280              
7281 6         26 # <<~HEREDOC
7282 3         9 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7283 3         9 $slash = 'm//';
7284             my $here_quote = $1;
7285             my $delimiter = $2;
7286 3 50       6  
7287 3         11 # get here document
7288 3         15 if ($here_script eq '') {
7289             $here_script = CORE::substr $_, pos $_;
7290 3 50       20 $here_script =~ s/.*?\n//oxm;
7291 3         42 }
7292 3         9 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7293 3         5 my $heredoc = $1;
7294 3         41 my $indent = $2;
7295 3         12 $heredoc =~ s{^$indent}{}msg; # no /ox
7296             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7297             push @heredoc_delimiter, qq{\\s*$delimiter};
7298 3         9 }
7299             else {
7300 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7301             }
7302             return qq{<<$delimiter};
7303             }
7304              
7305 3         15 # <<~`HEREDOC`
7306 6         13 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7307 6         15 $slash = 'm//';
7308             my $here_quote = $1;
7309             my $delimiter = $2;
7310 6 50       13  
7311 6         14 # get here document
7312 6         25 if ($here_script eq '') {
7313             $here_script = CORE::substr $_, pos $_;
7314 6 50       35 $here_script =~ s/.*?\n//oxm;
7315 6         104 }
7316 6         17 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7317 6         16 my $heredoc = $1;
7318 6         59 my $indent = $2;
7319 6         20 $heredoc =~ s{^$indent}{}msg; # no /ox
7320             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7321             push @heredoc_delimiter, qq{\\s*$delimiter};
7322 6         17 }
7323             else {
7324 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7325             }
7326             return qq{<<`$delimiter`};
7327             }
7328              
7329 6         26 # <<'HEREDOC'
7330 86         207 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7331 86         201 $slash = 'm//';
7332             my $here_quote = $1;
7333             my $delimiter = $2;
7334 86 100       171  
7335 86         194 # get here document
7336 83         541 if ($here_script eq '') {
7337             $here_script = CORE::substr $_, pos $_;
7338 83 50       509 $here_script =~ s/.*?\n//oxm;
7339 86         727 }
7340 86         337 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7341             push @heredoc, $1 . qq{\n$delimiter\n};
7342             push @heredoc_delimiter, $delimiter;
7343 86         157 }
7344             else {
7345 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7346             }
7347             return $here_quote;
7348             }
7349              
7350             # <<\HEREDOC
7351              
7352             # P.66 2.6.6. "Here" Documents
7353             # in Chapter 2: Bits and Pieces
7354             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7355              
7356             # P.73 "Here" Documents
7357             # in Chapter 2: Bits and Pieces
7358             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7359 86         394  
7360 2         5 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7361 2         5 $slash = 'm//';
7362             my $here_quote = $1;
7363             my $delimiter = $2;
7364 2 100       4  
7365 2         6 # get here document
7366 1         6 if ($here_script eq '') {
7367             $here_script = CORE::substr $_, pos $_;
7368 1 50       6 $here_script =~ s/.*?\n//oxm;
7369 2         38 }
7370 2         8 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7371             push @heredoc, $1 . qq{\n$delimiter\n};
7372             push @heredoc_delimiter, $delimiter;
7373 2         4 }
7374             else {
7375 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7376             }
7377             return $here_quote;
7378             }
7379              
7380 2         8 # <<"HEREDOC"
7381 39         115 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7382 39         107 $slash = 'm//';
7383             my $here_quote = $1;
7384             my $delimiter = $2;
7385 39 100       85  
7386 39         113 # get here document
7387 38         303 if ($here_script eq '') {
7388             $here_script = CORE::substr $_, pos $_;
7389 38 50       258 $here_script =~ s/.*?\n//oxm;
7390 39         567 }
7391 39         144 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7392             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7393             push @heredoc_delimiter, $delimiter;
7394 39         101 }
7395             else {
7396 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7397             }
7398             return $here_quote;
7399             }
7400              
7401 39         188 # <
7402 54         154 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7403 54         130 $slash = 'm//';
7404             my $here_quote = $1;
7405             my $delimiter = $2;
7406 54 100       119  
7407 54         172 # get here document
7408 51         353 if ($here_script eq '') {
7409             $here_script = CORE::substr $_, pos $_;
7410 51 50       413 $here_script =~ s/.*?\n//oxm;
7411 54         834 }
7412 54         200 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7413             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7414             push @heredoc_delimiter, $delimiter;
7415 54         140 }
7416             else {
7417 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7418             }
7419             return $here_quote;
7420             }
7421              
7422 54         242 # <<`HEREDOC`
7423 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7424 0         0 $slash = 'm//';
7425             my $here_quote = $1;
7426             my $delimiter = $2;
7427 0 0       0  
7428 0         0 # get here document
7429 0         0 if ($here_script eq '') {
7430             $here_script = CORE::substr $_, pos $_;
7431 0 0       0 $here_script =~ s/.*?\n//oxm;
7432 0         0 }
7433 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7434             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7435             push @heredoc_delimiter, $delimiter;
7436 0         0 }
7437             else {
7438 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7439             }
7440             return $here_quote;
7441             }
7442              
7443 0         0 # <<= <=> <= < operator
7444             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7445             return $1;
7446             }
7447              
7448 13         79 #
7449             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7450             return $1;
7451             }
7452              
7453             # --- glob
7454              
7455             # avoid "Error: Runtime exception" of perl version 5.005_03
7456 0         0  
7457             elsif (/\G < ((?:[^\x81-\xFE>\0\a\e\f\n\r\t]|[\x81-\xFE][\x00-\xFF])+?) > /oxgc) {
7458             return 'Euhc::glob("' . $1 . '")';
7459             }
7460 0         0  
7461             # __DATA__
7462             elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7463 0         0  
7464             # __END__
7465             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7466              
7467             # \cD Control-D
7468              
7469             # P.68 2.6.8. Other Literal Tokens
7470             # in Chapter 2: Bits and Pieces
7471             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7472              
7473             # P.76 Other Literal Tokens
7474             # in Chapter 2: Bits and Pieces
7475 384         3269 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7476              
7477             elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7478 0         0  
7479             # \cZ Control-Z
7480             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7481              
7482             # any operator before div
7483             elsif (/\G (
7484             -- | \+\+ |
7485 0         0 [\)\}\]]
  14161         32230  
7486              
7487             ) /oxgc) { $slash = 'div'; return $1; }
7488              
7489             # yada-yada or triple-dot operator
7490             elsif (/\G (
7491 14161         72226 \.\.\.
  7         16  
7492              
7493             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7494              
7495             # any operator before m//
7496              
7497             # //, //= (defined-or)
7498              
7499             # P.164 Logical Operators
7500             # in Chapter 10: More Control Structures
7501             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7502              
7503             # P.119 C-Style Logical (Short-Circuit) Operators
7504             # in Chapter 3: Unary and Binary Operators
7505             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7506              
7507             # (and so on)
7508              
7509             # ~~
7510              
7511             # P.221 The Smart Match Operator
7512             # in Chapter 15: Smart Matching and given-when
7513             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7514              
7515             # P.112 Smartmatch Operator
7516             # in Chapter 3: Unary and Binary Operators
7517             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7518              
7519             # (and so on)
7520              
7521             elsif (/\G ((?>
7522              
7523             !~~ | !~ | != | ! |
7524             %= | % |
7525             &&= | && | &= | &\.= | &\. | & |
7526             -= | -> | - |
7527             :(?>\s*)= |
7528             : |
7529             <<>> |
7530             <<= | <=> | <= | < |
7531             == | => | =~ | = |
7532             >>= | >> | >= | > |
7533             \*\*= | \*\* | \*= | \* |
7534             \+= | \+ |
7535             \.\. | \.= | \. |
7536             \/\/= | \/\/ |
7537             \/= | \/ |
7538             \? |
7539             \\ |
7540             \^= | \^\.= | \^\. | \^ |
7541             \b x= |
7542             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7543             ~~ | ~\. | ~ |
7544             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7545             \b(?: print )\b |
7546              
7547 7         31 [,;\(\{\[]
  23792         53557  
7548              
7549             )) /oxgc) { $slash = 'm//'; return $1; }
7550 23792         118136  
  36888         80111  
7551             # other any character
7552             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7553              
7554 36888         200428 # system error
7555             else {
7556             die __FILE__, ": Oops, this shouldn't happen!\n";
7557             }
7558             }
7559              
7560 0     3097 0 0 # escape UHC string
7561 3097         7784 sub e_string {
7562             my($string) = @_;
7563 3097         4840 my $e_string = '';
7564              
7565             local $slash = 'm//';
7566              
7567             # P.1024 Appendix W.10 Multibyte Processing
7568             # of ISBN 1-56592-224-7 CJKV Information Processing
7569 3097         4777 # (and so on)
7570              
7571             my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\$q_char|$q_char) /oxmsg;
7572 3097 100 66     30880  
7573 3097 50       14939 # without { ... }
7574 3018         7029 if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7575             if ($string !~ /<
7576             return $string;
7577             }
7578             }
7579 3018         7747  
7580 79 50       304 E_STRING_LOOP:
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    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          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    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          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    50          
7581             while ($string !~ /\G \z/oxgc) {
7582             if (0) {
7583             }
7584 606         83026  
7585 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Euhc::PREMATCH()]}
7586 0         0 elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7587             $e_string .= q{Euhc::PREMATCH()};
7588             $slash = 'div';
7589             }
7590              
7591 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Euhc::MATCH()]}
7592 0         0 elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7593             $e_string .= q{Euhc::MATCH()};
7594             $slash = 'div';
7595             }
7596              
7597 0         0 # $', ${'} --> $', ${'}
7598 0         0 elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7599             $e_string .= $1;
7600             $slash = 'div';
7601             }
7602              
7603 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Euhc::POSTMATCH()]}
7604 0         0 elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7605             $e_string .= q{Euhc::POSTMATCH()};
7606             $slash = 'div';
7607             }
7608              
7609 0         0 # bareword
7610 0         0 elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7611             $e_string .= $1;
7612             $slash = 'div';
7613             }
7614              
7615 0         0 # $0 --> $0
7616 0         0 elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7617             $e_string .= $1;
7618             $slash = 'div';
7619 0         0 }
7620 0         0 elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7621             $e_string .= $1;
7622             $slash = 'div';
7623             }
7624              
7625 0         0 # $$ --> $$
7626 0         0 elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7627             $e_string .= $1;
7628             $slash = 'div';
7629             }
7630              
7631             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7632 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7633 0         0 elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7634             $e_string .= e_capture($1);
7635             $slash = 'div';
7636 0         0 }
7637 0         0 elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7638             $e_string .= e_capture($1);
7639             $slash = 'div';
7640             }
7641              
7642 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
7643 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
7644             $e_string .= e_capture($1.'->'.$2);
7645             $slash = 'div';
7646             }
7647              
7648 0         0 # $$foo{ ... } --> $ $foo->{ ... }
7649 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
7650             $e_string .= e_capture($1.'->'.$2);
7651             $slash = 'div';
7652             }
7653              
7654 0         0 # $$foo
7655 0         0 elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
7656             $e_string .= e_capture($1);
7657             $slash = 'div';
7658             }
7659              
7660 0         0 # ${ foo }
7661 0         0 elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
7662             $e_string .= '${' . $1 . '}';
7663             $slash = 'div';
7664             }
7665              
7666 0         0 # ${ ... }
7667 3         11 elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
7668             $e_string .= e_capture($1);
7669             $slash = 'div';
7670             }
7671              
7672             # variable or function
7673 3         14 # $ @ % & * $ #
7674 0         0 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) {
7675             $e_string .= $1;
7676             $slash = 'div';
7677             }
7678             # $ $ $ $ $ $ $ $ $ $ $ $ $ $
7679 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
7680 0         0 elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
7681             $e_string .= $1;
7682             $slash = 'div';
7683             }
7684 0         0  
  0         0  
7685 0         0 # subroutines of package Euhc
  0         0  
7686 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
7687 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7688 0         0 elsif ($string =~ /\G \b UHC::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
7689 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
7690 0         0 elsif ($string =~ /\G \b UHC::eval \b /oxgc) { $e_string .= 'eval UHC::escape'; $slash = 'm//'; }
  0         0  
7691 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
7692 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Euhc::chop'; $slash = 'm//'; }
  0         0  
7693 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
7694 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
7695 0         0 elsif ($string =~ /\G \b UHC::index \b /oxgc) { $e_string .= 'UHC::index'; $slash = 'm//'; }
  0         0  
7696 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Euhc::index'; $slash = 'm//'; }
  0         0  
7697 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
7698 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
7699 0         0 elsif ($string =~ /\G \b UHC::rindex \b /oxgc) { $e_string .= 'UHC::rindex'; $slash = 'm//'; }
  0         0  
7700 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Euhc::rindex'; $slash = 'm//'; }
  0         0  
7701 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::lc'; $slash = 'm//'; }
  0         0  
7702 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::lcfirst'; $slash = 'm//'; }
  0         0  
7703 0         0 elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::uc'; $slash = 'm//'; }
  0         0  
7704             elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::ucfirst'; $slash = 'm//'; }
7705 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::fc'; $slash = 'm//'; }
  0         0  
7706 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7707 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7708 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7709 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7710 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7711 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7712             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7713             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7714 1         5  
  1         8  
7715 1         4 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7716 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7717 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7718 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7719 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7720 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7721             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7722             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Euhc::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7723 1         4  
  0         0  
7724 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7725 0         0 { $e_string .= "Euhc::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7726 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Euhc::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7727             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Euhc::filetest qw($1),"; $slash = 'm//'; }
7728 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Euhc::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
7729 0         0  
  0         0  
7730 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Euhc::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7731 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7732 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7733 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7734 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         11  
7735             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
7736 2         8 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Euhc::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         7  
7737 1         6  
  0         0  
7738 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Euhc::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7739 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7740 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7741 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
7742 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         18  
7743             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7744             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Euhc::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
7745 2         8  
  0         0  
7746 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
7747 0         0 { $e_string .= "Euhc::$1($2)"; $slash = 'm//'; }
  0         0  
7748 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Euhc::$1($2)"; $slash = 'm//'; }
  0         0  
7749 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Euhc::$1"; $slash = 'm//'; }
  0         0  
7750 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Euhc::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
7751 0         0 elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
  0         0  
7752             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::lstat'; $slash = 'm//'; }
7753             elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::stat'; $slash = 'm//'; }
7754 0         0  
  0         0  
7755 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
7756 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7757 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  
7758 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  
7759 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  
7760 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  
7761             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
7762 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  
7763 0         0  
  0         0  
7764 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
7765 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  
7766 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  
7767 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  
7768 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  
7769             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7770             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
7771 0         0  
  0         0  
7772 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
7773 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7774 0         0 elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
  0         0  
7775             elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
7776 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
7777 0         0  
  0         0  
7778 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7779 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7780 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::chr'; $slash = 'm//'; }
  0         0  
7781 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7782 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
7783 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Euhc::glob'; $slash = 'm//'; }
  0         0  
7784 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Euhc::lc_'; $slash = 'm//'; }
  0         0  
7785 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Euhc::lcfirst_'; $slash = 'm//'; }
  0         0  
7786 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Euhc::uc_'; $slash = 'm//'; }
  0         0  
7787 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Euhc::ucfirst_'; $slash = 'm//'; }
  0         0  
7788 0         0 elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Euhc::fc_'; $slash = 'm//'; }
  0         0  
7789             elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Euhc::lstat_'; $slash = 'm//'; }
7790 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Euhc::stat_'; $slash = 'm//'; }
  0         0  
7791 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
7792 0         0 \b /oxgc) { $e_string .= "Euhc::filetest_(qw($1))"; $slash = 'm//'; }
  0         0  
7793             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Euhc::${1}_"; $slash = 'm//'; }
7794 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
7795 0         0  
  0         0  
7796 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
7797 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
7798 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Euhc::chr_'; $slash = 'm//'; }
  0         0  
7799 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
7800 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
7801 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Euhc::glob_'; $slash = 'm//'; }
  0         0  
7802 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
7803 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
7804 0         0 elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Euhc::opendir$1*"; $slash = 'm//'; }
  0         0  
7805             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Euhc::opendir$1*"; $slash = 'm//'; }
7806             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Euhc::unlink'; $slash = 'm//'; }
7807              
7808 0         0 # chdir
7809             elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
7810 0         0 $slash = 'm//';
7811              
7812 0         0 $e_string .= 'Euhc::chdir';
7813 0         0  
7814             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7815             $e_string .= $1;
7816             }
7817 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
7818             # end of chdir
7819             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
7820 0         0  
  0         0  
7821             # chdir scalar value
7822             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
7823              
7824 0 0       0 # chdir qq//
  0         0  
  0         0  
7825             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7826 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
7827 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7828 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7829 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7830 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
7831 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
7832 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
7833 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
  0         0  
7834             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
7835 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
7836             }
7837             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7838             }
7839             }
7840              
7841 0 0       0 # chdir q//
  0         0  
  0         0  
7842             elsif ($string =~ /\G \b (q) \b /oxgc) {
7843 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
7844 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7845 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7846 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
7847 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q ( ) --> qr ( )
  0         0  
7848 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q { } --> qr { }
  0         0  
7849 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q [ ] --> qr [ ]
  0         0  
7850 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q < > --> qr < >
  0         0  
7851             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
7852 0         0 elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q * * --> qr * *
7853             }
7854             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7855             }
7856             }
7857              
7858 0         0 # chdir ''
7859 0         0 elsif ($string =~ /\G (\') /oxgc) {
7860 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7861 0         0 while ($string !~ /\G \z/oxgc) {
7862 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7863 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
7864             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
7865 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7866             }
7867             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7868             }
7869              
7870 0         0 # chdir ""
7871 0         0 elsif ($string =~ /\G (\") /oxgc) {
7872 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7873 0         0 while ($string !~ /\G \z/oxgc) {
7874 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
7875 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
7876             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
7877 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
7878             }
7879             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7880             }
7881             }
7882              
7883 0         0 # split
7884             elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
7885 0         0 $slash = 'm//';
7886 0         0  
7887 0         0 my $e = '';
7888             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
7889             $e .= $1;
7890             }
7891 0 0       0  
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7892             # end of split
7893             if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Euhc::split' . $e; }
7894 0         0  
  0         0  
7895             # split scalar value
7896             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Euhc::split' . $e . e_string($1); next E_STRING_LOOP; }
7897 0         0  
  0         0  
7898 0         0 # split literal space
  0         0  
7899 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
7900 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Euhc::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7901 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Euhc::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7902 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Euhc::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7903 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Euhc::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7904 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Euhc::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
7905 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
7906 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7907 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7908 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7909 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7910 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Euhc::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
7911             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Euhc::split' . $e . qq {' '}; next E_STRING_LOOP; }
7912             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Euhc::split' . $e . qq {" "}; next E_STRING_LOOP; }
7913              
7914 0 0       0 # split qq//
  0         0  
  0         0  
7915             elsif ($string =~ /\G \b (qq) \b /oxgc) {
7916 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
7917 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7918 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7919 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7920 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  
7921 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  
7922 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  
7923 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  
7924             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
7925 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 * *
7926             }
7927             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7928             }
7929             }
7930              
7931 0 0       0 # split qr//
  0         0  
  0         0  
7932             elsif ($string =~ /\G \b (qr) \b /oxgc) {
7933 0         0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
7934 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7935 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7936 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7937 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  
7938 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  
7939 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  
7940 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  
7941 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  
7942             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
7943 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 * *
7944             }
7945             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7946             }
7947             }
7948              
7949 0 0       0 # split q//
  0         0  
  0         0  
7950             elsif ($string =~ /\G \b (q) \b /oxgc) {
7951 0         0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
7952 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
7953 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7954 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7955 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  
7956 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  
7957 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  
7958 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  
7959             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
7960 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 * *
7961             }
7962             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7963             }
7964             }
7965              
7966 0 0       0 # split m//
  0         0  
  0         0  
7967             elsif ($string =~ /\G \b (m) \b /oxgc) {
7968 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 # #
7969 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7970 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
7971 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
7972 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  
7973 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  
7974 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  
7975 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  
7976 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  
7977             elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
7978 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 * *
7979             }
7980             die __FILE__, ": Search pattern not terminated\n";
7981             }
7982             }
7983              
7984 0         0 # split ''
7985 0         0 elsif ($string =~ /\G (\') /oxgc) {
7986 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
7987 0         0 while ($string !~ /\G \z/oxgc) {
7988 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7989 0         0 elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
7990             elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
7991 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
7992             }
7993             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7994             }
7995              
7996 0         0 # split ""
7997 0         0 elsif ($string =~ /\G (\") /oxgc) {
7998 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
7999 0         0 while ($string !~ /\G \z/oxgc) {
8000 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
  0         0  
8001 0         0 elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8002             elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8003 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8004             }
8005             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8006             }
8007              
8008 0         0 # split //
8009 0         0 elsif ($string =~ /\G (\/) /oxgc) {
8010 0 0       0 my $regexp = '';
  0 0       0  
    0          
    0          
8011 0         0 while ($string !~ /\G \z/oxgc) {
8012 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
  0         0  
8013 0         0 elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8014             elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8015 0         0 elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8016             }
8017             die __FILE__, ": Search pattern not terminated\n";
8018             }
8019             }
8020              
8021 0         0 # qq//
8022 0 0       0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8023 0         0 my $ope = $1;
8024             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8025             $e_string .= e_qq($ope,$1,$3,$2);
8026 0         0 }
8027 0         0 else {
8028 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8029 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8030 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8031 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8032 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8033 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
  0         0  
8034             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8035 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8036             }
8037             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8038             }
8039             }
8040              
8041 0         0 # qx//
8042 0 0       0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8043 0         0 my $ope = $1;
8044             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8045             $e_string .= e_qq($ope,$1,$3,$2);
8046 0         0 }
8047 0         0 else {
8048 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8049 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8050 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8051 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8052 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8053 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8054 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
  0         0  
8055             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8056 0         0 elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8057             }
8058             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8059             }
8060             }
8061              
8062 0         0 # q//
8063 0 0       0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8064 0         0 my $ope = $1;
8065             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8066             $e_string .= e_q($ope,$1,$3,$2);
8067 0         0 }
8068 0         0 else {
8069 0 0       0 my $e = '';
  0 0       0  
    0          
    0          
    0          
    0          
8070 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8071 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8072 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8073 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8074 0         0 elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
  0         0  
8075             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8076 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 * *
8077             }
8078             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8079             }
8080             }
8081 0         0  
8082             # ''
8083             elsif ($string =~ /\G (?
8084 44         171  
8085             # ""
8086             elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8087 6         68  
8088             # ``
8089             elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8090 0         0  
8091             # <<>> (a safer ARGV)
8092             elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8093 0         0  
8094             # <<= <=> <= < operator
8095             elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8096 0         0  
8097             #
8098             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8099              
8100 0         0 # --- glob
8101             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8102             $e_string .= 'Euhc::glob("' . $1 . '")';
8103             }
8104              
8105 0         0 # << (bit shift) --- not here document
8106 0         0 elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8107             $slash = 'm//';
8108             $e_string .= $1;
8109             }
8110              
8111 0         0 # <<~'HEREDOC'
8112 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8113 0         0 $slash = 'm//';
8114             my $here_quote = $1;
8115             my $delimiter = $2;
8116 0 0       0  
8117 0         0 # get here document
8118 0         0 if ($here_script eq '') {
8119             $here_script = CORE::substr $_, pos $_;
8120 0 0       0 $here_script =~ s/.*?\n//oxm;
8121 0         0 }
8122 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8123 0         0 my $heredoc = $1;
8124 0         0 my $indent = $2;
8125 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8126             push @heredoc, $heredoc . qq{\n$delimiter\n};
8127             push @heredoc_delimiter, qq{\\s*$delimiter};
8128 0         0 }
8129             else {
8130 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8131             }
8132             $e_string .= qq{<<'$delimiter'};
8133             }
8134              
8135 0         0 # <<~\HEREDOC
8136 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8137 0         0 $slash = 'm//';
8138             my $here_quote = $1;
8139             my $delimiter = $2;
8140 0 0       0  
8141 0         0 # get here document
8142 0         0 if ($here_script eq '') {
8143             $here_script = CORE::substr $_, pos $_;
8144 0 0       0 $here_script =~ s/.*?\n//oxm;
8145 0         0 }
8146 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8147 0         0 my $heredoc = $1;
8148 0         0 my $indent = $2;
8149 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8150             push @heredoc, $heredoc . qq{\n$delimiter\n};
8151             push @heredoc_delimiter, qq{\\s*$delimiter};
8152 0         0 }
8153             else {
8154 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8155             }
8156             $e_string .= qq{<<\\$delimiter};
8157             }
8158              
8159 0         0 # <<~"HEREDOC"
8160 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8161 0         0 $slash = 'm//';
8162             my $here_quote = $1;
8163             my $delimiter = $2;
8164 0 0       0  
8165 0         0 # get here document
8166 0         0 if ($here_script eq '') {
8167             $here_script = CORE::substr $_, pos $_;
8168 0 0       0 $here_script =~ s/.*?\n//oxm;
8169 0         0 }
8170 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8171 0         0 my $heredoc = $1;
8172 0         0 my $indent = $2;
8173 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8174             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8175             push @heredoc_delimiter, qq{\\s*$delimiter};
8176 0         0 }
8177             else {
8178 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8179             }
8180             $e_string .= qq{<<"$delimiter"};
8181             }
8182              
8183 0         0 # <<~HEREDOC
8184 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8185 0         0 $slash = 'm//';
8186             my $here_quote = $1;
8187             my $delimiter = $2;
8188 0 0       0  
8189 0         0 # get here document
8190 0         0 if ($here_script eq '') {
8191             $here_script = CORE::substr $_, pos $_;
8192 0 0       0 $here_script =~ s/.*?\n//oxm;
8193 0         0 }
8194 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8195 0         0 my $heredoc = $1;
8196 0         0 my $indent = $2;
8197 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8198             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8199             push @heredoc_delimiter, qq{\\s*$delimiter};
8200 0         0 }
8201             else {
8202 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8203             }
8204             $e_string .= qq{<<$delimiter};
8205             }
8206              
8207 0         0 # <<~`HEREDOC`
8208 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8209 0         0 $slash = 'm//';
8210             my $here_quote = $1;
8211             my $delimiter = $2;
8212 0 0       0  
8213 0         0 # get here document
8214 0         0 if ($here_script eq '') {
8215             $here_script = CORE::substr $_, pos $_;
8216 0 0       0 $here_script =~ s/.*?\n//oxm;
8217 0         0 }
8218 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8219 0         0 my $heredoc = $1;
8220 0         0 my $indent = $2;
8221 0         0 $heredoc =~ s{^$indent}{}msg; # no /ox
8222             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8223             push @heredoc_delimiter, qq{\\s*$delimiter};
8224 0         0 }
8225             else {
8226 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8227             }
8228             $e_string .= qq{<<`$delimiter`};
8229             }
8230              
8231 0         0 # <<'HEREDOC'
8232 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8233 0         0 $slash = 'm//';
8234             my $here_quote = $1;
8235             my $delimiter = $2;
8236 0 0       0  
8237 0         0 # get here document
8238 0         0 if ($here_script eq '') {
8239             $here_script = CORE::substr $_, pos $_;
8240 0 0       0 $here_script =~ s/.*?\n//oxm;
8241 0         0 }
8242 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8243             push @heredoc, $1 . qq{\n$delimiter\n};
8244             push @heredoc_delimiter, $delimiter;
8245 0         0 }
8246             else {
8247 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8248             }
8249             $e_string .= $here_quote;
8250             }
8251              
8252 0         0 # <<\HEREDOC
8253 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8254 0         0 $slash = 'm//';
8255             my $here_quote = $1;
8256             my $delimiter = $2;
8257 0 0       0  
8258 0         0 # get here document
8259 0         0 if ($here_script eq '') {
8260             $here_script = CORE::substr $_, pos $_;
8261 0 0       0 $here_script =~ s/.*?\n//oxm;
8262 0         0 }
8263 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8264             push @heredoc, $1 . qq{\n$delimiter\n};
8265             push @heredoc_delimiter, $delimiter;
8266 0         0 }
8267             else {
8268 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8269             }
8270             $e_string .= $here_quote;
8271             }
8272              
8273 0         0 # <<"HEREDOC"
8274 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8275 0         0 $slash = 'm//';
8276             my $here_quote = $1;
8277             my $delimiter = $2;
8278 0 0       0  
8279 0         0 # get here document
8280 0         0 if ($here_script eq '') {
8281             $here_script = CORE::substr $_, pos $_;
8282 0 0       0 $here_script =~ s/.*?\n//oxm;
8283 0         0 }
8284 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8285             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8286             push @heredoc_delimiter, $delimiter;
8287 0         0 }
8288             else {
8289 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8290             }
8291             $e_string .= $here_quote;
8292             }
8293              
8294 0         0 # <
8295 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8296 0         0 $slash = 'm//';
8297             my $here_quote = $1;
8298             my $delimiter = $2;
8299 0 0       0  
8300 0         0 # get here document
8301 0         0 if ($here_script eq '') {
8302             $here_script = CORE::substr $_, pos $_;
8303 0 0       0 $here_script =~ s/.*?\n//oxm;
8304 0         0 }
8305 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8306             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8307             push @heredoc_delimiter, $delimiter;
8308 0         0 }
8309             else {
8310 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8311             }
8312             $e_string .= $here_quote;
8313             }
8314              
8315 0         0 # <<`HEREDOC`
8316 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8317 0         0 $slash = 'm//';
8318             my $here_quote = $1;
8319             my $delimiter = $2;
8320 0 0       0  
8321 0         0 # get here document
8322 0         0 if ($here_script eq '') {
8323             $here_script = CORE::substr $_, pos $_;
8324 0 0       0 $here_script =~ s/.*?\n//oxm;
8325 0         0 }
8326 0         0 if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8327             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8328             push @heredoc_delimiter, $delimiter;
8329 0         0 }
8330             else {
8331 0         0 die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8332             }
8333             $e_string .= $here_quote;
8334             }
8335              
8336             # any operator before div
8337             elsif ($string =~ /\G (
8338             -- | \+\+ |
8339 0         0 [\)\}\]]
  80         165  
8340              
8341             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8342              
8343             # yada-yada or triple-dot operator
8344             elsif ($string =~ /\G (
8345 80         290 \.\.\.
  0         0  
8346              
8347             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8348              
8349             # any operator before m//
8350             elsif ($string =~ /\G ((?>
8351              
8352             !~~ | !~ | != | ! |
8353             %= | % |
8354             &&= | && | &= | &\.= | &\. | & |
8355             -= | -> | - |
8356             :(?>\s*)= |
8357             : |
8358             <<>> |
8359             <<= | <=> | <= | < |
8360             == | => | =~ | = |
8361             >>= | >> | >= | > |
8362             \*\*= | \*\* | \*= | \* |
8363             \+= | \+ |
8364             \.\. | \.= | \. |
8365             \/\/= | \/\/ |
8366             \/= | \/ |
8367             \? |
8368             \\ |
8369             \^= | \^\.= | \^\. | \^ |
8370             \b x= |
8371             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8372             ~~ | ~\. | ~ |
8373             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8374             \b(?: print )\b |
8375              
8376 0         0 [,;\(\{\[]
  112         251  
8377              
8378             )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8379 112         742  
8380             # other any character
8381             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8382              
8383 353         1459 # system error
8384             else {
8385             die __FILE__, ": Oops, this shouldn't happen!\n";
8386             }
8387 0         0 }
8388              
8389             return $e_string;
8390             }
8391              
8392             #
8393             # character class
8394 79     5434 0 349 #
8395             sub character_class {
8396 5434 100       10930 my($char,$modifier) = @_;
8397 5434 100       9089  
8398 115         252 if ($char eq '.') {
8399             if ($modifier =~ /s/) {
8400             return '${Euhc::dot_s}';
8401 23         78 }
8402             else {
8403             return '${Euhc::dot}';
8404             }
8405 92         202 }
8406             else {
8407             return Euhc::classic_character_class($char);
8408             }
8409             }
8410              
8411             #
8412             # escape capture ($1, $2, $3, ...)
8413             #
8414 5319     637 0 9275 sub e_capture {
8415 637         3012  
8416             return join '', '${Euhc::capture(', $_[0], ')}';
8417             return join '', '${', $_[0], '}';
8418             }
8419              
8420             #
8421             # escape transliteration (tr/// or y///)
8422 0     11 0 0 #
8423 11         72 sub e_tr {
8424 11   100     21 my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8425             my $e_tr = '';
8426 11         38 $modifier ||= '';
8427              
8428             $slash = 'div';
8429 11         20  
8430             # quote character class 1
8431             $charclass = q_tr($charclass);
8432 11         30  
8433             # quote character class 2
8434             $charclass2 = q_tr($charclass2);
8435 11 50       24  
8436 11 0       35 # /b /B modifier
8437 0         0 if ($modifier =~ tr/bB//d) {
8438             if ($variable eq '') {
8439             $e_tr = qq{tr$charclass$e$charclass2$modifier};
8440 0         0 }
8441             else {
8442             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8443             }
8444 0 100       0 }
8445 11         23 else {
8446             if ($variable eq '') {
8447             $e_tr = qq{Euhc::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8448 2         8 }
8449             else {
8450             $e_tr = qq{Euhc::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8451             }
8452             }
8453 9         41  
8454 11         16 # clear tr/// variable
8455             $tr_variable = '';
8456 11         16 $bind_operator = '';
8457              
8458             return $e_tr;
8459             }
8460              
8461             #
8462             # quote for escape transliteration (tr/// or y///)
8463 11     22 0 142 #
8464             sub q_tr {
8465             my($charclass) = @_;
8466 22 50       40  
    0          
    0          
    0          
    0          
    0          
8467 22         57 # quote character class
8468             if ($charclass !~ /'/oxms) {
8469             return e_q('', "'", "'", $charclass); # --> q' '
8470 22         50 }
8471             elsif ($charclass !~ /\//oxms) {
8472             return e_q('q', '/', '/', $charclass); # --> q/ /
8473 0         0 }
8474             elsif ($charclass !~ /\#/oxms) {
8475             return e_q('q', '#', '#', $charclass); # --> q# #
8476 0         0 }
8477             elsif ($charclass !~ /[\<\>]/oxms) {
8478             return e_q('q', '<', '>', $charclass); # --> q< >
8479 0         0 }
8480             elsif ($charclass !~ /[\(\)]/oxms) {
8481             return e_q('q', '(', ')', $charclass); # --> q( )
8482 0         0 }
8483             elsif ($charclass !~ /[\{\}]/oxms) {
8484             return e_q('q', '{', '}', $charclass); # --> q{ }
8485 0         0 }
8486 0 0       0 else {
8487 0         0 for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8488             if ($charclass !~ /\Q$char\E/xms) {
8489             return e_q('q', $char, $char, $charclass);
8490             }
8491             }
8492 0         0 }
8493              
8494             return e_q('q', '{', '}', $charclass);
8495             }
8496              
8497             #
8498             # escape q string (q//, '')
8499 0     3967 0 0 #
8500             sub e_q {
8501 3967         10906 my($ope,$delimiter,$end_delimiter,$string) = @_;
8502              
8503 3967         5980 $slash = 'div';
8504 3967         26853  
8505             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8506             for (my $i=0; $i <= $#char; $i++) {
8507 3967 100 100     11880  
    100 100        
8508 21145         131891 # escape last octet of multiple-octet
8509             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8510             $char[$i] = $1 . '\\' . $2;
8511 1         5 }
8512             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8513             $char[$i] = $1 . '\\' . $2;
8514 22 100 100     89 }
8515 3967         16447 }
8516             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8517             $char[-1] = $1 . '\\' . $2;
8518 204         787 }
8519 3967         22538  
8520             return join '', $ope, $delimiter, @char, $end_delimiter;
8521             return join '', $ope, $delimiter, $string, $end_delimiter;
8522             }
8523              
8524             #
8525             # escape qq string (qq//, "", qx//, ``)
8526 0     9552 0 0 #
8527             sub e_qq {
8528 9552         23791 my($ope,$delimiter,$end_delimiter,$string) = @_;
8529              
8530 9552         14469 $slash = 'div';
8531 9552         12270  
8532             my $left_e = 0;
8533             my $right_e = 0;
8534 9552         11320  
8535             # split regexp
8536             my @char = $string =~ /\G((?>
8537             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8538             \\x\{ (?>[0-9A-Fa-f]+) \} |
8539             \\o\{ (?>[0-7]+) \} |
8540             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8541             \\ $q_char |
8542             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8543             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8544             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8545             \$ (?>\s* [0-9]+) |
8546             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8547             \$ \$ (?![\w\{]) |
8548             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8549             $q_char
8550 9552         374393 ))/oxmsg;
8551              
8552             for (my $i=0; $i <= $#char; $i++) {
8553 9552 50 66     30950  
    50 33        
    100          
    100          
    50          
8554 307164         1040915 # "\L\u" --> "\u\L"
8555             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8556             @char[$i,$i+1] = @char[$i+1,$i];
8557             }
8558              
8559 0         0 # "\U\l" --> "\l\U"
8560             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8561             @char[$i,$i+1] = @char[$i+1,$i];
8562             }
8563              
8564 0         0 # octal escape sequence
8565             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8566             $char[$i] = Euhc::octchr($1);
8567             }
8568              
8569 1         5 # hexadecimal escape sequence
8570             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8571             $char[$i] = Euhc::hexchr($1);
8572             }
8573              
8574 1         4 # \N{CHARNAME} --> N{CHARNAME}
8575             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8576             $char[$i] = $1;
8577 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8578              
8579             if (0) {
8580             }
8581              
8582             # escape last octet of multiple-octet
8583 307164         2990231 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8584 0         0 # variable $delimiter and $end_delimiter can be ''
8585             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8586             $char[$i] = $1 . '\\' . $2;
8587             }
8588              
8589             # \F
8590             #
8591             # P.69 Table 2-6. Translation escapes
8592             # in Chapter 2: Bits and Pieces
8593             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8594             # (and so on)
8595              
8596 1342 50       4717 # \u \l \U \L \F \Q \E
8597 647         1718 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8598             if ($right_e < $left_e) {
8599             $char[$i] = '\\' . $char[$i];
8600             }
8601             }
8602             elsif ($char[$i] eq '\u') {
8603              
8604             # "STRING @{[ LIST EXPR ]} MORE STRING"
8605              
8606             # P.257 Other Tricks You Can Do with Hard References
8607             # in Chapter 8: References
8608             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8609              
8610             # P.353 Other Tricks You Can Do with Hard References
8611             # in Chapter 8: References
8612             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8613              
8614 0         0 # (and so on)
8615 0         0  
8616             $char[$i] = '@{[Euhc::ucfirst qq<';
8617             $left_e++;
8618 0         0 }
8619 0         0 elsif ($char[$i] eq '\l') {
8620             $char[$i] = '@{[Euhc::lcfirst qq<';
8621             $left_e++;
8622 0         0 }
8623 0         0 elsif ($char[$i] eq '\U') {
8624             $char[$i] = '@{[Euhc::uc qq<';
8625             $left_e++;
8626 0         0 }
8627 6         11 elsif ($char[$i] eq '\L') {
8628             $char[$i] = '@{[Euhc::lc qq<';
8629             $left_e++;
8630 6         11 }
8631 9         18 elsif ($char[$i] eq '\F') {
8632             $char[$i] = '@{[Euhc::fc qq<';
8633             $left_e++;
8634 9         22 }
8635 0         0 elsif ($char[$i] eq '\Q') {
8636             $char[$i] = '@{[CORE::quotemeta qq<';
8637             $left_e++;
8638 0 50       0 }
8639 12         23 elsif ($char[$i] eq '\E') {
8640 12         36 if ($right_e < $left_e) {
8641             $char[$i] = '>]}';
8642             $right_e++;
8643 12         26 }
8644             else {
8645             $char[$i] = '';
8646             }
8647 0         0 }
8648 0 0       0 elsif ($char[$i] eq '\Q') {
8649 0         0 while (1) {
8650             if (++$i > $#char) {
8651 0 0       0 last;
8652 0         0 }
8653             if ($char[$i] eq '\E') {
8654             last;
8655             }
8656             }
8657             }
8658             elsif ($char[$i] eq '\E') {
8659             }
8660              
8661             # $0 --> $0
8662             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8663             }
8664             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8665             }
8666              
8667             # $$ --> $$
8668             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8669             }
8670              
8671             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8672 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8673             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8674             $char[$i] = e_capture($1);
8675 415         1116 }
8676             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8677             $char[$i] = e_capture($1);
8678             }
8679              
8680 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8681             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8682             $char[$i] = e_capture($1.'->'.$2);
8683             }
8684              
8685 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8686             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8687             $char[$i] = e_capture($1.'->'.$2);
8688             }
8689              
8690 0         0 # $$foo
8691             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8692             $char[$i] = e_capture($1);
8693             }
8694              
8695 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Euhc::PREMATCH()
8696             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8697             $char[$i] = '@{[Euhc::PREMATCH()]}';
8698             }
8699              
8700 44         166 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Euhc::MATCH()
8701             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8702             $char[$i] = '@{[Euhc::MATCH()]}';
8703             }
8704              
8705 45         163 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Euhc::POSTMATCH()
8706             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8707             $char[$i] = '@{[Euhc::POSTMATCH()]}';
8708             }
8709              
8710             # ${ foo } --> ${ foo }
8711             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8712             }
8713              
8714 33         118 # ${ ... }
8715             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8716             $char[$i] = e_capture($1);
8717             }
8718             }
8719 0 100       0  
8720 9552         21884 # return string
8721             if ($left_e > $right_e) {
8722 3         18 return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
8723             }
8724             return join '', $ope, $delimiter, @char, $end_delimiter;
8725             }
8726              
8727             #
8728             # escape qw string (qw//)
8729 9549     34 0 82935 #
8730             sub e_qw {
8731 34         179 my($ope,$delimiter,$end_delimiter,$string) = @_;
8732              
8733             $slash = 'div';
8734 34         73  
  34         349  
8735 621 50       1022 # choice again delimiter
    0          
    0          
    0          
    0          
8736 34         184 my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
8737             if (not $octet{$end_delimiter}) {
8738             return join '', $ope, $delimiter, $string, $end_delimiter;
8739 34         229 }
8740             elsif (not $octet{')'}) {
8741             return join '', $ope, '(', $string, ')';
8742 0         0 }
8743             elsif (not $octet{'}'}) {
8744             return join '', $ope, '{', $string, '}';
8745 0         0 }
8746             elsif (not $octet{']'}) {
8747             return join '', $ope, '[', $string, ']';
8748 0         0 }
8749             elsif (not $octet{'>'}) {
8750             return join '', $ope, '<', $string, '>';
8751 0         0 }
8752 0 0       0 else {
8753 0         0 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8754             if (not $octet{$char}) {
8755             return join '', $ope, $char, $string, $char;
8756             }
8757             }
8758             }
8759 0         0  
8760 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
8761 0         0 my @string = CORE::split(/\s+/, $string);
8762 0         0 for my $string (@string) {
8763 0 0       0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
8764 0         0 for my $octet (@octet) {
8765             if ($octet =~ /\A (['\\]) \z/oxms) {
8766             $octet = '\\' . $1;
8767 0         0 }
8768             }
8769 0         0 $string = join '', @octet;
  0         0  
8770             }
8771             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
8772             }
8773              
8774             #
8775             # escape here document (<<"HEREDOC", <
8776 0     108 0 0 #
8777             sub e_heredoc {
8778 108         308 my($string) = @_;
8779              
8780 108         217 $slash = 'm//';
8781              
8782 108         406 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
8783 108         178  
8784             my $left_e = 0;
8785             my $right_e = 0;
8786 108         164  
8787             # split regexp
8788             my @char = $string =~ /\G((?>
8789             [^\x81-\xFE\\\$]|[\x81-\xFE][\x00-\xFF] |
8790             \\x\{ (?>[0-9A-Fa-f]+) \} |
8791             \\o\{ (?>[0-7]+) \} |
8792             \\N\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
8793             \\ $q_char |
8794             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8795             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8796             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8797             \$ (?>\s* [0-9]+) |
8798             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8799             \$ \$ (?![\w\{]) |
8800             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8801             $q_char
8802 108         11806 ))/oxmsg;
8803              
8804             for (my $i=0; $i <= $#char; $i++) {
8805 108 50 66     616  
    50 33        
    100          
    100          
    50          
8806 3199         10610 # "\L\u" --> "\u\L"
8807             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8808             @char[$i,$i+1] = @char[$i+1,$i];
8809             }
8810              
8811 0         0 # "\U\l" --> "\l\U"
8812             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8813             @char[$i,$i+1] = @char[$i+1,$i];
8814             }
8815              
8816 0         0 # octal escape sequence
8817             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8818             $char[$i] = Euhc::octchr($1);
8819             }
8820              
8821 1         3 # hexadecimal escape sequence
8822             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8823             $char[$i] = Euhc::hexchr($1);
8824             }
8825              
8826 1         4 # \N{CHARNAME} --> N{CHARNAME}
8827             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
8828             $char[$i] = $1;
8829 0 100       0 }
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8830              
8831             if (0) {
8832             }
8833 3199         30494  
8834 0         0 # escape character
8835             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
8836             $char[$i] = $1 . '\\' . $2;
8837             }
8838              
8839 57 50       235 # \u \l \U \L \F \Q \E
8840 72         162 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8841             if ($right_e < $left_e) {
8842             $char[$i] = '\\' . $char[$i];
8843             }
8844 0         0 }
8845 0         0 elsif ($char[$i] eq '\u') {
8846             $char[$i] = '@{[Euhc::ucfirst qq<';
8847             $left_e++;
8848 0         0 }
8849 0         0 elsif ($char[$i] eq '\l') {
8850             $char[$i] = '@{[Euhc::lcfirst qq<';
8851             $left_e++;
8852 0         0 }
8853 0         0 elsif ($char[$i] eq '\U') {
8854             $char[$i] = '@{[Euhc::uc qq<';
8855             $left_e++;
8856 0         0 }
8857 6         9 elsif ($char[$i] eq '\L') {
8858             $char[$i] = '@{[Euhc::lc qq<';
8859             $left_e++;
8860 6         10 }
8861 0         0 elsif ($char[$i] eq '\F') {
8862             $char[$i] = '@{[Euhc::fc qq<';
8863             $left_e++;
8864 0         0 }
8865 0         0 elsif ($char[$i] eq '\Q') {
8866             $char[$i] = '@{[CORE::quotemeta qq<';
8867             $left_e++;
8868 0 50       0 }
8869 3         7 elsif ($char[$i] eq '\E') {
8870 3         5 if ($right_e < $left_e) {
8871             $char[$i] = '>]}';
8872             $right_e++;
8873 3         6 }
8874             else {
8875             $char[$i] = '';
8876             }
8877 0         0 }
8878 0 0       0 elsif ($char[$i] eq '\Q') {
8879 0         0 while (1) {
8880             if (++$i > $#char) {
8881 0 0       0 last;
8882 0         0 }
8883             if ($char[$i] eq '\E') {
8884             last;
8885             }
8886             }
8887             }
8888             elsif ($char[$i] eq '\E') {
8889             }
8890              
8891             # $0 --> $0
8892             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
8893             }
8894             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
8895             }
8896              
8897             # $$ --> $$
8898             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
8899             }
8900              
8901             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
8902 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
8903             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
8904             $char[$i] = e_capture($1);
8905 0         0 }
8906             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
8907             $char[$i] = e_capture($1);
8908             }
8909              
8910 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8911             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
8912             $char[$i] = e_capture($1.'->'.$2);
8913             }
8914              
8915 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8916             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
8917             $char[$i] = e_capture($1.'->'.$2);
8918             }
8919              
8920 0         0 # $$foo
8921             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
8922             $char[$i] = e_capture($1);
8923             }
8924              
8925 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Euhc::PREMATCH()
8926             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
8927             $char[$i] = '@{[Euhc::PREMATCH()]}';
8928             }
8929              
8930 8         58 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Euhc::MATCH()
8931             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
8932             $char[$i] = '@{[Euhc::MATCH()]}';
8933             }
8934              
8935 8         56 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Euhc::POSTMATCH()
8936             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
8937             $char[$i] = '@{[Euhc::POSTMATCH()]}';
8938             }
8939              
8940             # ${ foo } --> ${ foo }
8941             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
8942             }
8943              
8944 6         40 # ${ ... }
8945             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
8946             $char[$i] = e_capture($1);
8947             }
8948             }
8949 0 100       0  
8950 108         308 # return string
8951             if ($left_e > $right_e) {
8952 3         25 return join '', @char, '>]}' x ($left_e - $right_e);
8953             }
8954             return join '', @char;
8955             }
8956              
8957             #
8958             # escape regexp (m//, qr//)
8959 105     1835 0 888 #
8960 1835   100     8031 sub e_qr {
8961             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
8962 1835         6721 $modifier ||= '';
8963 1835 50       3936  
8964 1835         4891 $modifier =~ tr/p//d;
8965 0         0 if ($modifier =~ /([adlu])/oxms) {
8966 0 0       0 my $line = 0;
8967 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
8968 0         0 if ($filename ne __FILE__) {
8969             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
8970             last;
8971 0         0 }
8972             }
8973             die qq{Unsupported modifier "$1" used at line $line.\n};
8974 0         0 }
8975              
8976             $slash = 'div';
8977 1835 100       3133  
    100          
8978 1835         5813 # literal null string pattern
8979 8         13 if ($string eq '') {
8980 8         12 $modifier =~ tr/bB//d;
8981             $modifier =~ tr/i//d;
8982             return join '', $ope, $delimiter, $end_delimiter, $modifier;
8983             }
8984              
8985             # /b /B modifier
8986             elsif ($modifier =~ tr/bB//d) {
8987 8 50       44  
8988 240         585 # choice again delimiter
8989 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
8990 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
8991 0         0 my %octet = map {$_ => 1} @char;
8992 0         0 if (not $octet{')'}) {
8993             $delimiter = '(';
8994             $end_delimiter = ')';
8995 0         0 }
8996 0         0 elsif (not $octet{'}'}) {
8997             $delimiter = '{';
8998             $end_delimiter = '}';
8999 0         0 }
9000 0         0 elsif (not $octet{']'}) {
9001             $delimiter = '[';
9002             $end_delimiter = ']';
9003 0         0 }
9004 0         0 elsif (not $octet{'>'}) {
9005             $delimiter = '<';
9006             $end_delimiter = '>';
9007 0         0 }
9008 0 0       0 else {
9009 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9010 0         0 if (not $octet{$char}) {
9011 0         0 $delimiter = $char;
9012             $end_delimiter = $char;
9013             last;
9014             }
9015             }
9016             }
9017 0 100 100     0 }
9018 240         1221  
9019             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9020             return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9021 90         534 }
9022             else {
9023             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9024             }
9025 150 100       933 }
9026 1587         4130  
9027             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9028             my $metachar = qr/[\@\\|[\]{^]/oxms;
9029 1587         5991  
9030             # split regexp
9031             my @char = $string =~ /\G((?>
9032             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9033             \\x (?>[0-9A-Fa-f]{1,2}) |
9034             \\ (?>[0-7]{2,3}) |
9035             \\c [\x40-\x5F] |
9036             \\x\{ (?>[0-9A-Fa-f]+) \} |
9037             \\o\{ (?>[0-7]+) \} |
9038             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9039             \\ $q_char |
9040             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9041             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9042             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9043             [\$\@] $qq_variable |
9044             \$ (?>\s* [0-9]+) |
9045             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9046             \$ \$ (?![\w\{]) |
9047             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9048             \[\^ |
9049             \[\: (?>[a-z]+) :\] |
9050             \[\:\^ (?>[a-z]+) :\] |
9051             \(\? |
9052             $q_char
9053             ))/oxmsg;
9054 1587 50       142678  
9055 1587         8761 # choice again delimiter
  0         0  
9056 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9057 0         0 my %octet = map {$_ => 1} @char;
9058 0         0 if (not $octet{')'}) {
9059             $delimiter = '(';
9060             $end_delimiter = ')';
9061 0         0 }
9062 0         0 elsif (not $octet{'}'}) {
9063             $delimiter = '{';
9064             $end_delimiter = '}';
9065 0         0 }
9066 0         0 elsif (not $octet{']'}) {
9067             $delimiter = '[';
9068             $end_delimiter = ']';
9069 0         0 }
9070 0         0 elsif (not $octet{'>'}) {
9071             $delimiter = '<';
9072             $end_delimiter = '>';
9073 0         0 }
9074 0 0       0 else {
9075 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9076 0         0 if (not $octet{$char}) {
9077 0         0 $delimiter = $char;
9078             $end_delimiter = $char;
9079             last;
9080             }
9081             }
9082             }
9083 0         0 }
9084 1587         2636  
9085 1587         2168 my $left_e = 0;
9086             my $right_e = 0;
9087             for (my $i=0; $i <= $#char; $i++) {
9088 1587 50 66     4351  
    50 66        
    100          
    100          
    100          
    100          
9089 5514         27800 # "\L\u" --> "\u\L"
9090             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9091             @char[$i,$i+1] = @char[$i+1,$i];
9092             }
9093              
9094 0         0 # "\U\l" --> "\l\U"
9095             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9096             @char[$i,$i+1] = @char[$i+1,$i];
9097             }
9098              
9099 0         0 # octal escape sequence
9100             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9101             $char[$i] = Euhc::octchr($1);
9102             }
9103              
9104 1         5 # hexadecimal escape sequence
9105             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9106             $char[$i] = Euhc::hexchr($1);
9107             }
9108              
9109             # \b{...} --> b\{...}
9110             # \B{...} --> B\{...}
9111             # \N{CHARNAME} --> N\{CHARNAME}
9112             # \p{PROPERTY} --> p\{PROPERTY}
9113 1         4 # \P{PROPERTY} --> P\{PROPERTY}
9114             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9115             $char[$i] = $1 . '\\' . $2;
9116             }
9117              
9118 6         17 # \p, \P, \X --> p, P, X
9119             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9120             $char[$i] = $1;
9121 4 100 100     13 }
    100 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          
9122              
9123             if (0) {
9124             }
9125 5514         38377  
9126 0         0 # escape last octet of multiple-octet
9127             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9128             $char[$i] = $1 . '\\' . $2;
9129             }
9130              
9131 77 50 33     318 # join separated multiple-octet
    50 33        
    50 33        
      33        
      66        
      33        
9132 6         199 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9133             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)) {
9134             $char[$i] .= join '', splice @char, $i+1, 3;
9135 0         0 }
9136             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)) {
9137             $char[$i] .= join '', splice @char, $i+1, 2;
9138 0         0 }
9139             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)) {
9140             $char[$i] .= join '', splice @char, $i+1, 1;
9141             }
9142             }
9143              
9144 0         0 # open character class [...]
9145             elsif ($char[$i] eq '[') {
9146             my $left = $i;
9147              
9148             # [] make die "Unmatched [] in regexp ...\n"
9149 586 100       1015 # (and so on)
9150 586         1572  
9151             if ($char[$i+1] eq ']') {
9152             $i++;
9153 3         5 }
9154 586 50       826  
9155 2583         4008 while (1) {
9156             if (++$i > $#char) {
9157 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9158 2583         4293 }
9159             if ($char[$i] eq ']') {
9160             my $right = $i;
9161 586 100       773  
9162 586         3459 # [...]
  90         226  
9163             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9164             splice @char, $left, $right-$left+1, sprintf(q{@{[Euhc::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9165 270         525 }
9166             else {
9167             splice @char, $left, $right-$left+1, Euhc::charlist_qr(@char[$left+1..$right-1], $modifier);
9168 496         2308 }
9169 586         1154  
9170             $i = $left;
9171             last;
9172             }
9173             }
9174             }
9175              
9176 586         2014 # open character class [^...]
9177             elsif ($char[$i] eq '[^') {
9178             my $left = $i;
9179              
9180             # [^] make die "Unmatched [] in regexp ...\n"
9181 328 100       521 # (and so on)
9182 328         776  
9183             if ($char[$i+1] eq ']') {
9184             $i++;
9185 5         8 }
9186 328 50       476  
9187 1447         2089 while (1) {
9188             if (++$i > $#char) {
9189 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9190 1447         2172 }
9191             if ($char[$i] eq ']') {
9192             my $right = $i;
9193 328 100       401  
9194 328         2176 # [^...]
  90         218  
9195             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9196             splice @char, $left, $right-$left+1, sprintf(q{@{[Euhc::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9197 270         471 }
9198             else {
9199             splice @char, $left, $right-$left+1, Euhc::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9200 238         805 }
9201 328         619  
9202             $i = $left;
9203             last;
9204             }
9205             }
9206             }
9207              
9208 328         931 # rewrite character class or escape character
9209             elsif (my $char = character_class($char[$i],$modifier)) {
9210             $char[$i] = $char;
9211             }
9212              
9213 215 50       606 # /i modifier
9214 238         477 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Euhc::uc($char[$i]) ne Euhc::fc($char[$i]))) {
9215             if (CORE::length(Euhc::fc($char[$i])) == 1) {
9216             $char[$i] = '[' . Euhc::uc($char[$i]) . Euhc::fc($char[$i]) . ']';
9217 238         478 }
9218             else {
9219             $char[$i] = '(?:' . Euhc::uc($char[$i]) . '|' . Euhc::fc($char[$i]) . ')';
9220             }
9221             }
9222              
9223 0 50       0 # \u \l \U \L \F \Q \E
9224 1         5 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9225             if ($right_e < $left_e) {
9226             $char[$i] = '\\' . $char[$i];
9227             }
9228 0         0 }
9229 0         0 elsif ($char[$i] eq '\u') {
9230             $char[$i] = '@{[Euhc::ucfirst qq<';
9231             $left_e++;
9232 0         0 }
9233 0         0 elsif ($char[$i] eq '\l') {
9234             $char[$i] = '@{[Euhc::lcfirst qq<';
9235             $left_e++;
9236 0         0 }
9237 1         3 elsif ($char[$i] eq '\U') {
9238             $char[$i] = '@{[Euhc::uc qq<';
9239             $left_e++;
9240 1         5 }
9241 1         3 elsif ($char[$i] eq '\L') {
9242             $char[$i] = '@{[Euhc::lc qq<';
9243             $left_e++;
9244 1         5 }
9245 9         13 elsif ($char[$i] eq '\F') {
9246             $char[$i] = '@{[Euhc::fc qq<';
9247             $left_e++;
9248 9         20 }
9249 22         46 elsif ($char[$i] eq '\Q') {
9250             $char[$i] = '@{[CORE::quotemeta qq<';
9251             $left_e++;
9252 22 50       57 }
9253 33         79 elsif ($char[$i] eq '\E') {
9254 33         53 if ($right_e < $left_e) {
9255             $char[$i] = '>]}';
9256             $right_e++;
9257 33         79 }
9258             else {
9259             $char[$i] = '';
9260             }
9261 0         0 }
9262 0 0       0 elsif ($char[$i] eq '\Q') {
9263 0         0 while (1) {
9264             if (++$i > $#char) {
9265 0 0       0 last;
9266 0         0 }
9267             if ($char[$i] eq '\E') {
9268             last;
9269             }
9270             }
9271             }
9272             elsif ($char[$i] eq '\E') {
9273             }
9274              
9275 0 0       0 # $0 --> $0
9276 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9277             if ($ignorecase) {
9278             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9279             }
9280 0 0       0 }
9281 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9282             if ($ignorecase) {
9283             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9284             }
9285             }
9286              
9287             # $$ --> $$
9288             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9289             }
9290              
9291             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9292 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9293 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9294 0         0 $char[$i] = e_capture($1);
9295             if ($ignorecase) {
9296             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9297             }
9298 0         0 }
9299 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9300 0         0 $char[$i] = e_capture($1);
9301             if ($ignorecase) {
9302             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9303             }
9304             }
9305              
9306 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
9307 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) {
9308 0         0 $char[$i] = e_capture($1.'->'.$2);
9309             if ($ignorecase) {
9310             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9311             }
9312             }
9313              
9314 0         0 # $$foo{ ... } --> $ $foo->{ ... }
9315 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) {
9316 0         0 $char[$i] = e_capture($1.'->'.$2);
9317             if ($ignorecase) {
9318             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9319             }
9320             }
9321              
9322 0         0 # $$foo
9323 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9324 0         0 $char[$i] = e_capture($1);
9325             if ($ignorecase) {
9326             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9327             }
9328             }
9329              
9330 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Euhc::PREMATCH()
9331 8         31 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9332             if ($ignorecase) {
9333             $char[$i] = '@{[Euhc::ignorecase(Euhc::PREMATCH())]}';
9334 0         0 }
9335             else {
9336             $char[$i] = '@{[Euhc::PREMATCH()]}';
9337             }
9338             }
9339              
9340 8 50       31 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Euhc::MATCH()
9341 8         24 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9342             if ($ignorecase) {
9343             $char[$i] = '@{[Euhc::ignorecase(Euhc::MATCH())]}';
9344 0         0 }
9345             else {
9346             $char[$i] = '@{[Euhc::MATCH()]}';
9347             }
9348             }
9349              
9350 8 50       32 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Euhc::POSTMATCH()
9351 6         19 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9352             if ($ignorecase) {
9353             $char[$i] = '@{[Euhc::ignorecase(Euhc::POSTMATCH())]}';
9354 0         0 }
9355             else {
9356             $char[$i] = '@{[Euhc::POSTMATCH()]}';
9357             }
9358             }
9359              
9360 6 0       23 # ${ foo }
9361 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) {
9362             if ($ignorecase) {
9363             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9364             }
9365             }
9366              
9367 0         0 # ${ ... }
9368 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9369 0         0 $char[$i] = e_capture($1);
9370             if ($ignorecase) {
9371             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9372             }
9373             }
9374              
9375 0         0 # $scalar or @array
9376 31 100       136 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9377 31         114 $char[$i] = e_string($char[$i]);
9378             if ($ignorecase) {
9379             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9380             }
9381             }
9382              
9383 4 100 66     14 # quote character before ? + * {
    50          
9384             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9385             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9386 188         1619 }
9387 0 0       0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9388 0         0 my $char = $char[$i-1];
9389             if ($char[$i] eq '{') {
9390             die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9391 0         0 }
9392             else {
9393             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9394             }
9395 0         0 }
9396             else {
9397             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9398             }
9399             }
9400             }
9401 187         887  
9402 1587 50       3080 # make regexp string
9403 1587 0 0     3671 $modifier =~ tr/i//d;
9404 0         0 if ($left_e > $right_e) {
9405             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9406             return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9407 0         0 }
9408             else {
9409             return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9410 0 100 100     0 }
9411 1587         8436 }
9412             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9413             return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9414 94         759 }
9415             else {
9416             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9417             }
9418             }
9419              
9420             #
9421             # double quote stuff
9422 1493     540 0 13333 #
9423             sub qq_stuff {
9424             my($delimiter,$end_delimiter,$stuff) = @_;
9425 540 100       1116  
9426 540         1368 # scalar variable or array variable
9427             if ($stuff =~ /\A [\$\@] /oxms) {
9428             return $stuff;
9429             }
9430 300         1131  
  240         711  
9431 280         808 # quote by delimiter
9432 240 50       639 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9433 240 50       444 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9434 240 50       400 next if $char eq $delimiter;
9435 240         439 next if $char eq $end_delimiter;
9436             if (not $octet{$char}) {
9437             return join '', 'qq', $char, $stuff, $char;
9438 240         1014 }
9439             }
9440             return join '', 'qq', '<', $stuff, '>';
9441             }
9442              
9443             #
9444             # escape regexp (m'', qr'', and m''b, qr''b)
9445 0     163 0 0 #
9446 163   100     1176 sub e_qr_q {
9447             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9448 163         630 $modifier ||= '';
9449 163 50       408  
9450 163         552 $modifier =~ tr/p//d;
9451 0         0 if ($modifier =~ /([adlu])/oxms) {
9452 0 0       0 my $line = 0;
9453 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9454 0         0 if ($filename ne __FILE__) {
9455             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9456             last;
9457 0         0 }
9458             }
9459             die qq{Unsupported modifier "$1" used at line $line.\n};
9460 0         0 }
9461              
9462             $slash = 'div';
9463 163 100       333  
    100          
9464 163         636 # literal null string pattern
9465 8         17 if ($string eq '') {
9466 8         12 $modifier =~ tr/bB//d;
9467             $modifier =~ tr/i//d;
9468             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9469             }
9470              
9471 8         45 # with /b /B modifier
9472             elsif ($modifier =~ tr/bB//d) {
9473             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9474             }
9475              
9476 89         299 # without /b /B modifier
9477             else {
9478             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9479             }
9480             }
9481              
9482             #
9483             # escape regexp (m'', qr'')
9484 66     66 0 235 #
9485             sub e_qr_qt {
9486 66 100       213 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9487              
9488             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9489 66         351  
9490             # split regexp
9491             my @char = $string =~ /\G((?>
9492             [^\x81-\xFE\\\[\$\@\/] |
9493             [\x81-\xFE][\x00-\xFF] |
9494             \[\^ |
9495             \[\: (?>[a-z]+) \:\] |
9496             \[\:\^ (?>[a-z]+) \:\] |
9497             [\$\@\/] |
9498             \\ (?:$q_char) |
9499             (?:$q_char)
9500             ))/oxmsg;
9501 66         1025  
9502 66 100 100     278 # unescape character
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9503             for (my $i=0; $i <= $#char; $i++) {
9504             if (0) {
9505             }
9506 79         1727  
9507 0         0 # escape last octet of multiple-octet
9508             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9509             $char[$i] = $1 . '\\' . $2;
9510             }
9511              
9512 2         14 # open character class [...]
9513 0 0       0 elsif ($char[$i] eq '[') {
9514 0         0 my $left = $i;
9515             if ($char[$i+1] eq ']') {
9516 0         0 $i++;
9517 0 0       0 }
9518 0         0 while (1) {
9519             if (++$i > $#char) {
9520 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9521 0         0 }
9522             if ($char[$i] eq ']') {
9523             my $right = $i;
9524 0         0  
9525             # [...]
9526 0         0 splice @char, $left, $right-$left+1, Euhc::charlist_qr(@char[$left+1..$right-1], $modifier);
9527 0         0  
9528             $i = $left;
9529             last;
9530             }
9531             }
9532             }
9533              
9534 0         0 # open character class [^...]
9535 0 0       0 elsif ($char[$i] eq '[^') {
9536 0         0 my $left = $i;
9537             if ($char[$i+1] eq ']') {
9538 0         0 $i++;
9539 0 0       0 }
9540 0         0 while (1) {
9541             if (++$i > $#char) {
9542 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9543 0         0 }
9544             if ($char[$i] eq ']') {
9545             my $right = $i;
9546 0         0  
9547             # [^...]
9548 0         0 splice @char, $left, $right-$left+1, Euhc::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9549 0         0  
9550             $i = $left;
9551             last;
9552             }
9553             }
9554             }
9555              
9556 0         0 # escape $ @ / and \
9557             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9558             $char[$i] = '\\' . $char[$i];
9559             }
9560              
9561 0         0 # rewrite character class or escape character
9562             elsif (my $char = character_class($char[$i],$modifier)) {
9563             $char[$i] = $char;
9564             }
9565              
9566 0 50       0 # /i modifier
9567 16         58 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Euhc::uc($char[$i]) ne Euhc::fc($char[$i]))) {
9568             if (CORE::length(Euhc::fc($char[$i])) == 1) {
9569             $char[$i] = '[' . Euhc::uc($char[$i]) . Euhc::fc($char[$i]) . ']';
9570 16         49 }
9571             else {
9572             $char[$i] = '(?:' . Euhc::uc($char[$i]) . '|' . Euhc::fc($char[$i]) . ')';
9573             }
9574             }
9575              
9576 0 0       0 # quote character before ? + * {
9577             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9578             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9579 0         0 }
9580             else {
9581             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9582             }
9583             }
9584 0         0 }
9585 66         156  
9586             $delimiter = '/';
9587 66         97 $end_delimiter = '/';
9588 66         124  
9589             $modifier =~ tr/i//d;
9590             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9591             }
9592              
9593             #
9594             # escape regexp (m''b, qr''b)
9595 66     89 0 506 #
9596             sub e_qr_qb {
9597             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9598 89         265  
9599             # split regexp
9600             my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9601 89         447  
9602 89 50       330 # unescape character
    50          
9603             for (my $i=0; $i <= $#char; $i++) {
9604             if (0) {
9605             }
9606 199         751  
9607             # remain \\
9608             elsif ($char[$i] eq '\\\\') {
9609             }
9610              
9611 0         0 # escape $ @ / and \
9612             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9613             $char[$i] = '\\' . $char[$i];
9614             }
9615 0         0 }
9616 89         158  
9617 89         149 $delimiter = '/';
9618             $end_delimiter = '/';
9619             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9620             }
9621              
9622             #
9623             # escape regexp (s/here//)
9624 89     194 0 641 #
9625 194   100     534 sub e_s1 {
9626             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9627 194         723 $modifier ||= '';
9628 194 50       359  
9629 194         699 $modifier =~ tr/p//d;
9630 0         0 if ($modifier =~ /([adlu])/oxms) {
9631 0 0       0 my $line = 0;
9632 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9633 0         0 if ($filename ne __FILE__) {
9634             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9635             last;
9636 0         0 }
9637             }
9638             die qq{Unsupported modifier "$1" used at line $line.\n};
9639 0         0 }
9640              
9641             $slash = 'div';
9642 194 100       348  
    100          
9643 194         720 # literal null string pattern
9644 8         9 if ($string eq '') {
9645 8         14 $modifier =~ tr/bB//d;
9646             $modifier =~ tr/i//d;
9647             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9648             }
9649              
9650             # /b /B modifier
9651             elsif ($modifier =~ tr/bB//d) {
9652 8 50       59  
9653 44         90 # choice again delimiter
9654 0         0 if ($delimiter =~ / [\@:] /oxms) {
  0         0  
9655 0 0       0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
    0          
    0          
    0          
9656 0         0 my %octet = map {$_ => 1} @char;
9657 0         0 if (not $octet{')'}) {
9658             $delimiter = '(';
9659             $end_delimiter = ')';
9660 0         0 }
9661 0         0 elsif (not $octet{'}'}) {
9662             $delimiter = '{';
9663             $end_delimiter = '}';
9664 0         0 }
9665 0         0 elsif (not $octet{']'}) {
9666             $delimiter = '[';
9667             $end_delimiter = ']';
9668 0         0 }
9669 0         0 elsif (not $octet{'>'}) {
9670             $delimiter = '<';
9671             $end_delimiter = '>';
9672 0         0 }
9673 0 0       0 else {
9674 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9675 0         0 if (not $octet{$char}) {
9676 0         0 $delimiter = $char;
9677             $end_delimiter = $char;
9678             last;
9679             }
9680             }
9681             }
9682 0         0 }
9683 44         53  
9684 44         66 my $prematch = '';
9685             $prematch = q{(\G[\x00-\xFF]*?)};
9686             return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9687 44 100       280 }
9688 142         445  
9689             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9690             my $metachar = qr/[\@\\|[\]{^]/oxms;
9691 142         582  
9692             # split regexp
9693             my @char = $string =~ /\G((?>
9694             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
9695             \\ (?>[1-9][0-9]*) |
9696             \\g (?>\s*) (?>[1-9][0-9]*) |
9697             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9698             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
9699             \\x (?>[0-9A-Fa-f]{1,2}) |
9700             \\ (?>[0-7]{2,3}) |
9701             \\c [\x40-\x5F] |
9702             \\x\{ (?>[0-9A-Fa-f]+) \} |
9703             \\o\{ (?>[0-7]+) \} |
9704             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
9705             \\ $q_char |
9706             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9707             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9708             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9709             [\$\@] $qq_variable |
9710             \$ (?>\s* [0-9]+) |
9711             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9712             \$ \$ (?![\w\{]) |
9713             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9714             \[\^ |
9715             \[\: (?>[a-z]+) :\] |
9716             \[\:\^ (?>[a-z]+) :\] |
9717             \(\? |
9718             $q_char
9719             ))/oxmsg;
9720 142 50       38343  
9721 142         1132 # choice again delimiter
  0         0  
9722 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9723 0         0 my %octet = map {$_ => 1} @char;
9724 0         0 if (not $octet{')'}) {
9725             $delimiter = '(';
9726             $end_delimiter = ')';
9727 0         0 }
9728 0         0 elsif (not $octet{'}'}) {
9729             $delimiter = '{';
9730             $end_delimiter = '}';
9731 0         0 }
9732 0         0 elsif (not $octet{']'}) {
9733             $delimiter = '[';
9734             $end_delimiter = ']';
9735 0         0 }
9736 0         0 elsif (not $octet{'>'}) {
9737             $delimiter = '<';
9738             $end_delimiter = '>';
9739 0         0 }
9740 0 0       0 else {
9741 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9742 0         0 if (not $octet{$char}) {
9743 0         0 $delimiter = $char;
9744             $end_delimiter = $char;
9745             last;
9746             }
9747             }
9748             }
9749             }
9750 0         0  
  142         339  
9751             # count '('
9752 476         901 my $parens = grep { $_ eq '(' } @char;
9753 142         225  
9754 142         229 my $left_e = 0;
9755             my $right_e = 0;
9756             for (my $i=0; $i <= $#char; $i++) {
9757 142 50 33     420  
    50 33        
    100          
    100          
    50          
    50          
9758 397         2673 # "\L\u" --> "\u\L"
9759             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9760             @char[$i,$i+1] = @char[$i+1,$i];
9761             }
9762              
9763 0         0 # "\U\l" --> "\l\U"
9764             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9765             @char[$i,$i+1] = @char[$i+1,$i];
9766             }
9767              
9768 0         0 # octal escape sequence
9769             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9770             $char[$i] = Euhc::octchr($1);
9771             }
9772              
9773 1         4 # hexadecimal escape sequence
9774             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9775             $char[$i] = Euhc::hexchr($1);
9776             }
9777              
9778             # \b{...} --> b\{...}
9779             # \B{...} --> B\{...}
9780             # \N{CHARNAME} --> N\{CHARNAME}
9781             # \p{PROPERTY} --> p\{PROPERTY}
9782 1         3 # \P{PROPERTY} --> P\{PROPERTY}
9783             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
9784             $char[$i] = $1 . '\\' . $2;
9785             }
9786              
9787 0         0 # \p, \P, \X --> p, P, X
9788             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9789             $char[$i] = $1;
9790 0 100 100     0 }
    50 100        
    100 100        
    50          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
9791              
9792             if (0) {
9793             }
9794 397         4654  
9795 0         0 # escape last octet of multiple-octet
9796             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9797             $char[$i] = $1 . '\\' . $2;
9798             }
9799              
9800 23 0 0     165 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
9801 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9802             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)) {
9803             $char[$i] .= join '', splice @char, $i+1, 3;
9804 0         0 }
9805             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)) {
9806             $char[$i] .= join '', splice @char, $i+1, 2;
9807 0         0 }
9808             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)) {
9809             $char[$i] .= join '', splice @char, $i+1, 1;
9810             }
9811             }
9812              
9813 0         0 # open character class [...]
9814 20 50       41 elsif ($char[$i] eq '[') {
9815 20         68 my $left = $i;
9816             if ($char[$i+1] eq ']') {
9817 0         0 $i++;
9818 20 50       31 }
9819 79         133 while (1) {
9820             if (++$i > $#char) {
9821 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
9822 79         219 }
9823             if ($char[$i] eq ']') {
9824             my $right = $i;
9825 20 50       43  
9826 20         150 # [...]
  0         0  
9827             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9828             splice @char, $left, $right-$left+1, sprintf(q{@{[Euhc::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9829 0         0 }
9830             else {
9831             splice @char, $left, $right-$left+1, Euhc::charlist_qr(@char[$left+1..$right-1], $modifier);
9832 20         175 }
9833 20         45  
9834             $i = $left;
9835             last;
9836             }
9837             }
9838             }
9839              
9840 20         65 # open character class [^...]
9841 0 0       0 elsif ($char[$i] eq '[^') {
9842 0         0 my $left = $i;
9843             if ($char[$i+1] eq ']') {
9844 0         0 $i++;
9845 0 0       0 }
9846 0         0 while (1) {
9847             if (++$i > $#char) {
9848 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
9849 0         0 }
9850             if ($char[$i] eq ']') {
9851             my $right = $i;
9852 0 0       0  
9853 0         0 # [^...]
  0         0  
9854             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9855             splice @char, $left, $right-$left+1, sprintf(q{@{[Euhc::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9856 0         0 }
9857             else {
9858             splice @char, $left, $right-$left+1, Euhc::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9859 0         0 }
9860 0         0  
9861             $i = $left;
9862             last;
9863             }
9864             }
9865             }
9866              
9867 0         0 # rewrite character class or escape character
9868             elsif (my $char = character_class($char[$i],$modifier)) {
9869             $char[$i] = $char;
9870             }
9871              
9872 11 50       29 # /i modifier
9873 11         24 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Euhc::uc($char[$i]) ne Euhc::fc($char[$i]))) {
9874             if (CORE::length(Euhc::fc($char[$i])) == 1) {
9875             $char[$i] = '[' . Euhc::uc($char[$i]) . Euhc::fc($char[$i]) . ']';
9876 11         25 }
9877             else {
9878             $char[$i] = '(?:' . Euhc::uc($char[$i]) . '|' . Euhc::fc($char[$i]) . ')';
9879             }
9880             }
9881              
9882 0 50       0 # \u \l \U \L \F \Q \E
9883 8         31 elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9884             if ($right_e < $left_e) {
9885             $char[$i] = '\\' . $char[$i];
9886             }
9887 0         0 }
9888 0         0 elsif ($char[$i] eq '\u') {
9889             $char[$i] = '@{[Euhc::ucfirst qq<';
9890             $left_e++;
9891 0         0 }
9892 0         0 elsif ($char[$i] eq '\l') {
9893             $char[$i] = '@{[Euhc::lcfirst qq<';
9894             $left_e++;
9895 0         0 }
9896 0         0 elsif ($char[$i] eq '\U') {
9897             $char[$i] = '@{[Euhc::uc qq<';
9898             $left_e++;
9899 0         0 }
9900 0         0 elsif ($char[$i] eq '\L') {
9901             $char[$i] = '@{[Euhc::lc qq<';
9902             $left_e++;
9903 0         0 }
9904 0         0 elsif ($char[$i] eq '\F') {
9905             $char[$i] = '@{[Euhc::fc qq<';
9906             $left_e++;
9907 0         0 }
9908 7         12 elsif ($char[$i] eq '\Q') {
9909             $char[$i] = '@{[CORE::quotemeta qq<';
9910             $left_e++;
9911 7 50       16 }
9912 7         14 elsif ($char[$i] eq '\E') {
9913 7         10 if ($right_e < $left_e) {
9914             $char[$i] = '>]}';
9915             $right_e++;
9916 7         46 }
9917             else {
9918             $char[$i] = '';
9919             }
9920 0         0 }
9921 0 0       0 elsif ($char[$i] eq '\Q') {
9922 0         0 while (1) {
9923             if (++$i > $#char) {
9924 0 0       0 last;
9925 0         0 }
9926             if ($char[$i] eq '\E') {
9927             last;
9928             }
9929             }
9930             }
9931             elsif ($char[$i] eq '\E') {
9932             }
9933              
9934             # \0 --> \0
9935             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
9936             }
9937              
9938             # \g{N}, \g{-N}
9939              
9940             # P.108 Using Simple Patterns
9941             # in Chapter 7: In the World of Regular Expressions
9942             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
9943              
9944             # P.221 Capturing
9945             # in Chapter 5: Pattern Matching
9946             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
9947              
9948             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
9949             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9950             }
9951              
9952 0 0       0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
9953 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9954             if ($1 <= $parens) {
9955             $char[$i] = '\\g{' . ($1 + 1) . '}';
9956             }
9957             }
9958              
9959 0 0       0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
9960 0         0 elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9961             if ($1 <= $parens) {
9962             $char[$i] = '\\g' . ($1 + 1);
9963             }
9964             }
9965              
9966 0 0       0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
9967 0         0 elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
9968             if ($1 <= $parens) {
9969             $char[$i] = '\\' . ($1 + 1);
9970             }
9971             }
9972              
9973 0 0       0 # $0 --> $0
9974 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9975             if ($ignorecase) {
9976             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9977             }
9978 0 0       0 }
9979 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9980             if ($ignorecase) {
9981             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9982             }
9983             }
9984              
9985             # $$ --> $$
9986             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9987             }
9988              
9989             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9990 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
9991 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9992 0         0 $char[$i] = e_capture($1);
9993             if ($ignorecase) {
9994             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
9995             }
9996 0         0 }
9997 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9998 0         0 $char[$i] = e_capture($1);
9999             if ($ignorecase) {
10000             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10001             }
10002             }
10003              
10004 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10005 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) {
10006 0         0 $char[$i] = e_capture($1.'->'.$2);
10007             if ($ignorecase) {
10008             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10009             }
10010             }
10011              
10012 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10013 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) {
10014 0         0 $char[$i] = e_capture($1.'->'.$2);
10015             if ($ignorecase) {
10016             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10017             }
10018             }
10019              
10020 0         0 # $$foo
10021 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10022 0         0 $char[$i] = e_capture($1);
10023             if ($ignorecase) {
10024             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10025             }
10026             }
10027              
10028 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Euhc::PREMATCH()
10029 4         19 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10030             if ($ignorecase) {
10031             $char[$i] = '@{[Euhc::ignorecase(Euhc::PREMATCH())]}';
10032 0         0 }
10033             else {
10034             $char[$i] = '@{[Euhc::PREMATCH()]}';
10035             }
10036             }
10037              
10038 4 50       20 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Euhc::MATCH()
10039 4         21 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10040             if ($ignorecase) {
10041             $char[$i] = '@{[Euhc::ignorecase(Euhc::MATCH())]}';
10042 0         0 }
10043             else {
10044             $char[$i] = '@{[Euhc::MATCH()]}';
10045             }
10046             }
10047              
10048 4 50       20 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Euhc::POSTMATCH()
10049 3         15 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10050             if ($ignorecase) {
10051             $char[$i] = '@{[Euhc::ignorecase(Euhc::POSTMATCH())]}';
10052 0         0 }
10053             else {
10054             $char[$i] = '@{[Euhc::POSTMATCH()]}';
10055             }
10056             }
10057              
10058 3 0       15 # ${ foo }
10059 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) {
10060             if ($ignorecase) {
10061             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10062             }
10063             }
10064              
10065 0         0 # ${ ... }
10066 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10067 0         0 $char[$i] = e_capture($1);
10068             if ($ignorecase) {
10069             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10070             }
10071             }
10072              
10073 0         0 # $scalar or @array
10074 13 50       53 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10075 13         58 $char[$i] = e_string($char[$i]);
10076             if ($ignorecase) {
10077             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10078             }
10079             }
10080              
10081 0 50       0 # quote character before ? + * {
10082             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10083             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10084 23         128 }
10085             else {
10086             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10087             }
10088             }
10089             }
10090 23         119  
10091 142         346 # make regexp string
10092 142         356 my $prematch = '';
10093 142 50       243 $prematch = "($anchor)";
10094 142         379 $modifier =~ tr/i//d;
10095             if ($left_e > $right_e) {
10096 0         0 return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10097             }
10098             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10099             }
10100              
10101             #
10102             # escape regexp (s'here'' or s'here''b)
10103 142     96 0 1666 #
10104 96   100     210 sub e_s1_q {
10105             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10106 96         234 $modifier ||= '';
10107 96 50       130  
10108 96         292 $modifier =~ tr/p//d;
10109 0         0 if ($modifier =~ /([adlu])/oxms) {
10110 0 0       0 my $line = 0;
10111 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10112 0         0 if ($filename ne __FILE__) {
10113             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10114             last;
10115 0         0 }
10116             }
10117             die qq{Unsupported modifier "$1" used at line $line.\n};
10118 0         0 }
10119              
10120             $slash = 'div';
10121 96 100       160  
    100          
10122 96         211 # literal null string pattern
10123 8         13 if ($string eq '') {
10124 8         10 $modifier =~ tr/bB//d;
10125             $modifier =~ tr/i//d;
10126             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10127             }
10128              
10129 8         63 # with /b /B modifier
10130             elsif ($modifier =~ tr/bB//d) {
10131             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10132             }
10133              
10134 44         91 # without /b /B modifier
10135             else {
10136             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10137             }
10138             }
10139              
10140             #
10141             # escape regexp (s'here'')
10142 44     44 0 109 #
10143             sub e_s1_qt {
10144 44 100       98 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10145              
10146             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10147 44         100  
10148             # split regexp
10149             my @char = $string =~ /\G((?>
10150             [^\x81-\xFE\\\[\$\@\/] |
10151             [\x81-\xFE][\x00-\xFF] |
10152             \[\^ |
10153             \[\: (?>[a-z]+) \:\] |
10154             \[\:\^ (?>[a-z]+) \:\] |
10155             [\$\@\/] |
10156             \\ (?:$q_char) |
10157             (?:$q_char)
10158             ))/oxmsg;
10159 44         515  
10160 44 50 100     139 # unescape character
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10161             for (my $i=0; $i <= $#char; $i++) {
10162             if (0) {
10163             }
10164 62         572  
10165 0         0 # escape last octet of multiple-octet
10166             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10167             $char[$i] = $1 . '\\' . $2;
10168             }
10169              
10170 0         0 # open character class [...]
10171 0 0       0 elsif ($char[$i] eq '[') {
10172 0         0 my $left = $i;
10173             if ($char[$i+1] eq ']') {
10174 0         0 $i++;
10175 0 0       0 }
10176 0         0 while (1) {
10177             if (++$i > $#char) {
10178 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10179 0         0 }
10180             if ($char[$i] eq ']') {
10181             my $right = $i;
10182 0         0  
10183             # [...]
10184 0         0 splice @char, $left, $right-$left+1, Euhc::charlist_qr(@char[$left+1..$right-1], $modifier);
10185 0         0  
10186             $i = $left;
10187             last;
10188             }
10189             }
10190             }
10191              
10192 0         0 # open character class [^...]
10193 0 0       0 elsif ($char[$i] eq '[^') {
10194 0         0 my $left = $i;
10195             if ($char[$i+1] eq ']') {
10196 0         0 $i++;
10197 0 0       0 }
10198 0         0 while (1) {
10199             if (++$i > $#char) {
10200 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
10201 0         0 }
10202             if ($char[$i] eq ']') {
10203             my $right = $i;
10204 0         0  
10205             # [^...]
10206 0         0 splice @char, $left, $right-$left+1, Euhc::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10207 0         0  
10208             $i = $left;
10209             last;
10210             }
10211             }
10212             }
10213              
10214 0         0 # escape $ @ / and \
10215             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10216             $char[$i] = '\\' . $char[$i];
10217             }
10218              
10219 0         0 # rewrite character class or escape character
10220             elsif (my $char = character_class($char[$i],$modifier)) {
10221             $char[$i] = $char;
10222             }
10223              
10224 6 50       13 # /i modifier
10225 8         18 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Euhc::uc($char[$i]) ne Euhc::fc($char[$i]))) {
10226             if (CORE::length(Euhc::fc($char[$i])) == 1) {
10227             $char[$i] = '[' . Euhc::uc($char[$i]) . Euhc::fc($char[$i]) . ']';
10228 8         18 }
10229             else {
10230             $char[$i] = '(?:' . Euhc::uc($char[$i]) . '|' . Euhc::fc($char[$i]) . ')';
10231             }
10232             }
10233              
10234 0 0       0 # quote character before ? + * {
10235             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10236             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10237 0         0 }
10238             else {
10239             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10240             }
10241             }
10242 0         0 }
10243 44         82  
10244 44         70 $modifier =~ tr/i//d;
10245 44         56 $delimiter = '/';
10246 44         60 $end_delimiter = '/';
10247 44         86 my $prematch = '';
10248             $prematch = "($anchor)";
10249             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10250             }
10251              
10252             #
10253             # escape regexp (s'here''b)
10254 44     44 0 336 #
10255             sub e_s1_qb {
10256             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10257 44         97  
10258             # split regexp
10259             my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10260 44         201  
10261 44 50       123 # unescape character
    50          
10262             for (my $i=0; $i <= $#char; $i++) {
10263             if (0) {
10264             }
10265 98         320  
10266             # remain \\
10267             elsif ($char[$i] eq '\\\\') {
10268             }
10269              
10270 0         0 # escape $ @ / and \
10271             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10272             $char[$i] = '\\' . $char[$i];
10273             }
10274 0         0 }
10275 44         72  
10276 44         54 $delimiter = '/';
10277 44         76 $end_delimiter = '/';
10278 44         62 my $prematch = '';
10279             $prematch = q{(\G[\x00-\xFF]*?)};
10280             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10281             }
10282              
10283             #
10284             # escape regexp (s''here')
10285 44     91 0 311 #
10286             sub e_s2_q {
10287 91         175 my($ope,$delimiter,$end_delimiter,$string) = @_;
10288              
10289 91         127 $slash = 'div';
10290 91         363  
10291 91 50 66     244 my @char = $string =~ / \G (?>[^\x81-\xFE\\]|\\\\|$q_char) /oxmsg;
    50 33        
    100          
    100          
10292             for (my $i=0; $i <= $#char; $i++) {
10293             if (0) {
10294             }
10295 9         102  
10296 0         0 # escape last octet of multiple-octet
10297             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10298             $char[$i] = $1 . '\\' . $2;
10299 0         0 }
10300             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10301             $char[$i] = $1 . '\\' . $2;
10302             }
10303              
10304             # not escape \\
10305             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10306             }
10307              
10308 0         0 # escape $ @ / and \
10309             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10310             $char[$i] = '\\' . $char[$i];
10311 5 50 66     18 }
10312 91         239 }
10313             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10314             $char[-1] = $1 . '\\' . $2;
10315 0         0 }
10316              
10317             return join '', $ope, $delimiter, @char, $end_delimiter;
10318             }
10319              
10320             #
10321             # escape regexp (s/here/and here/modifier)
10322 91     290 0 279 #
10323 290   100     2082 sub e_sub {
10324             my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10325 290         1142 $modifier ||= '';
10326 290 50       600  
10327 290         956 $modifier =~ tr/p//d;
10328 0         0 if ($modifier =~ /([adlu])/oxms) {
10329 0 0       0 my $line = 0;
10330 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10331 0         0 if ($filename ne __FILE__) {
10332             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10333             last;
10334 0         0 }
10335             }
10336             die qq{Unsupported modifier "$1" used at line $line.\n};
10337 0 100       0 }
10338 290         689  
10339 37         61 if ($variable eq '') {
10340             $variable = '$_';
10341             $bind_operator = ' =~ ';
10342 37         53 }
10343              
10344             $slash = 'div';
10345              
10346             # P.128 Start of match (or end of previous match): \G
10347             # P.130 Advanced Use of \G with Perl
10348             # in Chapter 3: Overview of Regular Expression Features and Flavors
10349             # P.312 Iterative Matching: Scalar Context, with /g
10350             # in Chapter 7: Perl
10351             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10352              
10353             # P.181 Where You Left Off: The \G Assertion
10354             # in Chapter 5: Pattern Matching
10355             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10356              
10357             # P.220 Where You Left Off: The \G Assertion
10358             # in Chapter 5: Pattern Matching
10359 290         435 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10360 290         453  
10361             my $e_modifier = $modifier =~ tr/e//d;
10362 290         409 my $r_modifier = $modifier =~ tr/r//d;
10363 290 50       416  
10364 290         686 my $my = '';
10365 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10366 0         0 $my = $variable;
10367             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10368             $variable =~ s/ = .+ \z//oxms;
10369 0         0 }
10370 290         648  
10371             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10372             $variable_basename =~ s/ \s+ \z//oxms;
10373 290         534  
10374 290 100       460 # quote replacement string
10375 290         629 my $e_replacement = '';
10376 17         35 if ($e_modifier >= 1) {
10377             $e_replacement = e_qq('', '', '', $replacement);
10378             $e_modifier--;
10379 17 100       29 }
10380 273         594 else {
10381             if ($delimiter2 eq "'") {
10382             $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10383 91         171 }
10384             else {
10385             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10386             }
10387 182         509 }
10388              
10389             my $sub = '';
10390 290 100       484  
10391 290 100       581 # with /r
    50          
10392             if ($r_modifier) {
10393             if (0) {
10394             }
10395 8         20  
10396 0 50       0 # s///gr with multibyte anchoring
10397             elsif ($modifier =~ /g/oxms) {
10398             $sub = sprintf(
10399             # 1 2 3 4 5
10400             q,
10401              
10402             $variable, # 1
10403             ($delimiter1 eq "'") ? # 2
10404             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10405             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10406             $s_matched, # 3
10407             $e_replacement, # 4
10408             '$Euhc::re_r=CORE::eval $Euhc::re_r; ' x $e_modifier, # 5
10409             );
10410             }
10411              
10412 4 0       15 # s///gr without multibyte anchoring
10413             elsif ($modifier =~ /g/oxms) {
10414             $sub = sprintf(
10415             # 1 2 3 4 5
10416             q,
10417              
10418             $variable, # 1
10419             ($delimiter1 eq "'") ? # 2
10420             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10421             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10422             $s_matched, # 3
10423             $e_replacement, # 4
10424             '$Euhc::re_r=CORE::eval $Euhc::re_r; ' x $e_modifier, # 5
10425             );
10426             }
10427              
10428             # s///r
10429 0         0 else {
10430 4         6  
10431             my $prematch = q{$`};
10432 4 50       6 $prematch = q{${1}};
10433              
10434             $sub = sprintf(
10435             # 1 2 3 4 5 6 7
10436             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Euhc::re_r=%s; %s"%s$Euhc::re_r$'" } : %s>,
10437              
10438             $variable, # 1
10439             ($delimiter1 eq "'") ? # 2
10440             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10441             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10442             $s_matched, # 3
10443             $e_replacement, # 4
10444             '$Euhc::re_r=CORE::eval $Euhc::re_r; ' x $e_modifier, # 5
10445             $prematch, # 6
10446             $variable, # 7
10447             );
10448             }
10449 4 50       14  
10450 8         23 # $var !~ s///r doesn't make sense
10451             if ($bind_operator =~ / !~ /oxms) {
10452             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10453             }
10454             }
10455              
10456 0 100       0 # without /r
    50          
10457             else {
10458             if (0) {
10459             }
10460 282         809  
10461 0 100       0 # s///g with multibyte anchoring
    100          
10462             elsif ($modifier =~ /g/oxms) {
10463             $sub = sprintf(
10464             # 1 2 3 4 5 6 7 8 9 10
10465             q,
10466              
10467             $variable, # 1
10468             ($delimiter1 eq "'") ? # 2
10469             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10470             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10471             $s_matched, # 3
10472             $e_replacement, # 4
10473             '$Euhc::re_r=CORE::eval $Euhc::re_r; ' x $e_modifier, # 5
10474             $variable, # 6
10475             $variable, # 7
10476             $variable, # 8
10477             $variable, # 9
10478              
10479             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10480             # It returns false if the match succeeds, and true if it fails.
10481             # (and so on)
10482              
10483             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10484             );
10485             }
10486              
10487 35 0       166 # s///g without multibyte anchoring
    0          
10488             elsif ($modifier =~ /g/oxms) {
10489             $sub = sprintf(
10490             # 1 2 3 4 5 6 7 8
10491             q,
10492              
10493             $variable, # 1
10494             ($delimiter1 eq "'") ? # 2
10495             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10496             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10497             $s_matched, # 3
10498             $e_replacement, # 4
10499             '$Euhc::re_r=CORE::eval $Euhc::re_r; ' x $e_modifier, # 5
10500             $variable, # 6
10501             $variable, # 7
10502             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10503             );
10504             }
10505              
10506             # s///
10507 0         0 else {
10508 247         460  
10509             my $prematch = q{$`};
10510 247 100       371 $prematch = q{${1}};
    100          
10511              
10512             $sub = sprintf(
10513              
10514             ($bind_operator =~ / =~ /oxms) ?
10515              
10516             # 1 2 3 4 5 6 7 8
10517             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Euhc::re_r=%s; %s%s="%s$Euhc::re_r$'"; 1 } : undef> :
10518              
10519             # 1 2 3 4 5 6 7 8
10520             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Euhc::re_r=%s; %s%s="%s$Euhc::re_r$'"; undef }>,
10521              
10522             $variable, # 1
10523             $bind_operator, # 2
10524             ($delimiter1 eq "'") ? # 3
10525             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10526             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10527             $s_matched, # 4
10528             $e_replacement, # 5
10529             '$Euhc::re_r=CORE::eval $Euhc::re_r; ' x $e_modifier, # 6
10530             $variable, # 7
10531             $prematch, # 8
10532             );
10533             }
10534             }
10535 247 50       1194  
10536 290         795 # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10537             if ($my ne '') {
10538             $sub = "($my, $sub)[1]";
10539             }
10540 0         0  
10541 290         429 # clear s/// variable
10542             $sub_variable = '';
10543 290         407 $bind_operator = '';
10544              
10545             return $sub;
10546             }
10547              
10548             #
10549             # escape chdir (qq//, "")
10550 290     0 0 2153 #
10551             sub e_chdir {
10552 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10553 0 0       0  
10554 0 0       0 if ($^W) {
10555 0         0 if (Euhc::_MSWin32_5Cended_path($string)) {
10556 0         0 if ($] !~ /^5\.005/oxms) {
10557             warn <
10558             @{[__FILE__]}: Can't chdir to '$string'
10559              
10560             chdir does not work with chr(0x5C) at end of path
10561             http://bugs.activestate.com/show_bug.cgi?id=81839
10562             END
10563             }
10564             }
10565 0         0 }
10566              
10567             return e_qq($ope,$delimiter,$end_delimiter,$string);
10568             }
10569              
10570             #
10571             # escape chdir (q//, '')
10572 0     2 0 0 #
10573             sub e_chdir_q {
10574 2 50       6 my($ope,$delimiter,$end_delimiter,$string) = @_;
10575 2 0       15  
10576 0 0       0 if ($^W) {
10577 0         0 if (Euhc::_MSWin32_5Cended_path($string)) {
10578 0         0 if ($] !~ /^5\.005/oxms) {
10579             warn <
10580             @{[__FILE__]}: Can't chdir to '$string'
10581              
10582             chdir does not work with chr(0x5C) at end of path
10583             http://bugs.activestate.com/show_bug.cgi?id=81839
10584             END
10585             }
10586             }
10587 0         0 }
10588              
10589             return e_q($ope,$delimiter,$end_delimiter,$string);
10590             }
10591              
10592             #
10593             # escape regexp of split qr//
10594 2     273 0 18 #
10595 273   100     1464 sub e_split {
10596             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10597 273         1187 $modifier ||= '';
10598 273 50       591  
10599 273         791 $modifier =~ tr/p//d;
10600 0         0 if ($modifier =~ /([adlu])/oxms) {
10601 0 0       0 my $line = 0;
10602 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10603 0         0 if ($filename ne __FILE__) {
10604             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10605             last;
10606 0         0 }
10607             }
10608             die qq{Unsupported modifier "$1" used at line $line.\n};
10609 0         0 }
10610              
10611             $slash = 'div';
10612 273 100       540  
10613 273         690 # /b /B modifier
10614             if ($modifier =~ tr/bB//d) {
10615             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10616 84 100       484 }
10617 189         645  
10618             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10619             my $metachar = qr/[\@\\|[\]{^]/oxms;
10620 189         743  
10621             # split regexp
10622             my @char = $string =~ /\G((?>
10623             [^\x81-\xFE\\\$\@\[\(]|[\x81-\xFE][\x00-\xFF] |
10624             \\x (?>[0-9A-Fa-f]{1,2}) |
10625             \\ (?>[0-7]{2,3}) |
10626             \\c [\x40-\x5F] |
10627             \\x\{ (?>[0-9A-Fa-f]+) \} |
10628             \\o\{ (?>[0-7]+) \} |
10629             \\[bBNpP]\{ (?>[^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} |
10630             \\ $q_char |
10631             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10632             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10633             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10634             [\$\@] $qq_variable |
10635             \$ (?>\s* [0-9]+) |
10636             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10637             \$ \$ (?![\w\{]) |
10638             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10639             \[\^ |
10640             \[\: (?>[a-z]+) :\] |
10641             \[\:\^ (?>[a-z]+) :\] |
10642             \(\? |
10643             $q_char
10644 189         29929 ))/oxmsg;
10645 189         691  
10646 189         321 my $left_e = 0;
10647             my $right_e = 0;
10648             for (my $i=0; $i <= $#char; $i++) {
10649 189 50 33     583  
    50 33        
    100          
    100          
    50          
    50          
10650 372         2721 # "\L\u" --> "\u\L"
10651             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10652             @char[$i,$i+1] = @char[$i+1,$i];
10653             }
10654              
10655 0         0 # "\U\l" --> "\l\U"
10656             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10657             @char[$i,$i+1] = @char[$i+1,$i];
10658             }
10659              
10660 0         0 # octal escape sequence
10661             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10662             $char[$i] = Euhc::octchr($1);
10663             }
10664              
10665 1         5 # hexadecimal escape sequence
10666             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10667             $char[$i] = Euhc::hexchr($1);
10668             }
10669              
10670             # \b{...} --> b\{...}
10671             # \B{...} --> B\{...}
10672             # \N{CHARNAME} --> N\{CHARNAME}
10673             # \p{PROPERTY} --> p\{PROPERTY}
10674 1         3 # \P{PROPERTY} --> P\{PROPERTY}
10675             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
10676             $char[$i] = $1 . '\\' . $2;
10677             }
10678              
10679 0         0 # \p, \P, \X --> p, P, X
10680             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10681             $char[$i] = $1;
10682 0 50 100     0 }
    50 100        
    100 66        
    100 100        
    100          
    100          
    100          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
    100          
    100          
10683              
10684             if (0) {
10685             }
10686 372         3726  
10687 0         0 # escape last octet of multiple-octet
10688             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10689             $char[$i] = $1 . '\\' . $2;
10690             }
10691              
10692 0 0 0     0 # join separated multiple-octet
    0 0        
    0 0        
      0        
      0        
      0        
10693 0         0 elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10694             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)) {
10695             $char[$i] .= join '', splice @char, $i+1, 3;
10696 0         0 }
10697             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)) {
10698             $char[$i] .= join '', splice @char, $i+1, 2;
10699 0         0 }
10700             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)) {
10701             $char[$i] .= join '', splice @char, $i+1, 1;
10702             }
10703             }
10704              
10705 0         0 # open character class [...]
10706 3 50       4 elsif ($char[$i] eq '[') {
10707 3         8 my $left = $i;
10708             if ($char[$i+1] eq ']') {
10709 0         0 $i++;
10710 3 50       5 }
10711 7         11 while (1) {
10712             if (++$i > $#char) {
10713 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10714 7         13 }
10715             if ($char[$i] eq ']') {
10716             my $right = $i;
10717 3 50       4  
10718 3         17 # [...]
  0         0  
10719             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10720             splice @char, $left, $right-$left+1, sprintf(q{@{[Euhc::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10721 0         0 }
10722             else {
10723             splice @char, $left, $right-$left+1, Euhc::charlist_qr(@char[$left+1..$right-1], $modifier);
10724 3         11 }
10725 3         6  
10726             $i = $left;
10727             last;
10728             }
10729             }
10730             }
10731              
10732 3         7 # open character class [^...]
10733 1 50       3 elsif ($char[$i] eq '[^') {
10734 1         5 my $left = $i;
10735             if ($char[$i+1] eq ']') {
10736 0         0 $i++;
10737 1 50       2 }
10738 2         5 while (1) {
10739             if (++$i > $#char) {
10740 0 100       0 die __FILE__, ": Unmatched [] in regexp\n";
10741 2         6 }
10742             if ($char[$i] eq ']') {
10743             my $right = $i;
10744 1 50       1  
10745 1         8 # [^...]
  0         0  
10746             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10747             splice @char, $left, $right-$left+1, sprintf(q{@{[Euhc::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10748 0         0 }
10749             else {
10750             splice @char, $left, $right-$left+1, Euhc::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10751 1         16 }
10752 1         3  
10753             $i = $left;
10754             last;
10755             }
10756             }
10757             }
10758              
10759 1         3 # rewrite character class or escape character
10760             elsif (my $char = character_class($char[$i],$modifier)) {
10761             $char[$i] = $char;
10762             }
10763              
10764             # P.794 29.2.161. split
10765             # in Chapter 29: Functions
10766             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10767              
10768             # P.951 split
10769             # in Chapter 27: Functions
10770             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10771              
10772             # said "The //m modifier is assumed when you split on the pattern /^/",
10773             # but perl5.008 is not so. Therefore, this software adds //m.
10774             # (and so on)
10775              
10776 5         20 # split(m/^/) --> split(m/^/m)
10777             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
10778             $modifier .= 'm';
10779             }
10780              
10781 11 50       48 # /i modifier
10782 18         49 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Euhc::uc($char[$i]) ne Euhc::fc($char[$i]))) {
10783             if (CORE::length(Euhc::fc($char[$i])) == 1) {
10784             $char[$i] = '[' . Euhc::uc($char[$i]) . Euhc::fc($char[$i]) . ']';
10785 18         52 }
10786             else {
10787             $char[$i] = '(?:' . Euhc::uc($char[$i]) . '|' . Euhc::fc($char[$i]) . ')';
10788             }
10789             }
10790              
10791 0 50       0 # \u \l \U \L \F \Q \E
10792 2         7 elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
10793             if ($right_e < $left_e) {
10794             $char[$i] = '\\' . $char[$i];
10795             }
10796 0         0 }
10797 0         0 elsif ($char[$i] eq '\u') {
10798             $char[$i] = '@{[Euhc::ucfirst qq<';
10799             $left_e++;
10800 0         0 }
10801 0         0 elsif ($char[$i] eq '\l') {
10802             $char[$i] = '@{[Euhc::lcfirst qq<';
10803             $left_e++;
10804 0         0 }
10805 0         0 elsif ($char[$i] eq '\U') {
10806             $char[$i] = '@{[Euhc::uc qq<';
10807             $left_e++;
10808 0         0 }
10809 0         0 elsif ($char[$i] eq '\L') {
10810             $char[$i] = '@{[Euhc::lc qq<';
10811             $left_e++;
10812 0         0 }
10813 0         0 elsif ($char[$i] eq '\F') {
10814             $char[$i] = '@{[Euhc::fc qq<';
10815             $left_e++;
10816 0         0 }
10817 0         0 elsif ($char[$i] eq '\Q') {
10818             $char[$i] = '@{[CORE::quotemeta qq<';
10819             $left_e++;
10820 0 0       0 }
10821 0         0 elsif ($char[$i] eq '\E') {
10822 0         0 if ($right_e < $left_e) {
10823             $char[$i] = '>]}';
10824             $right_e++;
10825 0         0 }
10826             else {
10827             $char[$i] = '';
10828             }
10829 0         0 }
10830 0 0       0 elsif ($char[$i] eq '\Q') {
10831 0         0 while (1) {
10832             if (++$i > $#char) {
10833 0 0       0 last;
10834 0         0 }
10835             if ($char[$i] eq '\E') {
10836             last;
10837             }
10838             }
10839             }
10840             elsif ($char[$i] eq '\E') {
10841             }
10842              
10843 0 0       0 # $0 --> $0
10844 0         0 elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10845             if ($ignorecase) {
10846             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10847             }
10848 0 0       0 }
10849 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10850             if ($ignorecase) {
10851             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10852             }
10853             }
10854              
10855             # $$ --> $$
10856             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10857             }
10858              
10859             # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10860 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
10861 0 0       0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10862 0         0 $char[$i] = e_capture($1);
10863             if ($ignorecase) {
10864             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10865             }
10866 0         0 }
10867 0 0       0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10868 0         0 $char[$i] = e_capture($1);
10869             if ($ignorecase) {
10870             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10871             }
10872             }
10873              
10874 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
10875 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) {
10876 0         0 $char[$i] = e_capture($1.'->'.$2);
10877             if ($ignorecase) {
10878             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10879             }
10880             }
10881              
10882 0         0 # $$foo{ ... } --> $ $foo->{ ... }
10883 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) {
10884 0         0 $char[$i] = e_capture($1.'->'.$2);
10885             if ($ignorecase) {
10886             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10887             }
10888             }
10889              
10890 0         0 # $$foo
10891 0 0       0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10892 0         0 $char[$i] = e_capture($1);
10893             if ($ignorecase) {
10894             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10895             }
10896             }
10897              
10898 0 50       0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Euhc::PREMATCH()
10899 12         48 elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10900             if ($ignorecase) {
10901             $char[$i] = '@{[Euhc::ignorecase(Euhc::PREMATCH())]}';
10902 0         0 }
10903             else {
10904             $char[$i] = '@{[Euhc::PREMATCH()]}';
10905             }
10906             }
10907              
10908 12 50       72 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Euhc::MATCH()
10909 12         39 elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10910             if ($ignorecase) {
10911             $char[$i] = '@{[Euhc::ignorecase(Euhc::MATCH())]}';
10912 0         0 }
10913             else {
10914             $char[$i] = '@{[Euhc::MATCH()]}';
10915             }
10916             }
10917              
10918 12 50       77 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Euhc::POSTMATCH()
10919 9         29 elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10920             if ($ignorecase) {
10921             $char[$i] = '@{[Euhc::ignorecase(Euhc::POSTMATCH())]}';
10922 0         0 }
10923             else {
10924             $char[$i] = '@{[Euhc::POSTMATCH()]}';
10925             }
10926             }
10927              
10928 9 0       55 # ${ foo }
10929 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) {
10930             if ($ignorecase) {
10931             $char[$i] = '@{[Euhc::ignorecase(' . $1 . ')]}';
10932             }
10933             }
10934              
10935 0         0 # ${ ... }
10936 0 0       0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10937 0         0 $char[$i] = e_capture($1);
10938             if ($ignorecase) {
10939             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10940             }
10941             }
10942              
10943 0         0 # $scalar or @array
10944 3 50       13 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10945 3         19 $char[$i] = e_string($char[$i]);
10946             if ($ignorecase) {
10947             $char[$i] = '@{[Euhc::ignorecase(' . $char[$i] . ')]}';
10948             }
10949             }
10950              
10951 0 100       0 # quote character before ? + * {
10952             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10953             if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10954 7         44 }
10955             else {
10956             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10957             }
10958             }
10959             }
10960 4         24  
10961 189 50       497 # make regexp string
10962 189         469 $modifier =~ tr/i//d;
10963             if ($left_e > $right_e) {
10964 0         0 return join '', 'Euhc::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
10965             }
10966             return join '', 'Euhc::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
10967             }
10968              
10969             #
10970             # escape regexp of split qr''
10971 189     112 0 1849 #
10972 112   100     1005 sub e_split_q {
10973             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10974 112         375 $modifier ||= '';
10975 112 50       281  
10976 112         380 $modifier =~ tr/p//d;
10977 0         0 if ($modifier =~ /([adlu])/oxms) {
10978 0 0       0 my $line = 0;
10979 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10980 0         0 if ($filename ne __FILE__) {
10981             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10982             last;
10983 0         0 }
10984             }
10985             die qq{Unsupported modifier "$1" used at line $line.\n};
10986 0         0 }
10987              
10988             $slash = 'div';
10989 112 100       215  
10990 112         295 # /b /B modifier
10991             if ($modifier =~ tr/bB//d) {
10992             return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10993 56 100       326 }
10994              
10995             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10996 56         182  
10997             # split regexp
10998             my @char = $string =~ /\G((?>
10999             [^\x81-\xFE\\\[] |
11000             [\x81-\xFE][\x00-\xFF] |
11001             \[\^ |
11002             \[\: (?>[a-z]+) \:\] |
11003             \[\:\^ (?>[a-z]+) \:\] |
11004             \\ (?:$q_char) |
11005             (?:$q_char)
11006             ))/oxmsg;
11007 56         366  
11008 56 50 33     193 # unescape character
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11009             for (my $i=0; $i <= $#char; $i++) {
11010             if (0) {
11011             }
11012 56         652  
11013 0         0 # escape last octet of multiple-octet
11014             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11015             $char[$i] = $1 . '\\' . $2;
11016             }
11017              
11018 0         0 # open character class [...]
11019 0 0       0 elsif ($char[$i] eq '[') {
11020 0         0 my $left = $i;
11021             if ($char[$i+1] eq ']') {
11022 0         0 $i++;
11023 0 0       0 }
11024 0         0 while (1) {
11025             if (++$i > $#char) {
11026 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11027 0         0 }
11028             if ($char[$i] eq ']') {
11029             my $right = $i;
11030 0         0  
11031             # [...]
11032 0         0 splice @char, $left, $right-$left+1, Euhc::charlist_qr(@char[$left+1..$right-1], $modifier);
11033 0         0  
11034             $i = $left;
11035             last;
11036             }
11037             }
11038             }
11039              
11040 0         0 # open character class [^...]
11041 0 0       0 elsif ($char[$i] eq '[^') {
11042 0         0 my $left = $i;
11043             if ($char[$i+1] eq ']') {
11044 0         0 $i++;
11045 0 0       0 }
11046 0         0 while (1) {
11047             if (++$i > $#char) {
11048 0 0       0 die __FILE__, ": Unmatched [] in regexp\n";
11049 0         0 }
11050             if ($char[$i] eq ']') {
11051             my $right = $i;
11052 0         0  
11053             # [^...]
11054 0         0 splice @char, $left, $right-$left+1, Euhc::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11055 0         0  
11056             $i = $left;
11057             last;
11058             }
11059             }
11060             }
11061              
11062 0         0 # rewrite character class or escape character
11063             elsif (my $char = character_class($char[$i],$modifier)) {
11064             $char[$i] = $char;
11065             }
11066              
11067 0         0 # split(m/^/) --> split(m/^/m)
11068             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11069             $modifier .= 'm';
11070             }
11071              
11072 0 50       0 # /i modifier
11073 12         42 elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Euhc::uc($char[$i]) ne Euhc::fc($char[$i]))) {
11074             if (CORE::length(Euhc::fc($char[$i])) == 1) {
11075             $char[$i] = '[' . Euhc::uc($char[$i]) . Euhc::fc($char[$i]) . ']';
11076 12         36 }
11077             else {
11078             $char[$i] = '(?:' . Euhc::uc($char[$i]) . '|' . Euhc::fc($char[$i]) . ')';
11079             }
11080             }
11081              
11082 0 0       0 # quote character before ? + * {
11083             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11084             if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11085 0         0 }
11086             else {
11087             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11088             }
11089             }
11090 0         0 }
11091 56         134  
11092             $modifier =~ tr/i//d;
11093             return join '', 'Euhc::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11094             }
11095              
11096             #
11097             # escape use without import
11098 56     0 0 341 #
11099             sub e_use_noimport {
11100 0           my($module) = @_;
11101              
11102 0           my $expr = _pathof($module);
11103 0            
11104             my $fh = gensym();
11105 0 0         for my $realfilename (_realfilename($expr)) {
11106 0            
11107 0           if (Euhc::_open_r($fh, $realfilename)) {
11108 0 0         local $/ = undef; # slurp mode
11109             my $script = <$fh>;
11110 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11111 0            
11112             if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11113 0           return qq;
11114             }
11115             last;
11116             }
11117 0           }
11118              
11119             return qq;
11120             }
11121              
11122             #
11123             # escape no without unimport
11124 0     0 0   #
11125             sub e_no_nounimport {
11126 0           my($module) = @_;
11127              
11128 0           my $expr = _pathof($module);
11129 0            
11130             my $fh = gensym();
11131 0 0         for my $realfilename (_realfilename($expr)) {
11132 0            
11133 0           if (Euhc::_open_r($fh, $realfilename)) {
11134 0 0         local $/ = undef; # slurp mode
11135             my $script = <$fh>;
11136 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11137 0            
11138             if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11139 0           return qq;
11140             }
11141             last;
11142             }
11143 0           }
11144              
11145             return qq;
11146             }
11147              
11148             #
11149             # escape use with import no parameter
11150 0     0 0   #
11151             sub e_use_noparam {
11152 0           my($module) = @_;
11153              
11154 0           my $expr = _pathof($module);
11155 0            
11156             my $fh = gensym();
11157 0 0         for my $realfilename (_realfilename($expr)) {
11158 0            
11159 0           if (Euhc::_open_r($fh, $realfilename)) {
11160 0 0         local $/ = undef; # slurp mode
11161             my $script = <$fh>;
11162 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11163              
11164             if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11165              
11166             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11167             # in Chapter 12: Objects
11168             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11169              
11170             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11171             # in Chapter 12: Objects
11172             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11173              
11174 0           # (and so on)
11175              
11176 0           return qq[BEGIN { Euhc::require '$expr'; $module->import() if $module->can('import'); }];
11177             }
11178             last;
11179             }
11180 0           }
11181              
11182             return qq;
11183             }
11184              
11185             #
11186             # escape no with unimport no parameter
11187 0     0 0   #
11188             sub e_no_noparam {
11189 0           my($module) = @_;
11190              
11191 0           my $expr = _pathof($module);
11192 0            
11193             my $fh = gensym();
11194 0 0         for my $realfilename (_realfilename($expr)) {
11195 0            
11196 0           if (Euhc::_open_r($fh, $realfilename)) {
11197 0 0         local $/ = undef; # slurp mode
11198             my $script = <$fh>;
11199 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11200 0            
11201             if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11202 0           return qq[BEGIN { Euhc::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11203             }
11204             last;
11205             }
11206 0           }
11207              
11208             return qq;
11209             }
11210              
11211             #
11212             # escape use with import parameters
11213 0     0 0   #
11214             sub e_use {
11215 0           my($module,$list) = @_;
11216              
11217 0           my $expr = _pathof($module);
11218 0            
11219             my $fh = gensym();
11220 0 0         for my $realfilename (_realfilename($expr)) {
11221 0            
11222 0           if (Euhc::_open_r($fh, $realfilename)) {
11223 0 0         local $/ = undef; # slurp mode
11224             my $script = <$fh>;
11225 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11226 0            
11227             if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11228 0           return qq[BEGIN { Euhc::require '$expr'; $module->import($list) if $module->can('import'); }];
11229             }
11230             last;
11231             }
11232 0           }
11233              
11234             return qq;
11235             }
11236              
11237             #
11238             # escape no with unimport parameters
11239 0     0 0   #
11240             sub e_no {
11241 0           my($module,$list) = @_;
11242              
11243 0           my $expr = _pathof($module);
11244 0            
11245             my $fh = gensym();
11246 0 0         for my $realfilename (_realfilename($expr)) {
11247 0            
11248 0           if (Euhc::_open_r($fh, $realfilename)) {
11249 0 0         local $/ = undef; # slurp mode
11250             my $script = <$fh>;
11251 0 0         close($fh) or die __FILE__, ": Can't close file: $realfilename\n";
11252 0            
11253             if ($script =~ /^ (?>\s*) use (?>\s+) UHC (?>\s*) ([^\x81-\xFE;]*) ; (?>\s*) \n? $/oxms) {
11254 0           return qq[BEGIN { Euhc::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11255             }
11256             last;
11257             }
11258 0           }
11259              
11260             return qq;
11261             }
11262              
11263             #
11264             # file path of module
11265 0     0     #
11266             sub _pathof {
11267 0 0         my($expr) = @_;
11268 0            
11269             if ($^O eq 'MacOS') {
11270             $expr =~ s#::#:#g;
11271 0           }
11272             else {
11273 0 0         $expr =~ s#::#/#g;
11274             }
11275 0           $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11276              
11277             return $expr;
11278             }
11279              
11280             #
11281             # real file name of module
11282 0     0     #
11283             sub _realfilename {
11284 0 0         my($expr) = @_;
11285 0            
  0            
11286             if ($^O eq 'MacOS') {
11287             return map {"$_$expr"} @INC;
11288 0           }
  0            
11289             else {
11290             return map {"$_/$expr"} @INC;
11291             }
11292             }
11293              
11294             #
11295             # instead of Carp::carp
11296 0     0 0   #
11297 0           sub carp {
11298             my($package,$filename,$line) = caller(1);
11299             print STDERR "@_ at $filename line $line.\n";
11300             }
11301              
11302             #
11303             # instead of Carp::croak
11304 0     0 0   #
11305 0           sub croak {
11306 0           my($package,$filename,$line) = caller(1);
11307             print STDERR "@_ at $filename line $line.\n";
11308             die "\n";
11309             }
11310              
11311             #
11312             # instead of Carp::cluck
11313 0     0 0   #
11314 0           sub cluck {
11315 0           my $i = 0;
11316 0           my @cluck = ();
11317 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11318             push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11319 0           $i++;
11320 0           }
11321 0           print STDERR CORE::reverse @cluck;
11322             print STDERR "\n";
11323             print STDERR @_;
11324             }
11325              
11326             #
11327             # instead of Carp::confess
11328 0     0 0   #
11329 0           sub confess {
11330 0           my $i = 0;
11331 0           my @confess = ();
11332 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
11333             push @confess, "[$i] $filename($line) $package::$subroutine\n";
11334 0           $i++;
11335 0           }
11336 0           print STDERR CORE::reverse @confess;
11337 0           print STDERR "\n";
11338             print STDERR @_;
11339             die "\n";
11340             }
11341              
11342             1;
11343              
11344             __END__