File Coverage

blib/lib/Esjis.pm
Criterion Covered Total %
statement 1204 4847 24.8
branch 1358 4764 28.5
condition 160 511 31.3
subroutine 71 205 34.6
pod 8 149 5.3
total 2801 10476 26.7


line stmt bran cond sub pod time code
1             package Esjis;
2 391     391   14027 use strict;
  391         2779  
  391         17472  
3 391 50   391   11704 BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 } use warnings;
  391     391   3490  
  391         640  
  391         14263  
4             ######################################################################
5             #
6             # Esjis - Run-time routines for Sjis.pm
7             #
8             # http://search.cpan.org/dist/Char-Sjis/
9             #
10             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
11             ######################################################################
12              
13 391     391   7942 use 5.00503; # Galapagos Consensus 1998 for primetools
  391         4757  
14             # use 5.008001; # Lancaster Consensus 2013 for toolchains
15              
16             # 12.3. Delaying use Until Runtime
17             # in Chapter 12. Packages, Libraries, and Modules
18             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
19             # (and so on)
20              
21             # Version numbers should be boring
22             # http://www.dagolden.com/index.php/369/version-numbers-should-be-boring/
23             # For the impatient, the disinterested or those who just want to follow
24             # a recipe, my advice for all modules is this:
25             # our $VERSION = "0.001"; # or "0.001_001" for a dev release
26             # $VERSION = eval $VERSION; # No!! because '1.10' makes '1.1'
27              
28 391     391   3564 use vars qw($VERSION);
  391         3711  
  391         51977  
29             $VERSION = '1.21';
30             $VERSION = $VERSION;
31              
32             BEGIN {
33 391 50   391   5396 if ($^X =~ / jperl /oxmsi) {
34 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
35             }
36 391         3707 if (CORE::ord('A') == 193) {
37             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
38             }
39 391         49295 if (CORE::ord('A') != 0x41) {
40             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).\n";
41             }
42             }
43              
44             BEGIN {
45              
46             # instead of utf8.pm
47 391     391   28881 CORE::eval q{
  391     391   2382  
  391     130   5345  
  391         46512  
  0         0  
  0         0  
  0         0  
  0         0  
48             no warnings qw(redefine);
49             *utf8::upgrade = sub { CORE::length $_[0] };
50             *utf8::downgrade = sub { 1 };
51             *utf8::encode = sub { };
52             *utf8::decode = sub { 1 };
53             *utf8::is_utf8 = sub { };
54             *utf8::valid = sub { 1 };
55             };
56 391 50       146804 if ($@) {
57 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
58 0         0 *utf8::downgrade = sub { 1 };
  0         0  
59 0         0 *utf8::encode = sub { };
60 0         0 *utf8::decode = sub { 1 };
  0         0  
61 0         0 *utf8::is_utf8 = sub { };
62 0         0 *utf8::valid = sub { 1 };
  0         0  
63             }
64             }
65              
66             # instead of Symbol.pm
67 0         0 BEGIN {
68             sub gensym () {
69 0 0   0 0 0 if ($] < 5.006) {
70 0         0 return \do { local *_ };
  0         0  
71             }
72             else {
73 0         0 return undef;
74             }
75             }
76              
77             sub qualify ($$) {
78 0     1158 0 0 my($name) = @_;
79              
80 1158 50       3238 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
81 1158         4634 return $name;
82             }
83             elsif (Esjis::index($name,'::') >= 0) {
84 0         0 return $name;
85             }
86             elsif (Esjis::index($name,"'") >= 0) {
87 0         0 return $name;
88             }
89              
90             # special character, "^xyz"
91             elsif ($name =~ /\A \^ [ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]+ \z/x) {
92              
93             # RGS 2001-11-05 : translate leading ^X to control-char
94 0         0 $name =~ s{\A \^ ([ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz_]) }{'qq(\c'.$1.')'}xee;
  0         0  
95 0         0 return 'main::' . $name;
96             }
97              
98             # Global names
99             elsif ($name =~ /\A (?: ARGV | ARGVOUT | ENV | INC | SIG | STDERR | STDIN | STDOUT ) \z/x) {
100 0         0 return 'main::' . $name;
101             }
102              
103             # or other
104             elsif ($name =~ /\A [^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz] \z/x) {
105 0         0 return 'main::' . $name;
106             }
107              
108             elsif (defined $_[1]) {
109 0         0 return $_[1] . '::' . $name;
110             }
111             else {
112 1158         9851 return (caller)[0] . '::' . $name;
113             }
114             }
115              
116             sub qualify_to_ref ($;$) {
117 0 50   1158 0 0 if (defined $_[1]) {
118 391     391   4636 no strict qw(refs);
  391         2526  
  391         25112  
119 1158         3768 return \*{ qualify $_[0], $_[1] };
  0         0  
120             }
121             else {
122 391     391   3871 no strict qw(refs);
  391     0   770  
  391         69116  
123 0         0 return \*{ qualify $_[0], (caller)[0] };
  1158         1911  
124             }
125             }
126             }
127              
128             # P.714 29.2.39. flock
129             # in Chapter 29: Functions
130             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
131              
132             # P.863 flock
133             # in Chapter 27: Functions
134             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
135              
136             sub LOCK_SH() {1}
137             sub LOCK_EX() {2}
138             sub LOCK_UN() {8}
139             sub LOCK_NB() {4}
140              
141             # instead of Carp.pm
142             sub carp;
143             sub croak;
144             sub cluck;
145             sub confess;
146              
147             # 6.18. Matching Multiple-Byte Characters
148             # in Chapter 6. Pattern Matching
149             # of ISBN 978-1-56592-243-3 Perl Perl Cookbook.
150             # (and so on)
151              
152             # regexp of character
153             my $your_char = q{[\x81-\x9F\xE0-\xFC][\x00-\xFF]|[\x00-\xFF]};
154 391     391   2666 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  391         3836  
  391         27746  
155 391     391   3878 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  391         2380  
  391         629336  
156              
157             #
158             # ShiftJIS character range per length
159             #
160             my %range_tr = ();
161              
162             #
163             # ShiftJIS case conversion
164             #
165             my %lc = ();
166             @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)} =
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             my %uc = ();
169             @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)} =
170             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);
171             my %fc = ();
172             @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)} =
173             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);
174              
175             if (0) {
176             }
177              
178             elsif (__PACKAGE__ =~ / \b E s j i s \z/oxms) { # escape from build system
179             %range_tr = (
180             1 => [ [0x00..0x80],
181             [0xA0..0xDF],
182             [0xFD..0xFF],
183             ],
184             2 => [ [0x81..0x9F],[0x40..0x7E],
185             [0x81..0x9F],[0x80..0xFC],
186             [0xE0..0xFC],[0x40..0x7E],
187             [0xE0..0xFC],[0x80..0xFC],
188             ],
189             );
190             }
191              
192             else {
193             croak "Don't know my package name '@{[__PACKAGE__]}'";
194             }
195              
196             #
197             # @ARGV wildcard globbing
198             #
199             sub import {
200              
201 1158 50   5   6320 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
202 5         106 my @argv = ();
203 0         0 for (@ARGV) {
204              
205             # has space
206 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
207 0 0       0 if (my @glob = Esjis::glob(qq{"$_"})) {
208 0         0 push @argv, @glob;
209             }
210             else {
211 0         0 push @argv, $_;
212             }
213             }
214              
215             # has wildcard metachar
216             elsif (/\A (?:$q_char)*? [*?] /oxms) {
217 0 0       0 if (my @glob = Esjis::glob($_)) {
218 0         0 push @argv, @glob;
219             }
220             else {
221 0         0 push @argv, $_;
222             }
223             }
224              
225             # no wildcard globbing
226             else {
227 0         0 push @argv, $_;
228             }
229             }
230 0         0 @ARGV = @argv;
231             }
232              
233 0         0 *Char::ord = \&Sjis::ord;
234 5         35 *Char::ord_ = \&Sjis::ord_;
235 5         17 *Char::reverse = \&Sjis::reverse;
236 5         14 *Char::getc = \&Sjis::getc;
237 5         12 *Char::length = \&Sjis::length;
238 5         10 *Char::substr = \&Sjis::substr;
239 5         144 *Char::index = \&Sjis::index;
240 5         14 *Char::rindex = \&Sjis::rindex;
241 5         13 *Char::eval = \&Sjis::eval;
242 5         17 *Char::escape = \&Sjis::escape;
243 5         14 *Char::escape_token = \&Sjis::escape_token;
244 5         10 *Char::escape_script = \&Sjis::escape_script;
245             }
246              
247             # P.230 Care with Prototypes
248             # in Chapter 6: Subroutines
249             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
250             #
251             # If you aren't careful, you can get yourself into trouble with prototypes.
252             # But if you are careful, you can do a lot of neat things with them. This is
253             # all very powerful, of course, and should only be used in moderation to make
254             # the world a better place.
255              
256             # P.332 Care with Prototypes
257             # in Chapter 7: Subroutines
258             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
259             #
260             # If you aren't careful, you can get yourself into trouble with prototypes.
261             # But if you are careful, you can do a lot of neat things with them. This is
262             # all very powerful, of course, and should only be used in moderation to make
263             # the world a better place.
264              
265             #
266             # Prototypes of subroutines
267             #
268       0     sub unimport {}
269             sub Esjis::split(;$$$);
270             sub Esjis::tr($$$$;$);
271             sub Esjis::chop(@);
272             sub Esjis::index($$;$);
273             sub Esjis::rindex($$;$);
274             sub Esjis::lcfirst(@);
275             sub Esjis::lcfirst_();
276             sub Esjis::lc(@);
277             sub Esjis::lc_();
278             sub Esjis::ucfirst(@);
279             sub Esjis::ucfirst_();
280             sub Esjis::uc(@);
281             sub Esjis::uc_();
282             sub Esjis::fc(@);
283             sub Esjis::fc_();
284             sub Esjis::ignorecase;
285             sub Esjis::classic_character_class;
286             sub Esjis::capture;
287             sub Esjis::chr(;$);
288             sub Esjis::chr_();
289             sub Esjis::filetest;
290             sub Esjis::r(;*@);
291             sub Esjis::w(;*@);
292             sub Esjis::x(;*@);
293             sub Esjis::o(;*@);
294             sub Esjis::R(;*@);
295             sub Esjis::W(;*@);
296             sub Esjis::X(;*@);
297             sub Esjis::O(;*@);
298             sub Esjis::e(;*@);
299             sub Esjis::z(;*@);
300             sub Esjis::s(;*@);
301             sub Esjis::f(;*@);
302             sub Esjis::d(;*@);
303             sub Esjis::l(;*@);
304             sub Esjis::p(;*@);
305             sub Esjis::S(;*@);
306             sub Esjis::b(;*@);
307             sub Esjis::c(;*@);
308             sub Esjis::u(;*@);
309             sub Esjis::g(;*@);
310             sub Esjis::k(;*@);
311             sub Esjis::T(;*@);
312             sub Esjis::B(;*@);
313             sub Esjis::M(;*@);
314             sub Esjis::A(;*@);
315             sub Esjis::C(;*@);
316             sub Esjis::filetest_;
317             sub Esjis::r_();
318             sub Esjis::w_();
319             sub Esjis::x_();
320             sub Esjis::o_();
321             sub Esjis::R_();
322             sub Esjis::W_();
323             sub Esjis::X_();
324             sub Esjis::O_();
325             sub Esjis::e_();
326             sub Esjis::z_();
327             sub Esjis::s_();
328             sub Esjis::f_();
329             sub Esjis::d_();
330             sub Esjis::l_();
331             sub Esjis::p_();
332             sub Esjis::S_();
333             sub Esjis::b_();
334             sub Esjis::c_();
335             sub Esjis::u_();
336             sub Esjis::g_();
337             sub Esjis::k_();
338             sub Esjis::T_();
339             sub Esjis::B_();
340             sub Esjis::M_();
341             sub Esjis::A_();
342             sub Esjis::C_();
343             sub Esjis::glob($);
344             sub Esjis::glob_();
345             sub Esjis::lstat(*);
346             sub Esjis::lstat_();
347             sub Esjis::opendir(*$);
348             sub Esjis::stat(*);
349             sub Esjis::stat_();
350             sub Esjis::unlink(@);
351             sub Esjis::chdir(;$);
352             sub Esjis::do($);
353             sub Esjis::require(;$);
354             sub Esjis::telldir(*);
355              
356             sub Sjis::ord(;$);
357             sub Sjis::ord_();
358             sub Sjis::reverse(@);
359             sub Sjis::getc(;*@);
360             sub Sjis::length(;$);
361             sub Sjis::substr($$;$$);
362             sub Sjis::index($$;$);
363             sub Sjis::rindex($$;$);
364             sub Sjis::escape(;$);
365              
366             #
367             # Regexp work
368             #
369 391         39334 use vars qw(
370             $re_a
371             $re_t
372             $re_n
373             $re_r
374 391     391   8152 );
  391         2429  
375              
376             #
377             # Character class
378             #
379 391         104779 use vars qw(
380             $dot
381             $dot_s
382             $eD
383             $eS
384             $eW
385             $eH
386             $eV
387             $eR
388             $eN
389             $not_alnum
390             $not_alpha
391             $not_ascii
392             $not_blank
393             $not_cntrl
394             $not_digit
395             $not_graph
396             $not_lower
397             $not_lower_i
398             $not_print
399             $not_punct
400             $not_space
401             $not_upper
402             $not_upper_i
403             $not_word
404             $not_xdigit
405             $eb
406             $eB
407 391     391   3652 );
  391         2051  
408              
409 391         4282913 use vars qw(
410             $anchor
411             $matched
412 391     391   3894 );
  391         8098  
413             ${Esjis::anchor} = qr{\G(?>[^\x81-\x9F\xE0-\xFC]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])*?}oxms;
414             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
415              
416             # Quantifiers
417             # {n,m} --- Match at least n but not more than m times
418             #
419             # n and m are limited to non-negative integral values less than a
420             # preset limit defined when perl is built. This is usually 32766 on
421             # the most common platforms.
422             #
423             # The following code is an attempt to solve the above limitations
424             # in a multi-byte anchoring.
425              
426             # avoid "Segmentation fault" and "Error: Parse exception"
427              
428             # perl5101delta
429             # http://perldoc.perl.org/perl5101delta.html
430             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
431             # [RT #60034, #60464]. For example, this match would fail:
432             # ("ab" x 32768) =~ /^(ab)*$/
433              
434             # SEE ALSO
435             #
436             # Complex regular subexpression recursion limit
437             # http://www.perlmonks.org/?node_id=810857
438             #
439             # regexp iteration limits
440             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
441             #
442             # latest Perl won't match certain regexes more than 32768 characters long
443             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
444             #
445             # Break through the limitations of regular expressions of Perl
446             # http://d.hatena.ne.jp/gfx/20110212/1297512479
447              
448             if (($] >= 5.010001) or
449             # ActivePerl 5.6 or later (include 5.10.0)
450             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
451             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
452             ) {
453             my $sbcs = ''; # Single Byte Character Set
454             for my $range (@{ $range_tr{1} }) {
455             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
456             }
457              
458             if (0) {
459             }
460              
461             # other encoding
462             else {
463             ${Esjis::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
464             # ******* octets not in multiple octet char (always char boundary)
465             # **************** 2 octet chars
466             }
467              
468             ${Esjis::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
469             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\x9F\xE0-\xFC]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Esjis::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
470             # qr{
471             # \G # (1), (2)
472             # (? # (3)
473             # (?=.{0,32766}\z) # (4)
474             # (?:[^\x81-\x9F\xE0-\xFC]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])*?| # (5)
475             # (?(?=[$sbcs]+\z) # (6)
476             # .*?| #(7)
477             # (?:${Esjis::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
478             # ))}oxms;
479              
480             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
481             local $^W = 0;
482             local $SIG{__WARN__} = sub {};
483              
484             if (((('A' x 32768).'B') !~ / ${Esjis::anchor} B /oxms) and
485             ((('A' x 32768).'B') =~ / ${Esjis::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
486             ) {
487             ${Esjis::anchor} = ${Esjis::anchor_SADAHIRO_Tomoyuki_2002_01_17};
488             }
489             else {
490             undef ${Esjis::q_char_SADAHIRO_Tomoyuki_2002_01_17};
491             }
492             }
493              
494             # (1)
495             # P.128 Start of match (or end of previous match): \G
496             # P.130 Advanced Use of \G with Perl
497             # in Chapter3: Over view of Regular Expression Features and Flavors
498             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
499              
500             # (2)
501             # P.255 Use leading anchors
502             # P.256 Expose ^ and \G at the front of expressions
503             # in Chapter6: Crafting an Efficient Expression
504             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
505              
506             # (3)
507             # P.138 Conditional: (? if then| else)
508             # in Chapter3: Over view of Regular Expression Features and Flavors
509             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
510              
511             # (4)
512             # perlre
513             # http://perldoc.perl.org/perlre.html
514             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
515             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
516             # integral values less than a preset limit defined when perl is built.
517             # This is usually 32766 on the most common platforms. The actual limit
518             # can be seen in the error message generated by code such as this:
519             # $_ **= $_ , / {$_} / for 2 .. 42;
520              
521             # (5)
522             # P.1023 Multiple-Byte Anchoring
523             # in Appendix W Perl Code Examples
524             # of ISBN 1-56592-224-7 CJKV Information Processing
525              
526             # (6)
527             # if string has only SBCS (Single Byte Character Set)
528              
529             # (7)
530             # then .*? (isn't limited to 32766)
531              
532             # (8)
533             # else ShiftJIS::Regexp::Const (SADAHIRO Tomoyuki)
534             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
535             # http://search.cpan.org/~sadahiro/ShiftJIS-Regexp/
536             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\x9F\xE0-\xFC]{2})*?';
537             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\x9F\xE0-\xFC]{2})*?';
538             # $PadGA = '\G(?:\A|(?:[\x81-\x9F\xE0-\xFC]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\x9F\xE0-\xFC]{2})*?)';
539              
540             ${Esjis::dot} = qr{(?>[^\x81-\x9F\xE0-\xFC\x0A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
541             ${Esjis::dot_s} = qr{(?>[^\x81-\x9F\xE0-\xFC]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
542             ${Esjis::eD} = qr{(?>[^\x81-\x9F\xE0-\xFC0-9]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
543              
544             # Vertical tabs are now whitespace
545             # \s in a regex now matches a vertical tab in all circumstances.
546             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
547             # ${Esjis::eS} = qr{(?>[^\x81-\x9F\xE0-\xFC\x09\x0A \x0C\x0D\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
548             # ${Esjis::eS} = qr{(?>[^\x81-\x9F\xE0-\xFC\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
549             ${Esjis::eS} = qr{(?>[^\x81-\x9F\xE0-\xFC\s]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
550              
551             ${Esjis::eW} = qr{(?>[^\x81-\x9F\xE0-\xFC0-9A-Z_a-z]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
552             ${Esjis::eH} = qr{(?>[^\x81-\x9F\xE0-\xFC\x09\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
553             ${Esjis::eV} = qr{(?>[^\x81-\x9F\xE0-\xFC\x0A\x0B\x0C\x0D]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
554             ${Esjis::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
555             ${Esjis::eN} = qr{(?>[^\x81-\x9F\xE0-\xFC\x0A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
556             ${Esjis::not_alnum} = qr{(?>[^\x81-\x9F\xE0-\xFC\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
557             ${Esjis::not_alpha} = qr{(?>[^\x81-\x9F\xE0-\xFC\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
558             ${Esjis::not_ascii} = qr{(?>[^\x81-\x9F\xE0-\xFC\x00-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
559             ${Esjis::not_blank} = qr{(?>[^\x81-\x9F\xE0-\xFC\x09\x20]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
560             ${Esjis::not_cntrl} = qr{(?>[^\x81-\x9F\xE0-\xFC\x00-\x1F\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
561             ${Esjis::not_digit} = qr{(?>[^\x81-\x9F\xE0-\xFC\x30-\x39]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
562             ${Esjis::not_graph} = qr{(?>[^\x81-\x9F\xE0-\xFC\x21-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
563             ${Esjis::not_lower} = qr{(?>[^\x81-\x9F\xE0-\xFC\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
564             ${Esjis::not_lower_i} = qr{(?>[^\x81-\x9F\xE0-\xFC\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])}; # Perl 5.16 compatible
565             # ${Esjis::not_lower_i} = qr{(?>[^\x81-\x9F\xE0-\xFC]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])}; # older Perl compatible
566             ${Esjis::not_print} = qr{(?>[^\x81-\x9F\xE0-\xFC\x20-\x7F]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
567             ${Esjis::not_punct} = qr{(?>[^\x81-\x9F\xE0-\xFC\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
568             ${Esjis::not_space} = qr{(?>[^\x81-\x9F\xE0-\xFC\s\x0B]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
569             ${Esjis::not_upper} = qr{(?>[^\x81-\x9F\xE0-\xFC\x41-\x5A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
570             ${Esjis::not_upper_i} = qr{(?>[^\x81-\x9F\xE0-\xFC\x41-\x5A\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])}; # Perl 5.16 compatible
571             # ${Esjis::not_upper_i} = qr{(?>[^\x81-\x9F\xE0-\xFC]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])}; # older Perl compatible
572             ${Esjis::not_word} = qr{(?>[^\x81-\x9F\xE0-\xFC\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
573             ${Esjis::not_xdigit} = qr{(?>[^\x81-\x9F\xE0-\xFC\x30-\x39\x41-\x46\x61-\x66]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])};
574             ${Esjis::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))};
575             ${Esjis::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]))};
576              
577             # avoid: Name "Esjis::foo" used only once: possible typo at here.
578             ${Esjis::dot} = ${Esjis::dot};
579             ${Esjis::dot_s} = ${Esjis::dot_s};
580             ${Esjis::eD} = ${Esjis::eD};
581             ${Esjis::eS} = ${Esjis::eS};
582             ${Esjis::eW} = ${Esjis::eW};
583             ${Esjis::eH} = ${Esjis::eH};
584             ${Esjis::eV} = ${Esjis::eV};
585             ${Esjis::eR} = ${Esjis::eR};
586             ${Esjis::eN} = ${Esjis::eN};
587             ${Esjis::not_alnum} = ${Esjis::not_alnum};
588             ${Esjis::not_alpha} = ${Esjis::not_alpha};
589             ${Esjis::not_ascii} = ${Esjis::not_ascii};
590             ${Esjis::not_blank} = ${Esjis::not_blank};
591             ${Esjis::not_cntrl} = ${Esjis::not_cntrl};
592             ${Esjis::not_digit} = ${Esjis::not_digit};
593             ${Esjis::not_graph} = ${Esjis::not_graph};
594             ${Esjis::not_lower} = ${Esjis::not_lower};
595             ${Esjis::not_lower_i} = ${Esjis::not_lower_i};
596             ${Esjis::not_print} = ${Esjis::not_print};
597             ${Esjis::not_punct} = ${Esjis::not_punct};
598             ${Esjis::not_space} = ${Esjis::not_space};
599             ${Esjis::not_upper} = ${Esjis::not_upper};
600             ${Esjis::not_upper_i} = ${Esjis::not_upper_i};
601             ${Esjis::not_word} = ${Esjis::not_word};
602             ${Esjis::not_xdigit} = ${Esjis::not_xdigit};
603             ${Esjis::eb} = ${Esjis::eb};
604             ${Esjis::eB} = ${Esjis::eB};
605              
606             #
607             # ShiftJIS split
608             #
609             sub Esjis::split(;$$$) {
610              
611             # P.794 29.2.161. split
612             # in Chapter 29: Functions
613             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
614              
615             # P.951 split
616             # in Chapter 27: Functions
617             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
618              
619 5     0 0 13506 my $pattern = $_[0];
620 0         0 my $string = $_[1];
621 0         0 my $limit = $_[2];
622              
623             # if $pattern is also omitted or is the literal space, " "
624 0 0       0 if (not defined $pattern) {
625 0         0 $pattern = ' ';
626             }
627              
628             # if $string is omitted, the function splits the $_ string
629 0 0       0 if (not defined $string) {
630 0 0       0 if (defined $_) {
631 0         0 $string = $_;
632             }
633             else {
634 0         0 $string = '';
635             }
636             }
637              
638 0         0 my @split = ();
639              
640             # when string is empty
641 0 0       0 if ($string eq '') {
    0          
642              
643             # resulting list value in list context
644 0 0       0 if (wantarray) {
645 0         0 return @split;
646             }
647              
648             # count of substrings in scalar context
649             else {
650 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
651 0         0 @_ = @split;
652 0         0 return scalar @_;
653             }
654             }
655              
656             # split's first argument is more consistently interpreted
657             #
658             # After some changes earlier in v5.17, split's behavior has been simplified:
659             # if the PATTERN argument evaluates to a string containing one space, it is
660             # treated the way that a literal string containing one space once was.
661             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
662              
663             # if $pattern is also omitted or is the literal space, " ", the function splits
664             # on whitespace, /\s+/, after skipping any leading whitespace
665             # (and so on)
666              
667             elsif ($pattern eq ' ') {
668 0 0       0 if (not defined $limit) {
669 0         0 return CORE::split(' ', $string);
670             }
671             else {
672 0         0 return CORE::split(' ', $string, $limit);
673             }
674             }
675              
676 0         0 local $q_char = $q_char;
677 0 0       0 if (CORE::length($string) > 32766) {
678 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
679 0         0 $q_char = qr{.}s;
680             }
681             elsif (defined ${Esjis::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
682 0         0 $q_char = ${Esjis::q_char_SADAHIRO_Tomoyuki_2002_01_17};
683             }
684             }
685              
686             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
687 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
688              
689             # a pattern capable of matching either the null string or something longer than the
690             # null string will split the value of $string into separate characters wherever it
691             # matches the null string between characters
692             # (and so on)
693              
694 0 0       0 if ('' =~ / \A $pattern \z /xms) {
695 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
696 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
697              
698             # P.1024 Appendix W.10 Multibyte Processing
699             # of ISBN 1-56592-224-7 CJKV Information Processing
700             # (and so on)
701              
702             # the //m modifier is assumed when you split on the pattern /^/
703             # (and so on)
704              
705 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
706             # V
707 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
708              
709             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
710             # is included in the resulting list, interspersed with the fields that are ordinarily returned
711             # (and so on)
712              
713 0         0 local $@;
714 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
715 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
716 0         0 push @split, CORE::eval('$' . $digit);
717             }
718             }
719             }
720              
721             else {
722 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
723              
724 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
725             # V
726 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
727 0         0 local $@;
728 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
729 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
730 0         0 push @split, CORE::eval('$' . $digit);
731             }
732             }
733             }
734             }
735              
736             elsif ($limit > 0) {
737 0 0       0 if ('' =~ / \A $pattern \z /xms) {
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 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
742             # V
743 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
744 0         0 local $@;
745 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
746 0         0 push @split, CORE::eval('$' . $digit);
747             }
748             }
749             }
750             }
751             else {
752 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
753 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
754              
755 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
756             # V
757 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
758 0         0 local $@;
759 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
760 0         0 push @split, CORE::eval('$' . $digit);
761             }
762             }
763             }
764             }
765             }
766              
767 0 0       0 if (CORE::length($string) > 0) {
768 0         0 push @split, $string;
769             }
770              
771             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
772 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
773 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
774 0         0 pop @split;
775             }
776             }
777              
778             # resulting list value in list context
779 0 0       0 if (wantarray) {
780 0         0 return @split;
781             }
782              
783             # count of substrings in scalar context
784             else {
785 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
786 0         0 @_ = @split;
787 0         0 return scalar @_;
788             }
789             }
790              
791             #
792             # get last subexpression offsets
793             #
794             sub _last_subexpression_offsets {
795 0     0   0 my $pattern = $_[0];
796              
797             # remove comment
798 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
799              
800 0         0 my $modifier = '';
801 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
802 0         0 $modifier = $1;
803 0         0 $modifier =~ s/-[A-Za-z]*//;
804             }
805              
806             # with /x modifier
807 0         0 my @char = ();
808 0 0       0 if ($modifier =~ /x/oxms) {
809 0         0 @char = $pattern =~ /\G((?>
810             [^\x81-\x9F\xE0-\xFC\\\#\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
811             \\ $q_char |
812             \# (?>[^\n]*) $ |
813             \[ (?>(?:[^\x81-\x9F\xE0-\xFC\\\]]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
814             \(\? |
815             $q_char
816             ))/oxmsg;
817             }
818              
819             # without /x modifier
820             else {
821 0         0 @char = $pattern =~ /\G((?>
822             [^\x81-\x9F\xE0-\xFC\\\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
823             \\ $q_char |
824             \[ (?>(?:[^\x81-\x9F\xE0-\xFC\\\]]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
825             \(\? |
826             $q_char
827             ))/oxmsg;
828             }
829              
830 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
831             }
832              
833             #
834             # ShiftJIS transliteration (tr///)
835             #
836             sub Esjis::tr($$$$;$) {
837              
838 0     0 0 0 my $bind_operator = $_[1];
839 0         0 my $searchlist = $_[2];
840 0         0 my $replacementlist = $_[3];
841 0   0     0 my $modifier = $_[4] || '';
842              
843 0 0       0 if ($modifier =~ /r/oxms) {
844 0 0       0 if ($bind_operator =~ / !~ /oxms) {
845 0         0 croak "Using !~ with tr///r doesn't make sense";
846             }
847             }
848              
849 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
850 0         0 my @searchlist = _charlist_tr($searchlist);
851 0         0 my @replacementlist = _charlist_tr($replacementlist);
852              
853 0         0 my %tr = ();
854 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
855 0 0       0 if (not exists $tr{$searchlist[$i]}) {
856 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
857 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
858             }
859             elsif ($modifier =~ /d/oxms) {
860 0         0 $tr{$searchlist[$i]} = '';
861             }
862             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
863 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
864             }
865             else {
866 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
867             }
868             }
869             }
870              
871 0         0 my $tr = 0;
872 0         0 my $replaced = '';
873 0 0       0 if ($modifier =~ /c/oxms) {
874 0         0 while (defined(my $char = shift @char)) {
875 0 0       0 if (not exists $tr{$char}) {
876 0 0       0 if (defined $replacementlist[-1]) {
877 0         0 $replaced .= $replacementlist[-1];
878             }
879 0         0 $tr++;
880 0 0       0 if ($modifier =~ /s/oxms) {
881 0   0     0 while (@char and (not exists $tr{$char[0]})) {
882 0         0 shift @char;
883 0         0 $tr++;
884             }
885             }
886             }
887             else {
888 0         0 $replaced .= $char;
889             }
890             }
891             }
892             else {
893 0         0 while (defined(my $char = shift @char)) {
894 0 0       0 if (exists $tr{$char}) {
895 0         0 $replaced .= $tr{$char};
896 0         0 $tr++;
897 0 0       0 if ($modifier =~ /s/oxms) {
898 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
899 0         0 shift @char;
900 0         0 $tr++;
901             }
902             }
903             }
904             else {
905 0         0 $replaced .= $char;
906             }
907             }
908             }
909              
910 0 0       0 if ($modifier =~ /r/oxms) {
911 0         0 return $replaced;
912             }
913             else {
914 0         0 $_[0] = $replaced;
915 0 0       0 if ($bind_operator =~ / !~ /oxms) {
916 0         0 return not $tr;
917             }
918             else {
919 0         0 return $tr;
920             }
921             }
922             }
923              
924             #
925             # ShiftJIS chop
926             #
927             sub Esjis::chop(@) {
928              
929 0     0 0 0 my $chop;
930 0 0       0 if (@_ == 0) {
931 0         0 my @char = /\G (?>$q_char) /oxmsg;
932 0         0 $chop = pop @char;
933 0         0 $_ = join '', @char;
934             }
935             else {
936 0         0 for (@_) {
937 0         0 my @char = /\G (?>$q_char) /oxmsg;
938 0         0 $chop = pop @char;
939 0         0 $_ = join '', @char;
940             }
941             }
942 0         0 return $chop;
943             }
944              
945             #
946             # ShiftJIS index by octet
947             #
948             sub Esjis::index($$;$) {
949              
950 0     2316 1 0 my($str,$substr,$position) = @_;
951 2316   50     4890 $position ||= 0;
952 2316         8709 my $pos = 0;
953              
954 2316         2882 while ($pos < CORE::length($str)) {
955 2316 50       5498 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
956 41020 0       62128 if ($pos >= $position) {
957 0         0 return $pos;
958             }
959             }
960 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
961 41020         107723 $pos += CORE::length($1);
962             }
963             else {
964 41020         72659 $pos += 1;
965             }
966             }
967 0         0 return -1;
968             }
969              
970             #
971             # ShiftJIS reverse index
972             #
973             sub Esjis::rindex($$;$) {
974              
975 2316     0 0 13306 my($str,$substr,$position) = @_;
976 0   0     0 $position ||= CORE::length($str) - 1;
977 0         0 my $pos = 0;
978 0         0 my $rindex = -1;
979              
980 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
981 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
982 0         0 $rindex = $pos;
983             }
984 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
985 0         0 $pos += CORE::length($1);
986             }
987             else {
988 0         0 $pos += 1;
989             }
990             }
991 0         0 return $rindex;
992             }
993              
994             #
995             # ShiftJIS lower case first with parameter
996             #
997             sub Esjis::lcfirst(@) {
998 0 0   0 0 0 if (@_) {
999 0         0 my $s = shift @_;
1000 0 0 0     0 if (@_ and wantarray) {
1001 0         0 return Esjis::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1002             }
1003             else {
1004 0         0 return Esjis::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1005             }
1006             }
1007             else {
1008 0         0 return Esjis::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1009             }
1010             }
1011              
1012             #
1013             # ShiftJIS lower case first without parameter
1014             #
1015             sub Esjis::lcfirst_() {
1016 0     0 0 0 return Esjis::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1017             }
1018              
1019             #
1020             # ShiftJIS lower case with parameter
1021             #
1022             sub Esjis::lc(@) {
1023 0 0   0 0 0 if (@_) {
1024 0         0 my $s = shift @_;
1025 0 0 0     0 if (@_ and wantarray) {
1026 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1027             }
1028             else {
1029 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1030             }
1031             }
1032             else {
1033 0         0 return Esjis::lc_();
1034             }
1035             }
1036              
1037             #
1038             # ShiftJIS lower case without parameter
1039             #
1040             sub Esjis::lc_() {
1041 0     0 0 0 my $s = $_;
1042 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1043             }
1044              
1045             #
1046             # ShiftJIS upper case first with parameter
1047             #
1048             sub Esjis::ucfirst(@) {
1049 0 0   0 0 0 if (@_) {
1050 0         0 my $s = shift @_;
1051 0 0 0     0 if (@_ and wantarray) {
1052 0         0 return Esjis::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1053             }
1054             else {
1055 0         0 return Esjis::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1056             }
1057             }
1058             else {
1059 0         0 return Esjis::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1060             }
1061             }
1062              
1063             #
1064             # ShiftJIS upper case first without parameter
1065             #
1066             sub Esjis::ucfirst_() {
1067 0     0 0 0 return Esjis::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1068             }
1069              
1070             #
1071             # ShiftJIS upper case with parameter
1072             #
1073             sub Esjis::uc(@) {
1074 0 50   3628 0 0 if (@_) {
1075 3628         5256 my $s = shift @_;
1076 3628 50 33     4416 if (@_ and wantarray) {
1077 3628 0       6306 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1078             }
1079             else {
1080 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3628         10273  
1081             }
1082             }
1083             else {
1084 3628         12090 return Esjis::uc_();
1085             }
1086             }
1087              
1088             #
1089             # ShiftJIS upper case without parameter
1090             #
1091             sub Esjis::uc_() {
1092 0     0 0 0 my $s = $_;
1093 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1094             }
1095              
1096             #
1097             # ShiftJIS fold case with parameter
1098             #
1099             sub Esjis::fc(@) {
1100 0 50   3931 0 0 if (@_) {
1101 3931         5848 my $s = shift @_;
1102 3931 50 33     4854 if (@_ and wantarray) {
1103 3931 0       6767 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1104             }
1105             else {
1106 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3931         9553  
1107             }
1108             }
1109             else {
1110 3931         14308 return Esjis::fc_();
1111             }
1112             }
1113              
1114             #
1115             # ShiftJIS fold case without parameter
1116             #
1117             sub Esjis::fc_() {
1118 0     0 0 0 my $s = $_;
1119 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1120             }
1121              
1122             #
1123             # ShiftJIS regexp capture
1124             #
1125             {
1126             # 10.3. Creating Persistent Private Variables
1127             # in Chapter 10. Subroutines
1128             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1129              
1130             my $last_s_matched = 0;
1131              
1132             sub Esjis::capture {
1133 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1134 0         0 return $_[0] + 1;
1135             }
1136 0         0 return $_[0];
1137             }
1138              
1139             # ShiftJIS mark last regexp matched
1140             sub Esjis::matched() {
1141 0     0 0 0 $last_s_matched = 0;
1142             }
1143              
1144             # ShiftJIS mark last s/// matched
1145             sub Esjis::s_matched() {
1146 0     0 0 0 $last_s_matched = 1;
1147             }
1148              
1149             # P.854 31.17. use re
1150             # in Chapter 31. Pragmatic Modules
1151             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1152              
1153             # P.1026 re
1154             # in Chapter 29. Pragmatic Modules
1155             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1156              
1157             $Esjis::matched = qr/(?{Esjis::matched})/;
1158             }
1159              
1160             #
1161             # ShiftJIS regexp ignore case modifier
1162             #
1163             sub Esjis::ignorecase {
1164              
1165 0     0 0 0 my @string = @_;
1166 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1167              
1168             # ignore case of $scalar or @array
1169 0         0 for my $string (@string) {
1170              
1171             # split regexp
1172 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1173              
1174             # unescape character
1175 0         0 for (my $i=0; $i <= $#char; $i++) {
1176 0 0       0 next if not defined $char[$i];
1177              
1178             # open character class [...]
1179 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1180 0         0 my $left = $i;
1181              
1182             # [] make die "unmatched [] in regexp ...\n"
1183              
1184 0 0       0 if ($char[$i+1] eq ']') {
1185 0         0 $i++;
1186             }
1187              
1188 0         0 while (1) {
1189 0 0       0 if (++$i > $#char) {
1190 0         0 croak "Unmatched [] in regexp";
1191             }
1192 0 0       0 if ($char[$i] eq ']') {
1193 0         0 my $right = $i;
1194 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1195              
1196             # escape character
1197 0         0 for my $char (@charlist) {
1198 0 0       0 if (0) {
    0          
1199             }
1200              
1201             # do not use quotemeta here
1202 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1203 0         0 $char = $1 . '\\' . $2;
1204             }
1205             elsif ($char =~ /\A [.|)] \z/oxms) {
1206 0         0 $char = '\\' . $char;
1207             }
1208             }
1209              
1210             # [...]
1211 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1212              
1213 0         0 $i = $left;
1214 0         0 last;
1215             }
1216             }
1217             }
1218              
1219             # open character class [^...]
1220             elsif ($char[$i] eq '[^') {
1221 0         0 my $left = $i;
1222              
1223             # [^] make die "unmatched [] in regexp ...\n"
1224              
1225 0 0       0 if ($char[$i+1] eq ']') {
1226 0         0 $i++;
1227             }
1228              
1229 0         0 while (1) {
1230 0 0       0 if (++$i > $#char) {
1231 0         0 croak "Unmatched [] in regexp";
1232             }
1233 0 0       0 if ($char[$i] eq ']') {
1234 0         0 my $right = $i;
1235 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1236              
1237             # escape character
1238 0         0 for my $char (@charlist) {
1239 0 0       0 if (0) {
    0          
1240             }
1241              
1242             # do not use quotemeta here
1243 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1244 0         0 $char = $1 . '\\' . $2;
1245             }
1246             elsif ($char =~ /\A [.|)] \z/oxms) {
1247 0         0 $char = '\\' . $char;
1248             }
1249             }
1250              
1251             # [^...]
1252 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1253              
1254 0         0 $i = $left;
1255 0         0 last;
1256             }
1257             }
1258             }
1259              
1260             # rewrite classic character class or escape character
1261             elsif (my $char = classic_character_class($char[$i])) {
1262 0         0 $char[$i] = $char;
1263             }
1264              
1265             # with /i modifier
1266             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1267 0         0 my $uc = Esjis::uc($char[$i]);
1268 0         0 my $fc = Esjis::fc($char[$i]);
1269 0 0       0 if ($uc ne $fc) {
1270 0 0       0 if (CORE::length($fc) == 1) {
1271 0         0 $char[$i] = '[' . $uc . $fc . ']';
1272             }
1273             else {
1274 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1275             }
1276             }
1277             }
1278             }
1279              
1280             # characterize
1281 0         0 for (my $i=0; $i <= $#char; $i++) {
1282 0 0       0 next if not defined $char[$i];
1283              
1284 0 0 0     0 if (0) {
    0          
1285             }
1286              
1287             # escape last octet of multiple-octet
1288 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1289 0         0 $char[$i] = $1 . '\\' . $2;
1290             }
1291              
1292             # quote character before ? + * {
1293             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1294 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1295 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1296             }
1297             }
1298             }
1299              
1300 0         0 $string = join '', @char;
1301             }
1302              
1303             # make regexp string
1304 0         0 return @string;
1305             }
1306              
1307             #
1308             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1309             #
1310             sub Esjis::classic_character_class {
1311 0     5243 0 0 my($char) = @_;
1312              
1313             return {
1314             '\D' => '${Esjis::eD}',
1315             '\S' => '${Esjis::eS}',
1316             '\W' => '${Esjis::eW}',
1317             '\d' => '[0-9]',
1318              
1319             # Before Perl 5.6, \s only matched the five whitespace characters
1320             # tab, newline, form-feed, carriage return, and the space character
1321             # itself, which, taken together, is the character class [\t\n\f\r ].
1322              
1323             # Vertical tabs are now whitespace
1324             # \s in a regex now matches a vertical tab in all circumstances.
1325             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1326             # \t \n \v \f \r space
1327             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1328             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1329             '\s' => '\s',
1330              
1331             '\w' => '[0-9A-Z_a-z]',
1332             '\C' => '[\x00-\xFF]',
1333             '\X' => 'X',
1334              
1335             # \h \v \H \V
1336              
1337             # P.114 Character Class Shortcuts
1338             # in Chapter 7: In the World of Regular Expressions
1339             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1340              
1341             # P.357 13.2.3 Whitespace
1342             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1343             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1344             #
1345             # 0x00009 CHARACTER TABULATION h s
1346             # 0x0000a LINE FEED (LF) vs
1347             # 0x0000b LINE TABULATION v
1348             # 0x0000c FORM FEED (FF) vs
1349             # 0x0000d CARRIAGE RETURN (CR) vs
1350             # 0x00020 SPACE h s
1351              
1352             # P.196 Table 5-9. Alphanumeric regex metasymbols
1353             # in Chapter 5. Pattern Matching
1354             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1355              
1356             # (and so on)
1357              
1358             '\H' => '${Esjis::eH}',
1359             '\V' => '${Esjis::eV}',
1360             '\h' => '[\x09\x20]',
1361             '\v' => '[\x0A\x0B\x0C\x0D]',
1362             '\R' => '${Esjis::eR}',
1363              
1364             # \N
1365             #
1366             # http://perldoc.perl.org/perlre.html
1367             # Character Classes and other Special Escapes
1368             # Any character but \n (experimental). Not affected by /s modifier
1369              
1370             '\N' => '${Esjis::eN}',
1371              
1372             # \b \B
1373              
1374             # P.180 Boundaries: The \b and \B Assertions
1375             # in Chapter 5: Pattern Matching
1376             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1377              
1378             # P.219 Boundaries: The \b and \B Assertions
1379             # in Chapter 5: Pattern Matching
1380             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1381              
1382             # \b really means (?:(?<=\w)(?!\w)|(?
1383             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1384             '\b' => '${Esjis::eb}',
1385              
1386             # \B really means (?:(?<=\w)(?=\w)|(?
1387             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1388             '\B' => '${Esjis::eB}',
1389              
1390 5243   100     7553 }->{$char} || '';
1391             }
1392              
1393             #
1394             # prepare ShiftJIS characters per length
1395             #
1396              
1397             # 1 octet characters
1398             my @chars1 = ();
1399             sub chars1 {
1400 5243 0   0 0 169644 if (@chars1) {
1401 0         0 return @chars1;
1402             }
1403 0 0       0 if (exists $range_tr{1}) {
1404 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1405 0         0 while (my @range = splice(@ranges,0,1)) {
1406 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1407 0         0 push @chars1, pack 'C', $oct0;
1408             }
1409             }
1410             }
1411 0         0 return @chars1;
1412             }
1413              
1414             # 2 octets characters
1415             my @chars2 = ();
1416             sub chars2 {
1417 0 0   0 0 0 if (@chars2) {
1418 0         0 return @chars2;
1419             }
1420 0 0       0 if (exists $range_tr{2}) {
1421 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1422 0         0 while (my @range = splice(@ranges,0,2)) {
1423 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1424 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1425 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1426             }
1427             }
1428             }
1429             }
1430 0         0 return @chars2;
1431             }
1432              
1433             # 3 octets characters
1434             my @chars3 = ();
1435             sub chars3 {
1436 0 0   0 0 0 if (@chars3) {
1437 0         0 return @chars3;
1438             }
1439 0 0       0 if (exists $range_tr{3}) {
1440 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1441 0         0 while (my @range = splice(@ranges,0,3)) {
1442 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1443 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1444 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1445 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1446             }
1447             }
1448             }
1449             }
1450             }
1451 0         0 return @chars3;
1452             }
1453              
1454             # 4 octets characters
1455             my @chars4 = ();
1456             sub chars4 {
1457 0 0   0 0 0 if (@chars4) {
1458 0         0 return @chars4;
1459             }
1460 0 0       0 if (exists $range_tr{4}) {
1461 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1462 0         0 while (my @range = splice(@ranges,0,4)) {
1463 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1464 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1465 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1466 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1467 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1468             }
1469             }
1470             }
1471             }
1472             }
1473             }
1474 0         0 return @chars4;
1475             }
1476              
1477             #
1478             # ShiftJIS open character list for tr
1479             #
1480             sub _charlist_tr {
1481              
1482 0     0   0 local $_ = shift @_;
1483              
1484             # unescape character
1485 0         0 my @char = ();
1486 0         0 while (not /\G \z/oxmsgc) {
1487 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1488 0         0 push @char, '\-';
1489             }
1490             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1491 0         0 push @char, CORE::chr(oct $1);
1492             }
1493             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1494 0         0 push @char, CORE::chr(hex $1);
1495             }
1496             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1497 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1498             }
1499             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1500             push @char, {
1501             '\0' => "\0",
1502             '\n' => "\n",
1503             '\r' => "\r",
1504             '\t' => "\t",
1505             '\f' => "\f",
1506             '\b' => "\x08", # \b means backspace in character class
1507             '\a' => "\a",
1508             '\e' => "\e",
1509 0         0 }->{$1};
1510             }
1511             elsif (/\G \\ ($q_char) /oxmsgc) {
1512 0         0 push @char, $1;
1513             }
1514             elsif (/\G ($q_char) /oxmsgc) {
1515 0         0 push @char, $1;
1516             }
1517             }
1518              
1519             # join separated multiple-octet
1520 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1521              
1522             # unescape '-'
1523 0         0 my @i = ();
1524 0         0 for my $i (0 .. $#char) {
1525 0 0       0 if ($char[$i] eq '\-') {
    0          
1526 0         0 $char[$i] = '-';
1527             }
1528             elsif ($char[$i] eq '-') {
1529 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1530 0         0 push @i, $i;
1531             }
1532             }
1533             }
1534              
1535             # open character list (reverse for splice)
1536 0         0 for my $i (CORE::reverse @i) {
1537 0         0 my @range = ();
1538              
1539             # range error
1540 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1541 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1542             }
1543              
1544             # range of multiple-octet code
1545 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1546 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1547 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1548             }
1549             elsif (CORE::length($char[$i+1]) == 2) {
1550 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1551 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1552             }
1553             elsif (CORE::length($char[$i+1]) == 3) {
1554 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1555 0         0 push @range, chars2();
1556 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1557             }
1558             elsif (CORE::length($char[$i+1]) == 4) {
1559 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1560 0         0 push @range, chars2();
1561 0         0 push @range, chars3();
1562 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1563             }
1564             else {
1565 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1566             }
1567             }
1568             elsif (CORE::length($char[$i-1]) == 2) {
1569 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1570 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1571             }
1572             elsif (CORE::length($char[$i+1]) == 3) {
1573 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1574 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1575             }
1576             elsif (CORE::length($char[$i+1]) == 4) {
1577 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1578 0         0 push @range, chars3();
1579 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1580             }
1581             else {
1582 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1583             }
1584             }
1585             elsif (CORE::length($char[$i-1]) == 3) {
1586 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1587 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1588             }
1589             elsif (CORE::length($char[$i+1]) == 4) {
1590 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1591 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1592             }
1593             else {
1594 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1595             }
1596             }
1597             elsif (CORE::length($char[$i-1]) == 4) {
1598 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1599 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1600             }
1601             else {
1602 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1603             }
1604             }
1605             else {
1606 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1607             }
1608              
1609 0         0 splice @char, $i-1, 3, @range;
1610             }
1611              
1612 0         0 return @char;
1613             }
1614              
1615             #
1616             # ShiftJIS open character class
1617             #
1618             sub _cc {
1619 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1620 604         1219 die __FILE__, ": subroutine cc got no parameter.\n";
1621             }
1622             elsif (scalar(@_) == 1) {
1623 0         0 return sprintf('\x%02X',$_[0]);
1624             }
1625             elsif (scalar(@_) == 2) {
1626 302 50       943 if ($_[0] > $_[1]) {
    50          
    50          
1627 302         667 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1628             }
1629             elsif ($_[0] == $_[1]) {
1630 0         0 return sprintf('\x%02X',$_[0]);
1631             }
1632             elsif (($_[0]+1) == $_[1]) {
1633 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1634             }
1635             else {
1636 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1637             }
1638             }
1639             else {
1640 302         1540 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1641             }
1642             }
1643              
1644             #
1645             # ShiftJIS octet range
1646             #
1647             sub _octets {
1648 0     688   0 my $length = shift @_;
1649              
1650 688 100       1044 if ($length == 1) {
    50          
    0          
    0          
1651 688         1425 my($a1) = unpack 'C', $_[0];
1652 426         1054 my($z1) = unpack 'C', $_[1];
1653              
1654 426 50       722 if ($a1 > $z1) {
1655 426         806 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1656             }
1657              
1658 0 50       0 if ($a1 == $z1) {
    50          
1659 426         1060 return sprintf('\x%02X',$a1);
1660             }
1661             elsif (($a1+1) == $z1) {
1662 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1663             }
1664             else {
1665 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1666             }
1667             }
1668             elsif ($length == 2) {
1669 426         2586 my($a1,$a2) = unpack 'CC', $_[0];
1670 262         597 my($z1,$z2) = unpack 'CC', $_[1];
1671 262         432 my($A1,$A2) = unpack 'CC', $_[2];
1672 262         388 my($Z1,$Z2) = unpack 'CC', $_[3];
1673              
1674 262 100       388 if ($a1 == $z1) {
    50          
1675             return (
1676             # 11111111 222222222222
1677             # A A Z
1678 262         415 _cc($a1) . _cc($a2,$z2), # a2-z2
1679             );
1680             }
1681             elsif (($a1+1) == $z1) {
1682             return (
1683             # 11111111111 222222222222
1684             # A Z A Z
1685 222         356 _cc($a1) . _cc($a2,$Z2), # a2-
1686             _cc( $z1) . _cc($A2,$z2), # -z2
1687             );
1688             }
1689             else {
1690             return (
1691             # 1111111111111111 222222222222
1692             # A Z A Z
1693 40         78 _cc($a1) . _cc($a2,$Z2), # a2-
1694             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1695             _cc( $z1) . _cc($A2,$z2), # -z2
1696             );
1697             }
1698             }
1699             elsif ($length == 3) {
1700 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1701 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1702 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1703 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1704              
1705 0 0       0 if ($a1 == $z1) {
    0          
1706 0 0       0 if ($a2 == $z2) {
    0          
1707             return (
1708             # 11111111 22222222 333333333333
1709             # A A A Z
1710 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1711             );
1712             }
1713             elsif (($a2+1) == $z2) {
1714             return (
1715             # 11111111 22222222222 333333333333
1716             # A A Z A Z
1717 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1718             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1719             );
1720             }
1721             else {
1722             return (
1723             # 11111111 2222222222222222 333333333333
1724             # A A Z A Z
1725 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1726             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1727             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1728             );
1729             }
1730             }
1731             elsif (($a1+1) == $z1) {
1732             return (
1733             # 11111111111 22222222222222 333333333333
1734             # A Z A Z A Z
1735 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1736             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1737             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1738             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1739             );
1740             }
1741             else {
1742             return (
1743             # 1111111111111111 22222222222222 333333333333
1744             # A Z A Z A Z
1745 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1746             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1747             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1748             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1749             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1750             );
1751             }
1752             }
1753             elsif ($length == 4) {
1754 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1755 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1756 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1757 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1758              
1759 0 0       0 if ($a1 == $z1) {
    0          
1760 0 0       0 if ($a2 == $z2) {
    0          
1761 0 0       0 if ($a3 == $z3) {
    0          
1762             return (
1763             # 11111111 22222222 33333333 444444444444
1764             # A A A A Z
1765 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1766             );
1767             }
1768             elsif (($a3+1) == $z3) {
1769             return (
1770             # 11111111 22222222 33333333333 444444444444
1771             # A A A Z A Z
1772 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1773             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1774             );
1775             }
1776             else {
1777             return (
1778             # 11111111 22222222 3333333333333333 444444444444
1779             # A A A Z A Z
1780 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1781             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1782             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1783             );
1784             }
1785             }
1786             elsif (($a2+1) == $z2) {
1787             return (
1788             # 11111111 22222222222 33333333333333 444444444444
1789             # A A Z A Z A Z
1790 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1791             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1792             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1793             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1794             );
1795             }
1796             else {
1797             return (
1798             # 11111111 2222222222222222 33333333333333 444444444444
1799             # A A Z A Z A Z
1800 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1801             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1802             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1803             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1804             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1805             );
1806             }
1807             }
1808             elsif (($a1+1) == $z1) {
1809             return (
1810             # 11111111111 22222222222222 33333333333333 444444444444
1811             # A Z A Z A Z A Z
1812 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1813             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1814             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1815             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1816             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1817             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1818             );
1819             }
1820             else {
1821             return (
1822             # 1111111111111111 22222222222222 33333333333333 444444444444
1823             # A Z A Z A Z A Z
1824 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1825             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1826             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1827             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1828             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1829             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1830             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1831             );
1832             }
1833             }
1834             else {
1835 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1836             }
1837             }
1838              
1839             #
1840             # ShiftJIS range regexp
1841             #
1842             sub _range_regexp {
1843 0     517   0 my($length,$first,$last) = @_;
1844              
1845 517         1044 my @range_regexp = ();
1846 517 50       657 if (not exists $range_tr{$length}) {
1847 517         1169 return @range_regexp;
1848             }
1849              
1850 0         0 my @ranges = @{ $range_tr{$length} };
  517         669  
1851 517         1170 while (my @range = splice(@ranges,0,$length)) {
1852 517         1488 my $min = '';
1853 1682         2262 my $max = '';
1854 1682         1784 for (my $i=0; $i < $length; $i++) {
1855 1682         2858 $min .= pack 'C', $range[$i][0];
1856 2206         4025 $max .= pack 'C', $range[$i][-1];
1857             }
1858              
1859             # min___max
1860             # FIRST_____________LAST
1861             # (nothing)
1862              
1863 2206 50 66     4071 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1864             }
1865              
1866             # **********
1867             # min_________max
1868             # FIRST_____________LAST
1869             # **********
1870              
1871             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1872 1682         13480 push @range_regexp, _octets($length,$first,$max,$min,$max);
1873             }
1874              
1875             # **********************
1876             # min________________max
1877             # FIRST_____________LAST
1878             # **********************
1879              
1880             elsif (($min eq $first) and ($max eq $last)) {
1881 20         92 push @range_regexp, _octets($length,$first,$last,$min,$max);
1882             }
1883              
1884             # *********
1885             # min___max
1886             # FIRST_____________LAST
1887             # *********
1888              
1889             elsif (($first le $min) and ($max le $last)) {
1890 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1891             }
1892              
1893             # **********************
1894             # min__________________________max
1895             # FIRST_____________LAST
1896             # **********************
1897              
1898             elsif (($min le $first) and ($last le $max)) {
1899 40         73 push @range_regexp, _octets($length,$first,$last,$min,$max);
1900             }
1901              
1902             # *********
1903             # min________max
1904             # FIRST_____________LAST
1905             # *********
1906              
1907             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1908 588         1311 push @range_regexp, _octets($length,$min,$last,$min,$max);
1909             }
1910              
1911             # min___max
1912             # FIRST_____________LAST
1913             # (nothing)
1914              
1915             elsif ($last lt $min) {
1916             }
1917              
1918             else {
1919 40         72 die __FILE__, ": subroutine _range_regexp panic.\n";
1920             }
1921             }
1922              
1923 0         0 return @range_regexp;
1924             }
1925              
1926             #
1927             # ShiftJIS open character list for qr and not qr
1928             #
1929             sub _charlist {
1930              
1931 517     758   1194 my $modifier = pop @_;
1932 758         1100 my @char = @_;
1933              
1934 758 100       1684 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1935              
1936             # unescape character
1937 758         1633 for (my $i=0; $i <= $#char; $i++) {
1938              
1939             # escape - to ...
1940 758 100 100     2159 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1941 2648 100 100     18001 if ((0 < $i) and ($i < $#char)) {
1942 522         1837 $char[$i] = '...';
1943             }
1944             }
1945              
1946             # octal escape sequence
1947             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1948 497         1001 $char[$i] = octchr($1);
1949             }
1950              
1951             # hexadecimal escape sequence
1952             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1953 0         0 $char[$i] = hexchr($1);
1954             }
1955              
1956             # \b{...} --> b\{...}
1957             # \B{...} --> B\{...}
1958             # \N{CHARNAME} --> N\{CHARNAME}
1959             # \p{PROPERTY} --> p\{PROPERTY}
1960             # \P{PROPERTY} --> P\{PROPERTY}
1961             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} ) \z/oxms) {
1962 0         0 $char[$i] = $1 . '\\' . $2;
1963             }
1964              
1965             # \p, \P, \X --> p, P, X
1966             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1967 0         0 $char[$i] = $1;
1968             }
1969              
1970             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1971 0         0 $char[$i] = CORE::chr oct $1;
1972             }
1973             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1974 0         0 $char[$i] = CORE::chr hex $1;
1975             }
1976             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1977 206         813 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1978             }
1979             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1980             $char[$i] = {
1981             '\0' => "\0",
1982             '\n' => "\n",
1983             '\r' => "\r",
1984             '\t' => "\t",
1985             '\f' => "\f",
1986             '\b' => "\x08", # \b means backspace in character class
1987             '\a' => "\a",
1988             '\e' => "\e",
1989             '\d' => '[0-9]',
1990              
1991             # Vertical tabs are now whitespace
1992             # \s in a regex now matches a vertical tab in all circumstances.
1993             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1994             # \t \n \v \f \r space
1995             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1996             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1997             '\s' => '\s',
1998              
1999             '\w' => '[0-9A-Z_a-z]',
2000             '\D' => '${Esjis::eD}',
2001             '\S' => '${Esjis::eS}',
2002             '\W' => '${Esjis::eW}',
2003              
2004             '\H' => '${Esjis::eH}',
2005             '\V' => '${Esjis::eV}',
2006             '\h' => '[\x09\x20]',
2007             '\v' => '[\x0A\x0B\x0C\x0D]',
2008             '\R' => '${Esjis::eR}',
2009              
2010 0         0 }->{$1};
2011             }
2012              
2013             # POSIX-style character classes
2014             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2015             $char[$i] = {
2016              
2017             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2018             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2019             '[:^lower:]' => '${Esjis::not_lower_i}',
2020             '[:^upper:]' => '${Esjis::not_upper_i}',
2021              
2022 33         518 }->{$1};
2023             }
2024             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2025             $char[$i] = {
2026              
2027             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2028             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2029             '[:ascii:]' => '[\x00-\x7F]',
2030             '[:blank:]' => '[\x09\x20]',
2031             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2032             '[:digit:]' => '[\x30-\x39]',
2033             '[:graph:]' => '[\x21-\x7F]',
2034             '[:lower:]' => '[\x61-\x7A]',
2035             '[:print:]' => '[\x20-\x7F]',
2036             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2037              
2038             # P.174 POSIX-Style Character Classes
2039             # in Chapter 5: Pattern Matching
2040             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2041              
2042             # P.311 11.2.4 Character Classes and other Special Escapes
2043             # in Chapter 11: perlre: Perl regular expressions
2044             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2045              
2046             # P.210 POSIX-Style Character Classes
2047             # in Chapter 5: Pattern Matching
2048             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2049              
2050             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2051              
2052             '[:upper:]' => '[\x41-\x5A]',
2053             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2054             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2055             '[:^alnum:]' => '${Esjis::not_alnum}',
2056             '[:^alpha:]' => '${Esjis::not_alpha}',
2057             '[:^ascii:]' => '${Esjis::not_ascii}',
2058             '[:^blank:]' => '${Esjis::not_blank}',
2059             '[:^cntrl:]' => '${Esjis::not_cntrl}',
2060             '[:^digit:]' => '${Esjis::not_digit}',
2061             '[:^graph:]' => '${Esjis::not_graph}',
2062             '[:^lower:]' => '${Esjis::not_lower}',
2063             '[:^print:]' => '${Esjis::not_print}',
2064             '[:^punct:]' => '${Esjis::not_punct}',
2065             '[:^space:]' => '${Esjis::not_space}',
2066             '[:^upper:]' => '${Esjis::not_upper}',
2067             '[:^word:]' => '${Esjis::not_word}',
2068             '[:^xdigit:]' => '${Esjis::not_xdigit}',
2069              
2070 8         65 }->{$1};
2071             }
2072             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2073 70         1467 $char[$i] = $1;
2074             }
2075             }
2076              
2077             # open character list
2078 7         37 my @singleoctet = ();
2079 758         1243 my @multipleoctet = ();
2080 758         1036 for (my $i=0; $i <= $#char; ) {
2081              
2082             # escaped -
2083 758 100 100     1572 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2084 2151         8558 $i += 1;
2085 497         608 next;
2086             }
2087              
2088             # make range regexp
2089             elsif ($char[$i] eq '...') {
2090              
2091             # range error
2092 497 50       922 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2093 497         1709 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2094             }
2095             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2096 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2097 477         1100 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2098             }
2099             }
2100              
2101             # make range regexp per length
2102 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2103 497         1327 my @regexp = ();
2104              
2105             # is first and last
2106 517 100 100     701 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2107 517         1758 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2108             }
2109              
2110             # is first
2111             elsif ($length == CORE::length($char[$i-1])) {
2112 477         1173 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2113             }
2114              
2115             # is inside in first and last
2116             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2117 20         76 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2118             }
2119              
2120             # is last
2121             elsif ($length == CORE::length($char[$i+1])) {
2122 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2123             }
2124              
2125             else {
2126 20         64 die __FILE__, ": subroutine make_regexp panic.\n";
2127             }
2128              
2129 0 100       0 if ($length == 1) {
2130 517         1075 push @singleoctet, @regexp;
2131             }
2132             else {
2133 386         1072 push @multipleoctet, @regexp;
2134             }
2135             }
2136              
2137 131         323 $i += 2;
2138             }
2139              
2140             # with /i modifier
2141             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2142 497 100       1381 if ($modifier =~ /i/oxms) {
2143 764         1230 my $uc = Esjis::uc($char[$i]);
2144 192         287 my $fc = Esjis::fc($char[$i]);
2145 192 50       314 if ($uc ne $fc) {
2146 192 50       273 if (CORE::length($fc) == 1) {
2147 192         242 push @singleoctet, $uc, $fc;
2148             }
2149             else {
2150 192         351 push @singleoctet, $uc;
2151 0         0 push @multipleoctet, $fc;
2152             }
2153             }
2154             else {
2155 0         0 push @singleoctet, $char[$i];
2156             }
2157             }
2158             else {
2159 0         0 push @singleoctet, $char[$i];
2160             }
2161 572         926 $i += 1;
2162             }
2163              
2164             # single character of single octet code
2165             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2166 764         1284 push @singleoctet, "\t", "\x20";
2167 0         0 $i += 1;
2168             }
2169             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2170 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2171 0         0 $i += 1;
2172             }
2173             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2174 0         0 push @singleoctet, $char[$i];
2175 2         8 $i += 1;
2176             }
2177              
2178             # single character of multiple-octet code
2179             else {
2180 2         6 push @multipleoctet, $char[$i];
2181 391         709 $i += 1;
2182             }
2183             }
2184              
2185             # quote metachar
2186 391         673 for (@singleoctet) {
2187 758 50       1463 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2188 1384         5716 $_ = '-';
2189             }
2190             elsif (/\A \n \z/oxms) {
2191 0         0 $_ = '\n';
2192             }
2193             elsif (/\A \r \z/oxms) {
2194 8         17 $_ = '\r';
2195             }
2196             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2197 8         16 $_ = sprintf('\x%02X', CORE::ord $1);
2198             }
2199             elsif (/\A [\x00-\xFF] \z/oxms) {
2200 1         11 $_ = quotemeta $_;
2201             }
2202             }
2203 939         1416 for (@multipleoctet) {
2204 758 100       1314 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2205 693         1750 $_ = $1 . quotemeta $2;
2206             }
2207             }
2208              
2209             # return character list
2210 307         689 return \@singleoctet, \@multipleoctet;
2211             }
2212              
2213             #
2214             # ShiftJIS octal escape sequence
2215             #
2216             sub octchr {
2217 758     5 0 2488 my($octdigit) = @_;
2218              
2219 5         12 my @binary = ();
2220 5         8 for my $octal (split(//,$octdigit)) {
2221             push @binary, {
2222             '0' => '000',
2223             '1' => '001',
2224             '2' => '010',
2225             '3' => '011',
2226             '4' => '100',
2227             '5' => '101',
2228             '6' => '110',
2229             '7' => '111',
2230 5         30 }->{$octal};
2231             }
2232 50         182 my $binary = join '', @binary;
2233              
2234             my $octchr = {
2235             # 1234567
2236             1 => pack('B*', "0000000$binary"),
2237             2 => pack('B*', "000000$binary"),
2238             3 => pack('B*', "00000$binary"),
2239             4 => pack('B*', "0000$binary"),
2240             5 => pack('B*', "000$binary"),
2241             6 => pack('B*', "00$binary"),
2242             7 => pack('B*', "0$binary"),
2243             0 => pack('B*', "$binary"),
2244              
2245 5         16 }->{CORE::length($binary) % 8};
2246              
2247 5         53 return $octchr;
2248             }
2249              
2250             #
2251             # ShiftJIS hexadecimal escape sequence
2252             #
2253             sub hexchr {
2254 5     5 0 19 my($hexdigit) = @_;
2255              
2256             my $hexchr = {
2257             1 => pack('H*', "0$hexdigit"),
2258             0 => pack('H*', "$hexdigit"),
2259              
2260 5         14 }->{CORE::length($_[0]) % 2};
2261              
2262 5         36 return $hexchr;
2263             }
2264              
2265             #
2266             # ShiftJIS open character list for qr
2267             #
2268             sub charlist_qr {
2269              
2270 5     519 0 16 my $modifier = pop @_;
2271 519         1043 my @char = @_;
2272              
2273 519         1302 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2274 519         1547 my @singleoctet = @$singleoctet;
2275 519         1171 my @multipleoctet = @$multipleoctet;
2276              
2277             # return character list
2278 519 100       818 if (scalar(@singleoctet) >= 1) {
2279              
2280             # with /i modifier
2281 519 100       1142 if ($modifier =~ m/i/oxms) {
2282 384         918 my %singleoctet_ignorecase = ();
2283 107         141 for (@singleoctet) {
2284 107   66     145 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2285 277         840 for my $ord (hex($1) .. hex($2)) {
2286 85         283 my $char = CORE::chr($ord);
2287 1376         1906 my $uc = Esjis::uc($char);
2288 1376         1839 my $fc = Esjis::fc($char);
2289 1376 100       2096 if ($uc eq $fc) {
2290 1376         2115 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2291             }
2292             else {
2293 787 50       1893 if (CORE::length($fc) == 1) {
2294 589         822 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2295 589         1193 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2296             }
2297             else {
2298 589         1459 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2299 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2300             }
2301             }
2302             }
2303             }
2304 0 100       0 if ($_ ne '') {
2305 277         417 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2306             }
2307             }
2308 192         421 my $i = 0;
2309 107         199 my @singleoctet_ignorecase = ();
2310 107         140 for my $ord (0 .. 255) {
2311 107 100       173 if (exists $singleoctet_ignorecase{$ord}) {
2312 27392         30848 push @{$singleoctet_ignorecase[$i]}, $ord;
  1907         1728  
2313             }
2314             else {
2315 1907         3048 $i++;
2316             }
2317             }
2318 25485         24522 @singleoctet = ();
2319 107         177 for my $range (@singleoctet_ignorecase) {
2320 107 100       219 if (ref $range) {
2321 11082 50       16612 if (scalar(@{$range}) == 1) {
  219 50       217  
2322 219         334 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2323             }
2324 0         0 elsif (scalar(@{$range}) == 2) {
2325 219         278 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2326             }
2327             else {
2328 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  219         271  
  219         283  
2329             }
2330             }
2331             }
2332             }
2333              
2334 219         1036 my $not_anchor = '';
2335 384         599 $not_anchor = '(?![\x81-\x9F\xE0-\xFC])';
2336              
2337 384         527 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2338             }
2339 384 100       996 if (scalar(@multipleoctet) >= 2) {
2340 519         1052 return '(?:' . join('|', @multipleoctet) . ')';
2341             }
2342             else {
2343 131         853 return $multipleoctet[0];
2344             }
2345             }
2346              
2347             #
2348             # ShiftJIS open character list for not qr
2349             #
2350             sub charlist_not_qr {
2351              
2352 388     239 0 1815 my $modifier = pop @_;
2353 239         413 my @char = @_;
2354              
2355 239         552 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2356 239         519 my @singleoctet = @$singleoctet;
2357 239         485 my @multipleoctet = @$multipleoctet;
2358              
2359             # with /i modifier
2360 239 100       381 if ($modifier =~ m/i/oxms) {
2361 239         609 my %singleoctet_ignorecase = ();
2362 128         191 for (@singleoctet) {
2363 128   66     174 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2364 277         812 for my $ord (hex($1) .. hex($2)) {
2365 85         277 my $char = CORE::chr($ord);
2366 1376         1882 my $uc = Esjis::uc($char);
2367 1376         1841 my $fc = Esjis::fc($char);
2368 1376 100       2089 if ($uc eq $fc) {
2369 1376         2084 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2370             }
2371             else {
2372 787 50       1822 if (CORE::length($fc) == 1) {
2373 589         731 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2374 589         1248 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2375             }
2376             else {
2377 589         1422 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2378 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2379             }
2380             }
2381             }
2382             }
2383 0 100       0 if ($_ ne '') {
2384 277         404 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2385             }
2386             }
2387 192         417 my $i = 0;
2388 128         144 my @singleoctet_ignorecase = ();
2389 128         229 for my $ord (0 .. 255) {
2390 128 100       181 if (exists $singleoctet_ignorecase{$ord}) {
2391 32768         36669 push @{$singleoctet_ignorecase[$i]}, $ord;
  1907         1745  
2392             }
2393             else {
2394 1907         3082 $i++;
2395             }
2396             }
2397 30861         30042 @singleoctet = ();
2398 128         187 for my $range (@singleoctet_ignorecase) {
2399 128 100       254 if (ref $range) {
2400 11082 50       16649 if (scalar(@{$range}) == 1) {
  219 50       240  
2401 219         338 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
2402             }
2403 0         0 elsif (scalar(@{$range}) == 2) {
2404 219         271 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2405             }
2406             else {
2407 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  219         243  
  219         246  
2408             }
2409             }
2410             }
2411             }
2412              
2413             # return character list
2414 219 100       1015 if (scalar(@multipleoctet) >= 1) {
2415 239 100       514 if (scalar(@singleoctet) >= 1) {
2416              
2417             # any character other than multiple-octet and single octet character class
2418 114         166 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\x9F\xE0-\xFC' . join('', @singleoctet) . ']|[\x81-\x9F\xE0-\xFC][\x00-\xFF])';
2419             }
2420             else {
2421              
2422             # any character other than multiple-octet character class
2423 70         475 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2424             }
2425             }
2426             else {
2427 44 50       263 if (scalar(@singleoctet) >= 1) {
2428              
2429             # any character other than single octet character class
2430 125         216 return '(?:[^\x81-\x9F\xE0-\xFC' . join('', @singleoctet) . ']|[\x81-\x9F\xE0-\xFC][\x00-\xFF])';
2431             }
2432             else {
2433              
2434             # any character
2435 125         730 return "(?:$your_char)";
2436             }
2437             }
2438             }
2439              
2440             #
2441             # open file in read mode
2442             #
2443             sub _open_r {
2444 0     772   0 my(undef,$file) = @_;
2445 391     391   6215 use Fcntl qw(O_RDONLY);
  391         2395  
  391         61501  
2446 772         2275 return CORE::sysopen($_[0], $file, &O_RDONLY);
2447             }
2448              
2449             #
2450             # open file in append mode
2451             #
2452             sub _open_a {
2453 772     386   33862 my(undef,$file) = @_;
2454 391     391   4316 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  391         2573  
  391         6430485  
2455 386         1330 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2456             }
2457              
2458             #
2459             # safe system
2460             #
2461             sub _systemx {
2462              
2463             # P.707 29.2.33. exec
2464             # in Chapter 29: Functions
2465             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2466             #
2467             # Be aware that in older releases of Perl, exec (and system) did not flush
2468             # your output buffer, so you needed to enable command buffering by setting $|
2469             # on one or more filehandles to avoid lost output in the case of exec, or
2470             # misordererd output in the case of system. This situation was largely remedied
2471             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2472              
2473             # P.855 exec
2474             # in Chapter 27: Functions
2475             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2476             #
2477             # In very old release of Perl (before v5.6), exec (and system) did not flush
2478             # your output buffer, so you needed to enable command buffering by setting $|
2479             # on one or more filehandles to avoid lost output with exec or misordered
2480             # output with system.
2481              
2482 386     386   51391 $| = 1;
2483              
2484             # P.565 23.1.2. Cleaning Up Your Environment
2485             # in Chapter 23: Security
2486             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2487              
2488             # P.656 Cleaning Up Your Environment
2489             # in Chapter 20: Security
2490             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2491              
2492             # local $ENV{'PATH'} = '.';
2493 386         1840 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2494              
2495             # P.707 29.2.33. exec
2496             # in Chapter 29: Functions
2497             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2498             #
2499             # As we mentioned earlier, exec treats a discrete list of arguments as an
2500             # indication that it should bypass shell processing. However, there is one
2501             # place where you might still get tripped up. The exec call (and system, too)
2502             # will not distinguish between a single scalar argument and an array containing
2503             # only one element.
2504             #
2505             # @args = ("echo surprise"); # just one element in list
2506             # exec @args # still subject to shell escapes
2507             # or die "exec: $!"; # because @args == 1
2508             #
2509             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2510             # first argument as the pathname, which forces the rest of the arguments to be
2511             # interpreted as a list, even if there is only one of them:
2512             #
2513             # exec { $args[0] } @args # safe even with one-argument list
2514             # or die "can't exec @args: $!";
2515              
2516             # P.855 exec
2517             # in Chapter 27: Functions
2518             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2519             #
2520             # As we mentioned earlier, exec treats a discrete list of arguments as a
2521             # directive to bypass shell processing. However, there is one place where
2522             # you might still get tripped up. The exec call (and system, too) cannot
2523             # distinguish between a single scalar argument and an array containing
2524             # only one element.
2525             #
2526             # @args = ("echo surprise"); # just one element in list
2527             # exec @args # still subject to shell escapes
2528             # || die "exec: $!"; # because @args == 1
2529             #
2530             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2531             # argument as the pathname, which forces the rest of the arguments to be
2532             # interpreted as a list, even if there is only one of them:
2533             #
2534             # exec { $args[0] } @args # safe even with one-argument list
2535             # || die "can't exec @args: $!";
2536              
2537 386         4214 return CORE::system { $_[0] } @_; # safe even with one-argument list
  386         864  
2538             }
2539              
2540             #
2541             # ShiftJIS order to character (with parameter)
2542             #
2543             sub Esjis::chr(;$) {
2544              
2545 386 0   0 0 44704549 my $c = @_ ? $_[0] : $_;
2546              
2547 0 0       0 if ($c == 0x00) {
2548 0         0 return "\x00";
2549             }
2550             else {
2551 0         0 my @chr = ();
2552 0         0 while ($c > 0) {
2553 0         0 unshift @chr, ($c % 0x100);
2554 0         0 $c = int($c / 0x100);
2555             }
2556 0         0 return pack 'C*', @chr;
2557             }
2558             }
2559              
2560             #
2561             # ShiftJIS order to character (without parameter)
2562             #
2563             sub Esjis::chr_() {
2564              
2565 0     0 0 0 my $c = $_;
2566              
2567 0 0       0 if ($c == 0x00) {
2568 0         0 return "\x00";
2569             }
2570             else {
2571 0         0 my @chr = ();
2572 0         0 while ($c > 0) {
2573 0         0 unshift @chr, ($c % 0x100);
2574 0         0 $c = int($c / 0x100);
2575             }
2576 0         0 return pack 'C*', @chr;
2577             }
2578             }
2579              
2580             #
2581             # ShiftJIS stacked file test expr
2582             #
2583             sub Esjis::filetest {
2584              
2585 0     0 0 0 my $file = pop @_;
2586 0         0 my $filetest = substr(pop @_, 1);
2587              
2588 0 0       0 unless (CORE::eval qq{Esjis::$filetest(\$file)}) {
2589 0         0 return '';
2590             }
2591 0         0 for my $filetest (CORE::reverse @_) {
2592 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2593 0         0 return '';
2594             }
2595             }
2596 0         0 return 1;
2597             }
2598              
2599             #
2600             # ShiftJIS file test -r expr
2601             #
2602             sub Esjis::r(;*@) {
2603              
2604 0 0   0 0 0 local $_ = shift if @_;
2605 0 0 0     0 croak 'Too many arguments for -r (Esjis::r)' if @_ and not wantarray;
2606              
2607 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2608 0 0       0 return wantarray ? (-r _,@_) : -r _;
2609             }
2610              
2611             # P.908 32.39. Symbol
2612             # in Chapter 32: Standard Modules
2613             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2614              
2615             # P.326 Prototypes
2616             # in Chapter 7: Subroutines
2617             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2618              
2619             # (and so on)
2620              
2621             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2622 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2623             }
2624             elsif (-e $_) {
2625 0 0       0 return wantarray ? (-r _,@_) : -r _;
2626             }
2627             elsif (_MSWin32_5Cended_path($_)) {
2628 0 0       0 if (-d "$_/.") {
2629 0 0       0 return wantarray ? (-r _,@_) : -r _;
2630             }
2631             else {
2632              
2633             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Esjis::*()
2634             # on Windows opens the file for the path which has 5c at end.
2635             # (and so on)
2636              
2637 0         0 my $fh = gensym();
2638 0 0       0 if (_open_r($fh, $_)) {
2639 0         0 my $r = -r $fh;
2640 0 0       0 close($fh) or die "Can't close file: $_: $!";
2641 0 0       0 return wantarray ? ($r,@_) : $r;
2642             }
2643             }
2644             }
2645 0 0       0 return wantarray ? (undef,@_) : undef;
2646             }
2647              
2648             #
2649             # ShiftJIS file test -w expr
2650             #
2651             sub Esjis::w(;*@) {
2652              
2653 0 0   0 0 0 local $_ = shift if @_;
2654 0 0 0     0 croak 'Too many arguments for -w (Esjis::w)' if @_ and not wantarray;
2655              
2656 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2657 0 0       0 return wantarray ? (-w _,@_) : -w _;
2658             }
2659             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2660 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2661             }
2662             elsif (-e $_) {
2663 0 0       0 return wantarray ? (-w _,@_) : -w _;
2664             }
2665             elsif (_MSWin32_5Cended_path($_)) {
2666 0 0       0 if (-d "$_/.") {
2667 0 0       0 return wantarray ? (-w _,@_) : -w _;
2668             }
2669             else {
2670 0         0 my $fh = gensym();
2671 0 0       0 if (_open_a($fh, $_)) {
2672 0         0 my $w = -w $fh;
2673 0 0       0 close($fh) or die "Can't close file: $_: $!";
2674 0 0       0 return wantarray ? ($w,@_) : $w;
2675             }
2676             }
2677             }
2678 0 0       0 return wantarray ? (undef,@_) : undef;
2679             }
2680              
2681             #
2682             # ShiftJIS file test -x expr
2683             #
2684             sub Esjis::x(;*@) {
2685              
2686 0 0   0 0 0 local $_ = shift if @_;
2687 0 0 0     0 croak 'Too many arguments for -x (Esjis::x)' if @_ and not wantarray;
2688              
2689 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2690 0 0       0 return wantarray ? (-x _,@_) : -x _;
2691             }
2692             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2693 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2694             }
2695             elsif (-e $_) {
2696 0 0       0 return wantarray ? (-x _,@_) : -x _;
2697             }
2698             elsif (_MSWin32_5Cended_path($_)) {
2699 0 0       0 if (-d "$_/.") {
2700 0 0       0 return wantarray ? (-x _,@_) : -x _;
2701             }
2702             else {
2703 0         0 my $fh = gensym();
2704 0 0       0 if (_open_r($fh, $_)) {
2705 0         0 my $dummy_for_underline_cache = -x $fh;
2706 0 0       0 close($fh) or die "Can't close file: $_: $!";
2707             }
2708              
2709             # filename is not .COM .EXE .BAT .CMD
2710 0 0       0 return wantarray ? ('',@_) : '';
2711             }
2712             }
2713 0 0       0 return wantarray ? (undef,@_) : undef;
2714             }
2715              
2716             #
2717             # ShiftJIS file test -o expr
2718             #
2719             sub Esjis::o(;*@) {
2720              
2721 0 0   0 0 0 local $_ = shift if @_;
2722 0 0 0     0 croak 'Too many arguments for -o (Esjis::o)' if @_ and not wantarray;
2723              
2724 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2725 0 0       0 return wantarray ? (-o _,@_) : -o _;
2726             }
2727             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2728 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2729             }
2730             elsif (-e $_) {
2731 0 0       0 return wantarray ? (-o _,@_) : -o _;
2732             }
2733             elsif (_MSWin32_5Cended_path($_)) {
2734 0 0       0 if (-d "$_/.") {
2735 0 0       0 return wantarray ? (-o _,@_) : -o _;
2736             }
2737             else {
2738 0         0 my $fh = gensym();
2739 0 0       0 if (_open_r($fh, $_)) {
2740 0         0 my $o = -o $fh;
2741 0 0       0 close($fh) or die "Can't close file: $_: $!";
2742 0 0       0 return wantarray ? ($o,@_) : $o;
2743             }
2744             }
2745             }
2746 0 0       0 return wantarray ? (undef,@_) : undef;
2747             }
2748              
2749             #
2750             # ShiftJIS file test -R expr
2751             #
2752             sub Esjis::R(;*@) {
2753              
2754 0 0   0 0 0 local $_ = shift if @_;
2755 0 0 0     0 croak 'Too many arguments for -R (Esjis::R)' if @_ and not wantarray;
2756              
2757 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2758 0 0       0 return wantarray ? (-R _,@_) : -R _;
2759             }
2760             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2761 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2762             }
2763             elsif (-e $_) {
2764 0 0       0 return wantarray ? (-R _,@_) : -R _;
2765             }
2766             elsif (_MSWin32_5Cended_path($_)) {
2767 0 0       0 if (-d "$_/.") {
2768 0 0       0 return wantarray ? (-R _,@_) : -R _;
2769             }
2770             else {
2771 0         0 my $fh = gensym();
2772 0 0       0 if (_open_r($fh, $_)) {
2773 0         0 my $R = -R $fh;
2774 0 0       0 close($fh) or die "Can't close file: $_: $!";
2775 0 0       0 return wantarray ? ($R,@_) : $R;
2776             }
2777             }
2778             }
2779 0 0       0 return wantarray ? (undef,@_) : undef;
2780             }
2781              
2782             #
2783             # ShiftJIS file test -W expr
2784             #
2785             sub Esjis::W(;*@) {
2786              
2787 0 0   0 0 0 local $_ = shift if @_;
2788 0 0 0     0 croak 'Too many arguments for -W (Esjis::W)' if @_ and not wantarray;
2789              
2790 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2791 0 0       0 return wantarray ? (-W _,@_) : -W _;
2792             }
2793             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2794 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2795             }
2796             elsif (-e $_) {
2797 0 0       0 return wantarray ? (-W _,@_) : -W _;
2798             }
2799             elsif (_MSWin32_5Cended_path($_)) {
2800 0 0       0 if (-d "$_/.") {
2801 0 0       0 return wantarray ? (-W _,@_) : -W _;
2802             }
2803             else {
2804 0         0 my $fh = gensym();
2805 0 0       0 if (_open_a($fh, $_)) {
2806 0         0 my $W = -W $fh;
2807 0 0       0 close($fh) or die "Can't close file: $_: $!";
2808 0 0       0 return wantarray ? ($W,@_) : $W;
2809             }
2810             }
2811             }
2812 0 0       0 return wantarray ? (undef,@_) : undef;
2813             }
2814              
2815             #
2816             # ShiftJIS file test -X expr
2817             #
2818             sub Esjis::X(;*@) {
2819              
2820 0 0   0 1 0 local $_ = shift if @_;
2821 0 0 0     0 croak 'Too many arguments for -X (Esjis::X)' if @_ and not wantarray;
2822              
2823 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2824 0 0       0 return wantarray ? (-X _,@_) : -X _;
2825             }
2826             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2827 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2828             }
2829             elsif (-e $_) {
2830 0 0       0 return wantarray ? (-X _,@_) : -X _;
2831             }
2832             elsif (_MSWin32_5Cended_path($_)) {
2833 0 0       0 if (-d "$_/.") {
2834 0 0       0 return wantarray ? (-X _,@_) : -X _;
2835             }
2836             else {
2837 0         0 my $fh = gensym();
2838 0 0       0 if (_open_r($fh, $_)) {
2839 0         0 my $dummy_for_underline_cache = -X $fh;
2840 0 0       0 close($fh) or die "Can't close file: $_: $!";
2841             }
2842              
2843             # filename is not .COM .EXE .BAT .CMD
2844 0 0       0 return wantarray ? ('',@_) : '';
2845             }
2846             }
2847 0 0       0 return wantarray ? (undef,@_) : undef;
2848             }
2849              
2850             #
2851             # ShiftJIS file test -O expr
2852             #
2853             sub Esjis::O(;*@) {
2854              
2855 0 0   0 0 0 local $_ = shift if @_;
2856 0 0 0     0 croak 'Too many arguments for -O (Esjis::O)' if @_ and not wantarray;
2857              
2858 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2859 0 0       0 return wantarray ? (-O _,@_) : -O _;
2860             }
2861             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2862 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2863             }
2864             elsif (-e $_) {
2865 0 0       0 return wantarray ? (-O _,@_) : -O _;
2866             }
2867             elsif (_MSWin32_5Cended_path($_)) {
2868 0 0       0 if (-d "$_/.") {
2869 0 0       0 return wantarray ? (-O _,@_) : -O _;
2870             }
2871             else {
2872 0         0 my $fh = gensym();
2873 0 0       0 if (_open_r($fh, $_)) {
2874 0         0 my $O = -O $fh;
2875 0 0       0 close($fh) or die "Can't close file: $_: $!";
2876 0 0       0 return wantarray ? ($O,@_) : $O;
2877             }
2878             }
2879             }
2880 0 0       0 return wantarray ? (undef,@_) : undef;
2881             }
2882              
2883             #
2884             # ShiftJIS file test -e expr
2885             #
2886             sub Esjis::e(;*@) {
2887              
2888 0 50   772 0 0 local $_ = shift if @_;
2889 772 50 33     3885 croak 'Too many arguments for -e (Esjis::e)' if @_ and not wantarray;
2890              
2891 772         2667 local $^W = 0;
2892 772     772   2713 local $SIG{__WARN__} = sub {}; # telldir() attempted on invalid dirhandle at here
2893              
2894 772         5268 my $fh = qualify_to_ref $_;
2895 772 50       2586 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2896 772 0       3485 return wantarray ? (-e _,@_) : -e _;
2897             }
2898              
2899             # return false if directory handle
2900             elsif (defined Esjis::telldir($fh)) {
2901 0 0       0 return wantarray ? ('',@_) : '';
2902             }
2903              
2904             # return true if file handle
2905             elsif (defined fileno $fh) {
2906 0 0       0 return wantarray ? (1,@_) : 1;
2907             }
2908              
2909             elsif (-e $_) {
2910 0 0       0 return wantarray ? (1,@_) : 1;
2911             }
2912             elsif (_MSWin32_5Cended_path($_)) {
2913 0 0       0 if (-d "$_/.") {
2914 0 0       0 return wantarray ? (1,@_) : 1;
2915             }
2916             else {
2917 0         0 my $fh = gensym();
2918 0 0       0 if (_open_r($fh, $_)) {
2919 0         0 my $e = -e $fh;
2920 0 0       0 close($fh) or die "Can't close file: $_: $!";
2921 0 0       0 return wantarray ? ($e,@_) : $e;
2922             }
2923             }
2924             }
2925 0 50       0 return wantarray ? (undef,@_) : undef;
2926             }
2927              
2928             #
2929             # ShiftJIS file test -z expr
2930             #
2931             sub Esjis::z(;*@) {
2932              
2933 772 0   0 0 7029 local $_ = shift if @_;
2934 0 0 0     0 croak 'Too many arguments for -z (Esjis::z)' if @_ and not wantarray;
2935              
2936 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2937 0 0       0 return wantarray ? (-z _,@_) : -z _;
2938             }
2939             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2940 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2941             }
2942             elsif (-e $_) {
2943 0 0       0 return wantarray ? (-z _,@_) : -z _;
2944             }
2945             elsif (_MSWin32_5Cended_path($_)) {
2946 0 0       0 if (-d "$_/.") {
2947 0 0       0 return wantarray ? (-z _,@_) : -z _;
2948             }
2949             else {
2950 0         0 my $fh = gensym();
2951 0 0       0 if (_open_r($fh, $_)) {
2952 0         0 my $z = -z $fh;
2953 0 0       0 close($fh) or die "Can't close file: $_: $!";
2954 0 0       0 return wantarray ? ($z,@_) : $z;
2955             }
2956             }
2957             }
2958 0 0       0 return wantarray ? (undef,@_) : undef;
2959             }
2960              
2961             #
2962             # ShiftJIS file test -s expr
2963             #
2964             sub Esjis::s(;*@) {
2965              
2966 0 0   0 0 0 local $_ = shift if @_;
2967 0 0 0     0 croak 'Too many arguments for -s (Esjis::s)' if @_ and not wantarray;
2968              
2969 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2970 0 0       0 return wantarray ? (-s _,@_) : -s _;
2971             }
2972             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2973 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2974             }
2975             elsif (-e $_) {
2976 0 0       0 return wantarray ? (-s _,@_) : -s _;
2977             }
2978             elsif (_MSWin32_5Cended_path($_)) {
2979 0 0       0 if (-d "$_/.") {
2980 0 0       0 return wantarray ? (-s _,@_) : -s _;
2981             }
2982             else {
2983 0         0 my $fh = gensym();
2984 0 0       0 if (_open_r($fh, $_)) {
2985 0         0 my $s = -s $fh;
2986 0 0       0 close($fh) or die "Can't close file: $_: $!";
2987 0 0       0 return wantarray ? ($s,@_) : $s;
2988             }
2989             }
2990             }
2991 0 0       0 return wantarray ? (undef,@_) : undef;
2992             }
2993              
2994             #
2995             # ShiftJIS file test -f expr
2996             #
2997             sub Esjis::f(;*@) {
2998              
2999 0 0   0 0 0 local $_ = shift if @_;
3000 0 0 0     0 croak 'Too many arguments for -f (Esjis::f)' if @_ and not wantarray;
3001              
3002 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3003 0 0       0 return wantarray ? (-f _,@_) : -f _;
3004             }
3005             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3006 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
3007             }
3008             elsif (-e $_) {
3009 0 0       0 return wantarray ? (-f _,@_) : -f _;
3010             }
3011             elsif (_MSWin32_5Cended_path($_)) {
3012 0 0       0 if (-d "$_/.") {
3013 0 0       0 return wantarray ? ('',@_) : '';
3014             }
3015             else {
3016 0         0 my $fh = gensym();
3017 0 0       0 if (_open_r($fh, $_)) {
3018 0         0 my $f = -f $fh;
3019 0 0       0 close($fh) or die "Can't close file: $_: $!";
3020 0 0       0 return wantarray ? ($f,@_) : $f;
3021             }
3022             }
3023             }
3024 0 0       0 return wantarray ? (undef,@_) : undef;
3025             }
3026              
3027             #
3028             # ShiftJIS file test -d expr
3029             #
3030             sub Esjis::d(;*@) {
3031              
3032 0 0   0 0 0 local $_ = shift if @_;
3033 0 0 0     0 croak 'Too many arguments for -d (Esjis::d)' if @_ and not wantarray;
3034              
3035 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3036 0 0       0 return wantarray ? (-d _,@_) : -d _;
3037             }
3038              
3039             # return false if file handle or directory handle
3040             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3041 0 0       0 return wantarray ? ('',@_) : '';
3042             }
3043             elsif (-e $_) {
3044 0 0       0 return wantarray ? (-d _,@_) : -d _;
3045             }
3046             elsif (_MSWin32_5Cended_path($_)) {
3047 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3048             }
3049 0 0       0 return wantarray ? (undef,@_) : undef;
3050             }
3051              
3052             #
3053             # ShiftJIS file test -l expr
3054             #
3055             sub Esjis::l(;*@) {
3056              
3057 0 0   0 0 0 local $_ = shift if @_;
3058 0 0 0     0 croak 'Too many arguments for -l (Esjis::l)' if @_ and not wantarray;
3059              
3060 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3061 0 0       0 return wantarray ? (-l _,@_) : -l _;
3062             }
3063             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3064 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3065             }
3066             elsif (-e $_) {
3067 0 0       0 return wantarray ? (-l _,@_) : -l _;
3068             }
3069             elsif (_MSWin32_5Cended_path($_)) {
3070 0 0       0 if (-d "$_/.") {
3071 0 0       0 return wantarray ? (-l _,@_) : -l _;
3072             }
3073             else {
3074 0         0 my $fh = gensym();
3075 0 0       0 if (_open_r($fh, $_)) {
3076 0         0 my $l = -l $fh;
3077 0 0       0 close($fh) or die "Can't close file: $_: $!";
3078 0 0       0 return wantarray ? ($l,@_) : $l;
3079             }
3080             }
3081             }
3082 0 0       0 return wantarray ? (undef,@_) : undef;
3083             }
3084              
3085             #
3086             # ShiftJIS file test -p expr
3087             #
3088             sub Esjis::p(;*@) {
3089              
3090 0 0   0 0 0 local $_ = shift if @_;
3091 0 0 0     0 croak 'Too many arguments for -p (Esjis::p)' if @_ and not wantarray;
3092              
3093 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3094 0 0       0 return wantarray ? (-p _,@_) : -p _;
3095             }
3096             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3097 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3098             }
3099             elsif (-e $_) {
3100 0 0       0 return wantarray ? (-p _,@_) : -p _;
3101             }
3102             elsif (_MSWin32_5Cended_path($_)) {
3103 0 0       0 if (-d "$_/.") {
3104 0 0       0 return wantarray ? (-p _,@_) : -p _;
3105             }
3106             else {
3107 0         0 my $fh = gensym();
3108 0 0       0 if (_open_r($fh, $_)) {
3109 0         0 my $p = -p $fh;
3110 0 0       0 close($fh) or die "Can't close file: $_: $!";
3111 0 0       0 return wantarray ? ($p,@_) : $p;
3112             }
3113             }
3114             }
3115 0 0       0 return wantarray ? (undef,@_) : undef;
3116             }
3117              
3118             #
3119             # ShiftJIS file test -S expr
3120             #
3121             sub Esjis::S(;*@) {
3122              
3123 0 0   0 0 0 local $_ = shift if @_;
3124 0 0 0     0 croak 'Too many arguments for -S (Esjis::S)' if @_ and not wantarray;
3125              
3126 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3127 0 0       0 return wantarray ? (-S _,@_) : -S _;
3128             }
3129             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3130 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3131             }
3132             elsif (-e $_) {
3133 0 0       0 return wantarray ? (-S _,@_) : -S _;
3134             }
3135             elsif (_MSWin32_5Cended_path($_)) {
3136 0 0       0 if (-d "$_/.") {
3137 0 0       0 return wantarray ? (-S _,@_) : -S _;
3138             }
3139             else {
3140 0         0 my $fh = gensym();
3141 0 0       0 if (_open_r($fh, $_)) {
3142 0         0 my $S = -S $fh;
3143 0 0       0 close($fh) or die "Can't close file: $_: $!";
3144 0 0       0 return wantarray ? ($S,@_) : $S;
3145             }
3146             }
3147             }
3148 0 0       0 return wantarray ? (undef,@_) : undef;
3149             }
3150              
3151             #
3152             # ShiftJIS file test -b expr
3153             #
3154             sub Esjis::b(;*@) {
3155              
3156 0 0   0 0 0 local $_ = shift if @_;
3157 0 0 0     0 croak 'Too many arguments for -b (Esjis::b)' if @_ and not wantarray;
3158              
3159 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3160 0 0       0 return wantarray ? (-b _,@_) : -b _;
3161             }
3162             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3163 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3164             }
3165             elsif (-e $_) {
3166 0 0       0 return wantarray ? (-b _,@_) : -b _;
3167             }
3168             elsif (_MSWin32_5Cended_path($_)) {
3169 0 0       0 if (-d "$_/.") {
3170 0 0       0 return wantarray ? (-b _,@_) : -b _;
3171             }
3172             else {
3173 0         0 my $fh = gensym();
3174 0 0       0 if (_open_r($fh, $_)) {
3175 0         0 my $b = -b $fh;
3176 0 0       0 close($fh) or die "Can't close file: $_: $!";
3177 0 0       0 return wantarray ? ($b,@_) : $b;
3178             }
3179             }
3180             }
3181 0 0       0 return wantarray ? (undef,@_) : undef;
3182             }
3183              
3184             #
3185             # ShiftJIS file test -c expr
3186             #
3187             sub Esjis::c(;*@) {
3188              
3189 0 0   0 0 0 local $_ = shift if @_;
3190 0 0 0     0 croak 'Too many arguments for -c (Esjis::c)' if @_ and not wantarray;
3191              
3192 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3193 0 0       0 return wantarray ? (-c _,@_) : -c _;
3194             }
3195             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3196 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3197             }
3198             elsif (-e $_) {
3199 0 0       0 return wantarray ? (-c _,@_) : -c _;
3200             }
3201             elsif (_MSWin32_5Cended_path($_)) {
3202 0 0       0 if (-d "$_/.") {
3203 0 0       0 return wantarray ? (-c _,@_) : -c _;
3204             }
3205             else {
3206 0         0 my $fh = gensym();
3207 0 0       0 if (_open_r($fh, $_)) {
3208 0         0 my $c = -c $fh;
3209 0 0       0 close($fh) or die "Can't close file: $_: $!";
3210 0 0       0 return wantarray ? ($c,@_) : $c;
3211             }
3212             }
3213             }
3214 0 0       0 return wantarray ? (undef,@_) : undef;
3215             }
3216              
3217             #
3218             # ShiftJIS file test -u expr
3219             #
3220             sub Esjis::u(;*@) {
3221              
3222 0 0   0 0 0 local $_ = shift if @_;
3223 0 0 0     0 croak 'Too many arguments for -u (Esjis::u)' if @_ and not wantarray;
3224              
3225 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3226 0 0       0 return wantarray ? (-u _,@_) : -u _;
3227             }
3228             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3229 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3230             }
3231             elsif (-e $_) {
3232 0 0       0 return wantarray ? (-u _,@_) : -u _;
3233             }
3234             elsif (_MSWin32_5Cended_path($_)) {
3235 0 0       0 if (-d "$_/.") {
3236 0 0       0 return wantarray ? (-u _,@_) : -u _;
3237             }
3238             else {
3239 0         0 my $fh = gensym();
3240 0 0       0 if (_open_r($fh, $_)) {
3241 0         0 my $u = -u $fh;
3242 0 0       0 close($fh) or die "Can't close file: $_: $!";
3243 0 0       0 return wantarray ? ($u,@_) : $u;
3244             }
3245             }
3246             }
3247 0 0       0 return wantarray ? (undef,@_) : undef;
3248             }
3249              
3250             #
3251             # ShiftJIS file test -g expr
3252             #
3253             sub Esjis::g(;*@) {
3254              
3255 0 0   0 0 0 local $_ = shift if @_;
3256 0 0 0     0 croak 'Too many arguments for -g (Esjis::g)' if @_ and not wantarray;
3257              
3258 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3259 0 0       0 return wantarray ? (-g _,@_) : -g _;
3260             }
3261             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3262 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3263             }
3264             elsif (-e $_) {
3265 0 0       0 return wantarray ? (-g _,@_) : -g _;
3266             }
3267             elsif (_MSWin32_5Cended_path($_)) {
3268 0 0       0 if (-d "$_/.") {
3269 0 0       0 return wantarray ? (-g _,@_) : -g _;
3270             }
3271             else {
3272 0         0 my $fh = gensym();
3273 0 0       0 if (_open_r($fh, $_)) {
3274 0         0 my $g = -g $fh;
3275 0 0       0 close($fh) or die "Can't close file: $_: $!";
3276 0 0       0 return wantarray ? ($g,@_) : $g;
3277             }
3278             }
3279             }
3280 0 0       0 return wantarray ? (undef,@_) : undef;
3281             }
3282              
3283             #
3284             # ShiftJIS file test -k expr
3285             #
3286             sub Esjis::k(;*@) {
3287              
3288 0 0   0 0 0 local $_ = shift if @_;
3289 0 0 0     0 croak 'Too many arguments for -k (Esjis::k)' if @_ and not wantarray;
3290              
3291 0 0       0 if ($_ eq '_') {
    0          
    0          
3292 0 0       0 return wantarray ? ('',@_) : '';
3293             }
3294             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3295 0 0       0 return wantarray ? ('',@_) : '';
3296             }
3297             elsif ($] =~ /^5\.008/oxms) {
3298 0 0       0 return wantarray ? ('',@_) : '';
3299             }
3300 0 0       0 return wantarray ? ($_,@_) : $_;
3301             }
3302              
3303             #
3304             # ShiftJIS file test -T expr
3305             #
3306             sub Esjis::T(;*@) {
3307              
3308 0 0   0 0 0 local $_ = shift if @_;
3309              
3310             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3311             # croak 'Too many arguments for -T (Esjis::T)';
3312             # Must be used by parentheses like:
3313             # croak('Too many arguments for -T (Esjis::T)');
3314              
3315 0 0 0     0 if (@_ and not wantarray) {
3316 0         0 croak('Too many arguments for -T (Esjis::T)');
3317             }
3318              
3319 0         0 my $T = 1;
3320              
3321 0         0 my $fh = qualify_to_ref $_;
3322 0 0       0 if (defined fileno $fh) {
3323              
3324 0     0   0 local $SIG{__WARN__} = sub {}; # telldir() attempted on invalid dirhandle at here
3325 0 0       0 if (defined Esjis::telldir($fh)) {
3326 0 0       0 return wantarray ? (undef,@_) : undef;
3327             }
3328              
3329             # P.813 29.2.176. tell
3330             # in Chapter 29: Functions
3331             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3332              
3333             # P.970 tell
3334             # in Chapter 27: Functions
3335             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3336              
3337             # (and so on)
3338              
3339 0         0 my $systell = sysseek $fh, 0, 1;
3340              
3341 0 0       0 if (sysread $fh, my $block, 512) {
3342              
3343             # P.163 Binary file check in Little Perl Parlor 16
3344             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3345             # (and so on)
3346              
3347 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3348 0         0 $T = '';
3349             }
3350             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3351 0         0 $T = '';
3352             }
3353             }
3354              
3355             # 0 byte or eof
3356             else {
3357 0         0 $T = 1;
3358             }
3359              
3360 0         0 my $dummy_for_underline_cache = -T $fh;
3361 0         0 sysseek $fh, $systell, 0;
3362             }
3363             else {
3364 0 0 0     0 if (-d $_ or -d "$_/.") {
3365 0 0       0 return wantarray ? (undef,@_) : undef;
3366             }
3367              
3368 0         0 $fh = gensym();
3369 0 0       0 if (_open_r($fh, $_)) {
3370             }
3371             else {
3372 0 0       0 return wantarray ? (undef,@_) : undef;
3373             }
3374 0 0       0 if (sysread $fh, my $block, 512) {
3375 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3376 0         0 $T = '';
3377             }
3378             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3379 0         0 $T = '';
3380             }
3381             }
3382              
3383             # 0 byte or eof
3384             else {
3385 0         0 $T = 1;
3386             }
3387 0         0 my $dummy_for_underline_cache = -T $fh;
3388 0 0       0 close($fh) or die "Can't close file: $_: $!";
3389             }
3390              
3391 0 0       0 return wantarray ? ($T,@_) : $T;
3392             }
3393              
3394             #
3395             # ShiftJIS file test -B expr
3396             #
3397             sub Esjis::B(;*@) {
3398              
3399 0 0   0 0 0 local $_ = shift if @_;
3400 0 0 0     0 croak 'Too many arguments for -B (Esjis::B)' if @_ and not wantarray;
3401 0         0 my $B = '';
3402              
3403 0         0 my $fh = qualify_to_ref $_;
3404 0 0       0 if (defined fileno $fh) {
3405              
3406 0     0   0 local $SIG{__WARN__} = sub {}; # telldir() attempted on invalid dirhandle at here
3407 0 0       0 if (defined Esjis::telldir($fh)) {
3408 0 0       0 return wantarray ? (undef,@_) : undef;
3409             }
3410              
3411 0         0 my $systell = sysseek $fh, 0, 1;
3412              
3413 0 0       0 if (sysread $fh, my $block, 512) {
3414 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3415 0         0 $B = 1;
3416             }
3417             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3418 0         0 $B = 1;
3419             }
3420             }
3421              
3422             # 0 byte or eof
3423             else {
3424 0         0 $B = 1;
3425             }
3426              
3427 0         0 my $dummy_for_underline_cache = -B $fh;
3428 0         0 sysseek $fh, $systell, 0;
3429             }
3430             else {
3431 0 0 0     0 if (-d $_ or -d "$_/.") {
3432 0 0       0 return wantarray ? (undef,@_) : undef;
3433             }
3434              
3435 0         0 $fh = gensym();
3436 0 0       0 if (_open_r($fh, $_)) {
3437             }
3438             else {
3439 0 0       0 return wantarray ? (undef,@_) : undef;
3440             }
3441 0 0       0 if (sysread $fh, my $block, 512) {
3442 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3443 0         0 $B = 1;
3444             }
3445             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3446 0         0 $B = 1;
3447             }
3448             }
3449              
3450             # 0 byte or eof
3451             else {
3452 0         0 $B = 1;
3453             }
3454 0         0 my $dummy_for_underline_cache = -B $fh;
3455 0 0       0 close($fh) or die "Can't close file: $_: $!";
3456             }
3457              
3458 0 0       0 return wantarray ? ($B,@_) : $B;
3459             }
3460              
3461             #
3462             # ShiftJIS file test -M expr
3463             #
3464             sub Esjis::M(;*@) {
3465              
3466 0 0   0 0 0 local $_ = shift if @_;
3467 0 0 0     0 croak 'Too many arguments for -M (Esjis::M)' if @_ and not wantarray;
3468              
3469 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3470 0 0       0 return wantarray ? (-M _,@_) : -M _;
3471             }
3472             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3473 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3474             }
3475             elsif (-e $_) {
3476 0 0       0 return wantarray ? (-M _,@_) : -M _;
3477             }
3478             elsif (_MSWin32_5Cended_path($_)) {
3479 0 0       0 if (-d "$_/.") {
3480 0 0       0 return wantarray ? (-M _,@_) : -M _;
3481             }
3482             else {
3483 0         0 my $fh = gensym();
3484 0 0       0 if (_open_r($fh, $_)) {
3485 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3486 0 0       0 close($fh) or die "Can't close file: $_: $!";
3487 0         0 my $M = ($^T - $mtime) / (24*60*60);
3488 0 0       0 return wantarray ? ($M,@_) : $M;
3489             }
3490             }
3491             }
3492 0 0       0 return wantarray ? (undef,@_) : undef;
3493             }
3494              
3495             #
3496             # ShiftJIS file test -A expr
3497             #
3498             sub Esjis::A(;*@) {
3499              
3500 0 0   0 0 0 local $_ = shift if @_;
3501 0 0 0     0 croak 'Too many arguments for -A (Esjis::A)' if @_ and not wantarray;
3502              
3503 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3504 0 0       0 return wantarray ? (-A _,@_) : -A _;
3505             }
3506             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3507 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3508             }
3509             elsif (-e $_) {
3510 0 0       0 return wantarray ? (-A _,@_) : -A _;
3511             }
3512             elsif (_MSWin32_5Cended_path($_)) {
3513 0 0       0 if (-d "$_/.") {
3514 0 0       0 return wantarray ? (-A _,@_) : -A _;
3515             }
3516             else {
3517 0         0 my $fh = gensym();
3518 0 0       0 if (_open_r($fh, $_)) {
3519 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3520 0 0       0 close($fh) or die "Can't close file: $_: $!";
3521 0         0 my $A = ($^T - $atime) / (24*60*60);
3522 0 0       0 return wantarray ? ($A,@_) : $A;
3523             }
3524             }
3525             }
3526 0 0       0 return wantarray ? (undef,@_) : undef;
3527             }
3528              
3529             #
3530             # ShiftJIS file test -C expr
3531             #
3532             sub Esjis::C(;*@) {
3533              
3534 0 0   0 0 0 local $_ = shift if @_;
3535 0 0 0     0 croak 'Too many arguments for -C (Esjis::C)' if @_ and not wantarray;
3536              
3537 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3538 0 0       0 return wantarray ? (-C _,@_) : -C _;
3539             }
3540             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3541 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3542             }
3543             elsif (-e $_) {
3544 0 0       0 return wantarray ? (-C _,@_) : -C _;
3545             }
3546             elsif (_MSWin32_5Cended_path($_)) {
3547 0 0       0 if (-d "$_/.") {
3548 0 0       0 return wantarray ? (-C _,@_) : -C _;
3549             }
3550             else {
3551 0         0 my $fh = gensym();
3552 0 0       0 if (_open_r($fh, $_)) {
3553 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3554 0 0       0 close($fh) or die "Can't close file: $_: $!";
3555 0         0 my $C = ($^T - $ctime) / (24*60*60);
3556 0 0       0 return wantarray ? ($C,@_) : $C;
3557             }
3558             }
3559             }
3560 0 0       0 return wantarray ? (undef,@_) : undef;
3561             }
3562              
3563             #
3564             # ShiftJIS stacked file test $_
3565             #
3566             sub Esjis::filetest_ {
3567              
3568 0     0 0 0 my $filetest = substr(pop @_, 1);
3569              
3570 0 0       0 unless (CORE::eval qq{Esjis::${filetest}_}) {
3571 0         0 return '';
3572             }
3573 0         0 for my $filetest (CORE::reverse @_) {
3574 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3575 0         0 return '';
3576             }
3577             }
3578 0         0 return 1;
3579             }
3580              
3581             #
3582             # ShiftJIS file test -r $_
3583             #
3584             sub Esjis::r_() {
3585              
3586 0 0   0 0 0 if (-e $_) {
    0          
3587 0 0       0 return -r _ ? 1 : '';
3588             }
3589             elsif (_MSWin32_5Cended_path($_)) {
3590 0 0       0 if (-d "$_/.") {
3591 0 0       0 return -r _ ? 1 : '';
3592             }
3593             else {
3594 0         0 my $fh = gensym();
3595 0 0       0 if (_open_r($fh, $_)) {
3596 0         0 my $r = -r $fh;
3597 0 0       0 close($fh) or die "Can't close file: $_: $!";
3598 0 0       0 return $r ? 1 : '';
3599             }
3600             }
3601             }
3602              
3603             # 10.10. Returning Failure
3604             # in Chapter 10. Subroutines
3605             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3606             # (and so on)
3607              
3608             # 2010-01-26 The difference of "return;" and "return undef;"
3609             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3610             #
3611             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3612             # it might be wrong in some cases. If you use this idiom for those functions
3613             # which are expected to return a scalar value, e.g. searching functions, the
3614             # user of those functions will be surprised at what they return in list
3615             # context, an empty list - note that many functions and all the methods
3616             # evaluate their arguments in list context. You'd better to use "return undef;"
3617             # for such scalar functions.
3618             #
3619             # sub search_something {
3620             # my($arg) = @_;
3621             # # search_something...
3622             # if(defined $found){
3623             # return $found;
3624             # }
3625             # return; # XXX: you'd better to "return undef;"
3626             # }
3627             #
3628             # # ...
3629             #
3630             # # you'll get what you want, but ...
3631             # my $something = search_something($source);
3632             #
3633             # # you won't get what you want here.
3634             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3635             # $obj->doit(search_something($source), -option=> $optval);
3636             #
3637             # # you have to use the "scalar" operator in such a case.
3638             # $obj->doit(scalar search_something($source), ...);
3639             #
3640             # *1: it returns an empty list in list context, or returns undef in scalar
3641             # context
3642             #
3643             # (and so on)
3644              
3645 0         0 return undef;
3646             }
3647              
3648             #
3649             # ShiftJIS file test -w $_
3650             #
3651             sub Esjis::w_() {
3652              
3653 0 0   0 0 0 if (-e $_) {
    0          
3654 0 0       0 return -w _ ? 1 : '';
3655             }
3656             elsif (_MSWin32_5Cended_path($_)) {
3657 0 0       0 if (-d "$_/.") {
3658 0 0       0 return -w _ ? 1 : '';
3659             }
3660             else {
3661 0         0 my $fh = gensym();
3662 0 0       0 if (_open_a($fh, $_)) {
3663 0         0 my $w = -w $fh;
3664 0 0       0 close($fh) or die "Can't close file: $_: $!";
3665 0 0       0 return $w ? 1 : '';
3666             }
3667             }
3668             }
3669 0         0 return undef;
3670             }
3671              
3672             #
3673             # ShiftJIS file test -x $_
3674             #
3675             sub Esjis::x_() {
3676              
3677 0 0   0 0 0 if (-e $_) {
    0          
3678 0 0       0 return -x _ ? 1 : '';
3679             }
3680             elsif (_MSWin32_5Cended_path($_)) {
3681 0 0       0 if (-d "$_/.") {
3682 0 0       0 return -x _ ? 1 : '';
3683             }
3684             else {
3685 0         0 my $fh = gensym();
3686 0 0       0 if (_open_r($fh, $_)) {
3687 0         0 my $dummy_for_underline_cache = -x $fh;
3688 0 0       0 close($fh) or die "Can't close file: $_: $!";
3689             }
3690              
3691             # filename is not .COM .EXE .BAT .CMD
3692 0         0 return '';
3693             }
3694             }
3695 0         0 return undef;
3696             }
3697              
3698             #
3699             # ShiftJIS file test -o $_
3700             #
3701             sub Esjis::o_() {
3702              
3703 0 0   0 0 0 if (-e $_) {
    0          
3704 0 0       0 return -o _ ? 1 : '';
3705             }
3706             elsif (_MSWin32_5Cended_path($_)) {
3707 0 0       0 if (-d "$_/.") {
3708 0 0       0 return -o _ ? 1 : '';
3709             }
3710             else {
3711 0         0 my $fh = gensym();
3712 0 0       0 if (_open_r($fh, $_)) {
3713 0         0 my $o = -o $fh;
3714 0 0       0 close($fh) or die "Can't close file: $_: $!";
3715 0 0       0 return $o ? 1 : '';
3716             }
3717             }
3718             }
3719 0         0 return undef;
3720             }
3721              
3722             #
3723             # ShiftJIS file test -R $_
3724             #
3725             sub Esjis::R_() {
3726              
3727 0 0   0 0 0 if (-e $_) {
    0          
3728 0 0       0 return -R _ ? 1 : '';
3729             }
3730             elsif (_MSWin32_5Cended_path($_)) {
3731 0 0       0 if (-d "$_/.") {
3732 0 0       0 return -R _ ? 1 : '';
3733             }
3734             else {
3735 0         0 my $fh = gensym();
3736 0 0       0 if (_open_r($fh, $_)) {
3737 0         0 my $R = -R $fh;
3738 0 0       0 close($fh) or die "Can't close file: $_: $!";
3739 0 0       0 return $R ? 1 : '';
3740             }
3741             }
3742             }
3743 0         0 return undef;
3744             }
3745              
3746             #
3747             # ShiftJIS file test -W $_
3748             #
3749             sub Esjis::W_() {
3750              
3751 0 0   0 0 0 if (-e $_) {
    0          
3752 0 0       0 return -W _ ? 1 : '';
3753             }
3754             elsif (_MSWin32_5Cended_path($_)) {
3755 0 0       0 if (-d "$_/.") {
3756 0 0       0 return -W _ ? 1 : '';
3757             }
3758             else {
3759 0         0 my $fh = gensym();
3760 0 0       0 if (_open_a($fh, $_)) {
3761 0         0 my $W = -W $fh;
3762 0 0       0 close($fh) or die "Can't close file: $_: $!";
3763 0 0       0 return $W ? 1 : '';
3764             }
3765             }
3766             }
3767 0         0 return undef;
3768             }
3769              
3770             #
3771             # ShiftJIS file test -X $_
3772             #
3773             sub Esjis::X_() {
3774              
3775 0 0   0 0 0 if (-e $_) {
    0          
3776 0 0       0 return -X _ ? 1 : '';
3777             }
3778             elsif (_MSWin32_5Cended_path($_)) {
3779 0 0       0 if (-d "$_/.") {
3780 0 0       0 return -X _ ? 1 : '';
3781             }
3782             else {
3783 0         0 my $fh = gensym();
3784 0 0       0 if (_open_r($fh, $_)) {
3785 0         0 my $dummy_for_underline_cache = -X $fh;
3786 0 0       0 close($fh) or die "Can't close file: $_: $!";
3787             }
3788              
3789             # filename is not .COM .EXE .BAT .CMD
3790 0         0 return '';
3791             }
3792             }
3793 0         0 return undef;
3794             }
3795              
3796             #
3797             # ShiftJIS file test -O $_
3798             #
3799             sub Esjis::O_() {
3800              
3801 0 0   0 0 0 if (-e $_) {
    0          
3802 0 0       0 return -O _ ? 1 : '';
3803             }
3804             elsif (_MSWin32_5Cended_path($_)) {
3805 0 0       0 if (-d "$_/.") {
3806 0 0       0 return -O _ ? 1 : '';
3807             }
3808             else {
3809 0         0 my $fh = gensym();
3810 0 0       0 if (_open_r($fh, $_)) {
3811 0         0 my $O = -O $fh;
3812 0 0       0 close($fh) or die "Can't close file: $_: $!";
3813 0 0       0 return $O ? 1 : '';
3814             }
3815             }
3816             }
3817 0         0 return undef;
3818             }
3819              
3820             #
3821             # ShiftJIS file test -e $_
3822             #
3823             sub Esjis::e_() {
3824              
3825 0 0   0 0 0 if (-e $_) {
    0          
3826 0         0 return 1;
3827             }
3828             elsif (_MSWin32_5Cended_path($_)) {
3829 0 0       0 if (-d "$_/.") {
3830 0         0 return 1;
3831             }
3832             else {
3833 0         0 my $fh = gensym();
3834 0 0       0 if (_open_r($fh, $_)) {
3835 0         0 my $e = -e $fh;
3836 0 0       0 close($fh) or die "Can't close file: $_: $!";
3837 0 0       0 return $e ? 1 : '';
3838             }
3839             }
3840             }
3841 0         0 return undef;
3842             }
3843              
3844             #
3845             # ShiftJIS file test -z $_
3846             #
3847             sub Esjis::z_() {
3848              
3849 0 0   0 0 0 if (-e $_) {
    0          
3850 0 0       0 return -z _ ? 1 : '';
3851             }
3852             elsif (_MSWin32_5Cended_path($_)) {
3853 0 0       0 if (-d "$_/.") {
3854 0 0       0 return -z _ ? 1 : '';
3855             }
3856             else {
3857 0         0 my $fh = gensym();
3858 0 0       0 if (_open_r($fh, $_)) {
3859 0         0 my $z = -z $fh;
3860 0 0       0 close($fh) or die "Can't close file: $_: $!";
3861 0 0       0 return $z ? 1 : '';
3862             }
3863             }
3864             }
3865 0         0 return undef;
3866             }
3867              
3868             #
3869             # ShiftJIS file test -s $_
3870             #
3871             sub Esjis::s_() {
3872              
3873 0 0   0 0 0 if (-e $_) {
    0          
3874 0         0 return -s _;
3875             }
3876             elsif (_MSWin32_5Cended_path($_)) {
3877 0 0       0 if (-d "$_/.") {
3878 0         0 return -s _;
3879             }
3880             else {
3881 0         0 my $fh = gensym();
3882 0 0       0 if (_open_r($fh, $_)) {
3883 0         0 my $s = -s $fh;
3884 0 0       0 close($fh) or die "Can't close file: $_: $!";
3885 0         0 return $s;
3886             }
3887             }
3888             }
3889 0         0 return undef;
3890             }
3891              
3892             #
3893             # ShiftJIS file test -f $_
3894             #
3895             sub Esjis::f_() {
3896              
3897 0 0   0 0 0 if (-e $_) {
    0          
3898 0 0       0 return -f _ ? 1 : '';
3899             }
3900             elsif (_MSWin32_5Cended_path($_)) {
3901 0 0       0 if (-d "$_/.") {
3902 0         0 return '';
3903             }
3904             else {
3905 0         0 my $fh = gensym();
3906 0 0       0 if (_open_r($fh, $_)) {
3907 0         0 my $f = -f $fh;
3908 0 0       0 close($fh) or die "Can't close file: $_: $!";
3909 0 0       0 return $f ? 1 : '';
3910             }
3911             }
3912             }
3913 0         0 return undef;
3914             }
3915              
3916             #
3917             # ShiftJIS file test -d $_
3918             #
3919             sub Esjis::d_() {
3920              
3921 0 0   0 0 0 if (-e $_) {
    0          
3922 0 0       0 return -d _ ? 1 : '';
3923             }
3924             elsif (_MSWin32_5Cended_path($_)) {
3925 0 0       0 return -d "$_/." ? 1 : '';
3926             }
3927 0         0 return undef;
3928             }
3929              
3930             #
3931             # ShiftJIS file test -l $_
3932             #
3933             sub Esjis::l_() {
3934              
3935 0 0   0 0 0 if (-e $_) {
    0          
3936 0 0       0 return -l _ ? 1 : '';
3937             }
3938             elsif (_MSWin32_5Cended_path($_)) {
3939 0 0       0 if (-d "$_/.") {
3940 0 0       0 return -l _ ? 1 : '';
3941             }
3942             else {
3943 0         0 my $fh = gensym();
3944 0 0       0 if (_open_r($fh, $_)) {
3945 0         0 my $l = -l $fh;
3946 0 0       0 close($fh) or die "Can't close file: $_: $!";
3947 0 0       0 return $l ? 1 : '';
3948             }
3949             }
3950             }
3951 0         0 return undef;
3952             }
3953              
3954             #
3955             # ShiftJIS file test -p $_
3956             #
3957             sub Esjis::p_() {
3958              
3959 0 0   0 0 0 if (-e $_) {
    0          
3960 0 0       0 return -p _ ? 1 : '';
3961             }
3962             elsif (_MSWin32_5Cended_path($_)) {
3963 0 0       0 if (-d "$_/.") {
3964 0 0       0 return -p _ ? 1 : '';
3965             }
3966             else {
3967 0         0 my $fh = gensym();
3968 0 0       0 if (_open_r($fh, $_)) {
3969 0         0 my $p = -p $fh;
3970 0 0       0 close($fh) or die "Can't close file: $_: $!";
3971 0 0       0 return $p ? 1 : '';
3972             }
3973             }
3974             }
3975 0         0 return undef;
3976             }
3977              
3978             #
3979             # ShiftJIS file test -S $_
3980             #
3981             sub Esjis::S_() {
3982              
3983 0 0   0 0 0 if (-e $_) {
    0          
3984 0 0       0 return -S _ ? 1 : '';
3985             }
3986             elsif (_MSWin32_5Cended_path($_)) {
3987 0 0       0 if (-d "$_/.") {
3988 0 0       0 return -S _ ? 1 : '';
3989             }
3990             else {
3991 0         0 my $fh = gensym();
3992 0 0       0 if (_open_r($fh, $_)) {
3993 0         0 my $S = -S $fh;
3994 0 0       0 close($fh) or die "Can't close file: $_: $!";
3995 0 0       0 return $S ? 1 : '';
3996             }
3997             }
3998             }
3999 0         0 return undef;
4000             }
4001              
4002             #
4003             # ShiftJIS file test -b $_
4004             #
4005             sub Esjis::b_() {
4006              
4007 0 0   0 0 0 if (-e $_) {
    0          
4008 0 0       0 return -b _ ? 1 : '';
4009             }
4010             elsif (_MSWin32_5Cended_path($_)) {
4011 0 0       0 if (-d "$_/.") {
4012 0 0       0 return -b _ ? 1 : '';
4013             }
4014             else {
4015 0         0 my $fh = gensym();
4016 0 0       0 if (_open_r($fh, $_)) {
4017 0         0 my $b = -b $fh;
4018 0 0       0 close($fh) or die "Can't close file: $_: $!";
4019 0 0       0 return $b ? 1 : '';
4020             }
4021             }
4022             }
4023 0         0 return undef;
4024             }
4025              
4026             #
4027             # ShiftJIS file test -c $_
4028             #
4029             sub Esjis::c_() {
4030              
4031 0 0   0 0 0 if (-e $_) {
    0          
4032 0 0       0 return -c _ ? 1 : '';
4033             }
4034             elsif (_MSWin32_5Cended_path($_)) {
4035 0 0       0 if (-d "$_/.") {
4036 0 0       0 return -c _ ? 1 : '';
4037             }
4038             else {
4039 0         0 my $fh = gensym();
4040 0 0       0 if (_open_r($fh, $_)) {
4041 0         0 my $c = -c $fh;
4042 0 0       0 close($fh) or die "Can't close file: $_: $!";
4043 0 0       0 return $c ? 1 : '';
4044             }
4045             }
4046             }
4047 0         0 return undef;
4048             }
4049              
4050             #
4051             # ShiftJIS file test -u $_
4052             #
4053             sub Esjis::u_() {
4054              
4055 0 0   0 0 0 if (-e $_) {
    0          
4056 0 0       0 return -u _ ? 1 : '';
4057             }
4058             elsif (_MSWin32_5Cended_path($_)) {
4059 0 0       0 if (-d "$_/.") {
4060 0 0       0 return -u _ ? 1 : '';
4061             }
4062             else {
4063 0         0 my $fh = gensym();
4064 0 0       0 if (_open_r($fh, $_)) {
4065 0         0 my $u = -u $fh;
4066 0 0       0 close($fh) or die "Can't close file: $_: $!";
4067 0 0       0 return $u ? 1 : '';
4068             }
4069             }
4070             }
4071 0         0 return undef;
4072             }
4073              
4074             #
4075             # ShiftJIS file test -g $_
4076             #
4077             sub Esjis::g_() {
4078              
4079 0 0   0 0 0 if (-e $_) {
    0          
4080 0 0       0 return -g _ ? 1 : '';
4081             }
4082             elsif (_MSWin32_5Cended_path($_)) {
4083 0 0       0 if (-d "$_/.") {
4084 0 0       0 return -g _ ? 1 : '';
4085             }
4086             else {
4087 0         0 my $fh = gensym();
4088 0 0       0 if (_open_r($fh, $_)) {
4089 0         0 my $g = -g $fh;
4090 0 0       0 close($fh) or die "Can't close file: $_: $!";
4091 0 0       0 return $g ? 1 : '';
4092             }
4093             }
4094             }
4095 0         0 return undef;
4096             }
4097              
4098             #
4099             # ShiftJIS file test -k $_
4100             #
4101             sub Esjis::k_() {
4102              
4103 0 0   0 0 0 if ($] =~ /^5\.008/oxms) {
4104 0 0       0 return wantarray ? ('',@_) : '';
4105             }
4106 0 0       0 return wantarray ? ($_,@_) : $_;
4107             }
4108              
4109             #
4110             # ShiftJIS file test -T $_
4111             #
4112             sub Esjis::T_() {
4113              
4114 0     0 0 0 my $T = 1;
4115              
4116 0 0 0     0 if (-d $_ or -d "$_/.") {
4117 0         0 return undef;
4118             }
4119 0         0 my $fh = gensym();
4120 0 0       0 if (_open_r($fh, $_)) {
4121             }
4122             else {
4123 0         0 return undef;
4124             }
4125              
4126 0 0       0 if (sysread $fh, my $block, 512) {
4127 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4128 0         0 $T = '';
4129             }
4130             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4131 0         0 $T = '';
4132             }
4133             }
4134              
4135             # 0 byte or eof
4136             else {
4137 0         0 $T = 1;
4138             }
4139 0         0 my $dummy_for_underline_cache = -T $fh;
4140 0 0       0 close($fh) or die "Can't close file: $_: $!";
4141              
4142 0         0 return $T;
4143             }
4144              
4145             #
4146             # ShiftJIS file test -B $_
4147             #
4148             sub Esjis::B_() {
4149              
4150 0     0 0 0 my $B = '';
4151              
4152 0 0 0     0 if (-d $_ or -d "$_/.") {
4153 0         0 return undef;
4154             }
4155 0         0 my $fh = gensym();
4156 0 0       0 if (_open_r($fh, $_)) {
4157             }
4158             else {
4159 0         0 return undef;
4160             }
4161              
4162 0 0       0 if (sysread $fh, my $block, 512) {
4163 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
4164 0         0 $B = 1;
4165             }
4166             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
4167 0         0 $B = 1;
4168             }
4169             }
4170              
4171             # 0 byte or eof
4172             else {
4173 0         0 $B = 1;
4174             }
4175 0         0 my $dummy_for_underline_cache = -B $fh;
4176 0 0       0 close($fh) or die "Can't close file: $_: $!";
4177              
4178 0         0 return $B;
4179             }
4180              
4181             #
4182             # ShiftJIS file test -M $_
4183             #
4184             sub Esjis::M_() {
4185              
4186 0 0   0 0 0 if (-e $_) {
    0          
4187 0         0 return -M _;
4188             }
4189             elsif (_MSWin32_5Cended_path($_)) {
4190 0 0       0 if (-d "$_/.") {
4191 0         0 return -M _;
4192             }
4193             else {
4194 0         0 my $fh = gensym();
4195 0 0       0 if (_open_r($fh, $_)) {
4196 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4197 0 0       0 close($fh) or die "Can't close file: $_: $!";
4198 0         0 my $M = ($^T - $mtime) / (24*60*60);
4199 0         0 return $M;
4200             }
4201             }
4202             }
4203 0         0 return undef;
4204             }
4205              
4206             #
4207             # ShiftJIS file test -A $_
4208             #
4209             sub Esjis::A_() {
4210              
4211 0 0   0 0 0 if (-e $_) {
    0          
4212 0         0 return -A _;
4213             }
4214             elsif (_MSWin32_5Cended_path($_)) {
4215 0 0       0 if (-d "$_/.") {
4216 0         0 return -A _;
4217             }
4218             else {
4219 0         0 my $fh = gensym();
4220 0 0       0 if (_open_r($fh, $_)) {
4221 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4222 0 0       0 close($fh) or die "Can't close file: $_: $!";
4223 0         0 my $A = ($^T - $atime) / (24*60*60);
4224 0         0 return $A;
4225             }
4226             }
4227             }
4228 0         0 return undef;
4229             }
4230              
4231             #
4232             # ShiftJIS file test -C $_
4233             #
4234             sub Esjis::C_() {
4235              
4236 0 0   0 0 0 if (-e $_) {
    0          
4237 0         0 return -C _;
4238             }
4239             elsif (_MSWin32_5Cended_path($_)) {
4240 0 0       0 if (-d "$_/.") {
4241 0         0 return -C _;
4242             }
4243             else {
4244 0         0 my $fh = gensym();
4245 0 0       0 if (_open_r($fh, $_)) {
4246 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
4247 0 0       0 close($fh) or die "Can't close file: $_: $!";
4248 0         0 my $C = ($^T - $ctime) / (24*60*60);
4249 0         0 return $C;
4250             }
4251             }
4252             }
4253 0         0 return undef;
4254             }
4255              
4256             #
4257             # ShiftJIS path globbing (with parameter)
4258             #
4259             sub Esjis::glob($) {
4260              
4261 0 0   0 0 0 if (wantarray) {
4262 0         0 my @glob = _DOS_like_glob(@_);
4263 0         0 for my $glob (@glob) {
4264 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4265             }
4266 0         0 return @glob;
4267             }
4268             else {
4269 0         0 my $glob = _DOS_like_glob(@_);
4270 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4271 0         0 return $glob;
4272             }
4273             }
4274              
4275             #
4276             # ShiftJIS path globbing (without parameter)
4277             #
4278             sub Esjis::glob_() {
4279              
4280 0 0   0 0 0 if (wantarray) {
4281 0         0 my @glob = _DOS_like_glob();
4282 0         0 for my $glob (@glob) {
4283 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4284             }
4285 0         0 return @glob;
4286             }
4287             else {
4288 0         0 my $glob = _DOS_like_glob();
4289 0         0 $glob =~ s{ \A (?:\./)+ }{}oxms;
4290 0         0 return $glob;
4291             }
4292             }
4293              
4294             #
4295             # ShiftJIS path globbing via File::DosGlob 1.10
4296             #
4297             # Often I confuse "_dosglob" and "_doglob".
4298             # So, I renamed "_dosglob" to "_DOS_like_glob".
4299             #
4300             my %iter;
4301             my %entries;
4302             sub _DOS_like_glob {
4303              
4304             # context (keyed by second cxix argument provided by core)
4305 0     0   0 my($expr,$cxix) = @_;
4306              
4307             # glob without args defaults to $_
4308 0 0       0 $expr = $_ if not defined $expr;
4309              
4310             # represents the current user's home directory
4311             #
4312             # 7.3. Expanding Tildes in Filenames
4313             # in Chapter 7. File Access
4314             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
4315             #
4316             # and File::HomeDir, File::HomeDir::Windows module
4317              
4318             # DOS-like system
4319 0 0       0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
    0          
4320 0         0 $expr =~ s{ \A ~ (?= [^/\\] ) }
  0         0  
4321             { my_home_MSWin32() }oxmse;
4322             }
4323              
4324             # Mac OS system
4325 0 0       0 elsif ($^O eq 'MacOS') {
4326 0         0 if ($expr =~ / \A ~ /oxms) {
  0         0  
4327             $expr =~ s{ \A ~ (?= [^/:] ) }
4328             { my_home_MacOS() }oxmse;
4329             }
4330             }
4331              
4332 0 0 0     0 # UNIX-like system
  0         0  
4333             else {
4334             $expr =~ s{ \A ~ ( (?:[^\x81-\x9F\xE0-\xFC/]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])* ) }
4335             { $1 ? (CORE::eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
4336 0 0       0 }
4337 0 0       0  
4338             # assume global context if not provided one
4339             $cxix = '_G_' if not defined $cxix;
4340 0 0       0 $iter{$cxix} = 0 if not exists $iter{$cxix};
4341 0 0       0  
4342             # if we're just beginning, do it all first
4343             if ($iter{$cxix} == 0) {
4344 0         0 if ($^O eq 'MacOS') {
4345              
4346             # first, take care of updirs and trailing colons
4347 0         0 my @expr = _canonpath_MacOS(_parse_line($expr));
4348              
4349 0 0       0 # expand volume names
  0         0  
4350             @expr = _expand_volume_MacOS(@expr);
4351              
4352 0         0 $entries{$cxix} = (@expr) ? [ map { _unescape_MacOS($_) } _do_glob_MacOS(1,@expr) ] : [()];
4353             }
4354             else {
4355             $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
4356             }
4357 0 0       0 }
4358 0         0  
4359 0         0 # chuck it all out, quick or slow
  0         0  
4360             if (wantarray) {
4361             delete $iter{$cxix};
4362 0 0       0 return @{delete $entries{$cxix}};
  0         0  
4363 0         0 }
  0         0  
4364             else {
4365             if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
4366             return shift @{$entries{$cxix}};
4367 0         0 }
4368 0         0 else {
4369 0         0 # return undef for EOL
4370             delete $iter{$cxix};
4371             delete $entries{$cxix};
4372             return undef;
4373             }
4374             }
4375             }
4376              
4377             #
4378             # ShiftJIS path globbing subroutine
4379 0     0   0 #
4380 0         0 sub _do_glob {
4381 0         0  
4382             my($cond,@expr) = @_;
4383             my @glob = ();
4384 0         0 my $fix_drive_relative_paths = 0;
4385 0 0       0  
4386 0 0       0 OUTER:
4387             for my $expr (@expr) {
4388 0         0 next OUTER if not defined $expr;
4389 0         0 next OUTER if $expr eq '';
4390 0         0  
4391 0         0 my @matched = ();
4392 0         0 my @globdir = ();
4393             my $head = '.';
4394             my $pathsep = '/';
4395 0 0       0 my $tail;
4396 0         0  
4397 0 0       0 # if argument is within quotes strip em and do no globbing
4398 0 0       0 if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4399 0         0 $expr = $1;
4400             if ($cond eq 'd') {
4401             if (Esjis::d $expr) {
4402             push @glob, $expr;
4403 0 0       0 }
4404 0         0 }
4405             else {
4406             if (Esjis::e $expr) {
4407 0         0 push @glob, $expr;
4408             }
4409             }
4410             next OUTER;
4411             }
4412 0 0       0  
4413 0 0       0 # wildcards with a drive prefix such as h:*.pm must be changed
4414 0         0 # to h:./*.pm to expand correctly
4415             if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
4416             if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^\x81-\x9F\xE0-\xFC/\\]|[\x81-\x9F\xE0-\xFC][\x00-\xFF]) #$1./$2#oxms) {
4417             $fix_drive_relative_paths = 1;
4418 0 0       0 }
4419 0 0       0 }
4420 0         0  
4421 0         0 if (($head, $tail) = _parse_path($expr,$pathsep)) {
4422             if ($tail eq '') {
4423 0 0       0 push @glob, $expr;
4424 0 0       0 next OUTER;
4425 0         0 }
  0         0  
4426 0         0 if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
4427             if (@globdir = _do_glob('d', $head)) {
4428             push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
4429 0 0 0     0 next OUTER;
4430 0         0 }
4431             }
4432 0         0 if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
4433             $head .= $pathsep;
4434             }
4435             $expr = $tail;
4436 0 0       0 }
4437 0 0       0  
4438 0         0 # If file component has no wildcards, we can avoid opendir
4439             if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
4440 0 0 0     0 if ($head eq '.') {
4441 0         0 $head = '';
4442             }
4443 0         0 if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4444 0 0       0 $head .= $pathsep;
4445 0 0       0 }
4446 0         0 $head .= $expr;
4447             if ($cond eq 'd') {
4448             if (Esjis::d $head) {
4449             push @glob, $head;
4450 0 0       0 }
4451 0         0 }
4452             else {
4453             if (Esjis::e $head) {
4454 0         0 push @glob, $head;
4455             }
4456 0 0       0 }
4457 0         0 next OUTER;
4458 0         0 }
4459             Esjis::opendir(*DIR, $head) or next OUTER;
4460 0 0       0 my @leaf = readdir DIR;
4461 0         0 closedir DIR;
4462              
4463 0 0 0     0 if ($head eq '.') {
4464 0         0 $head = '';
4465             }
4466             if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
4467 0         0 $head .= $pathsep;
4468 0         0 }
4469 0         0  
4470             my $pattern = '';
4471             while ($expr =~ / \G ($q_char) /oxgc) {
4472             my $char = $1;
4473              
4474             # 6.9. Matching Shell Globs as Regular Expressions
4475             # in Chapter 6. Pattern Matching
4476 0 0       0 # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
    0          
    0          
4477 0         0 # (and so on)
4478              
4479             if ($char eq '*') {
4480 0         0 $pattern .= "(?:$your_char)*",
4481             }
4482             elsif ($char eq '?') {
4483             $pattern .= "(?:$your_char)?", # DOS style
4484 0         0 # $pattern .= "(?:$your_char)", # UNIX style
4485             }
4486             elsif ((my $fc = Esjis::fc($char)) ne $char) {
4487 0         0 $pattern .= $fc;
4488             }
4489             else {
4490 0     0   0 $pattern .= quotemeta $char;
  0         0  
4491             }
4492             }
4493             my $matchsub = sub { Esjis::fc($_[0]) =~ /\A $pattern \z/xms };
4494              
4495             # if ($@) {
4496             # print STDERR "$0: $@\n";
4497             # next OUTER;
4498 0         0 # }
4499 0 0 0     0  
4500 0         0 INNER:
4501             for my $leaf (@leaf) {
4502 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
4503 0         0 next INNER;
4504             }
4505             if ($cond eq 'd' and not Esjis::d "$head$leaf") {
4506 0 0       0 next INNER;
4507 0         0 }
4508 0         0  
4509             if (&$matchsub($leaf)) {
4510             push @matched, "$head$leaf";
4511             next INNER;
4512             }
4513              
4514 0 0 0     0 # [DOS compatibility special case]
      0        
4515             # Failed, add a trailing dot and try again, but only...
4516              
4517             if (Esjis::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
4518 0 0       0 CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
4519 0         0 Esjis::index($pattern,'\\.') != -1 # pattern has a dot.
4520 0         0 ) {
4521             if (&$matchsub("$leaf.")) {
4522             push @matched, "$head$leaf";
4523             next INNER;
4524 0 0       0 }
4525 0         0 }
4526             }
4527             if (@matched) {
4528 0 0       0 push @glob, @matched;
4529 0         0 }
4530 0         0 }
4531             if ($fix_drive_relative_paths) {
4532             for my $glob (@glob) {
4533 0         0 $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
4534             }
4535             }
4536             return @glob;
4537             }
4538              
4539             #
4540             # ShiftJIS parse line
4541 0     0   0 #
4542             sub _parse_line {
4543 0         0  
4544 0         0 my($line) = @_;
4545 0         0  
4546             $line .= ' ';
4547             my @piece = ();
4548             while ($line =~ /
4549             " ( (?>(?: [^\x81-\x9F\xE0-\xFC"] |[\x81-\x9F\xE0-\xFC][\x00-\xFF] )* ) ) " (?>\s+) |
4550 0 0       0 ( (?>(?: [^\x81-\x9F\xE0-\xFC"\s]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] )* ) ) (?>\s+)
4551             /oxmsg
4552 0         0 ) {
4553             push @piece, defined($1) ? $1 : $2;
4554             }
4555             return @piece;
4556             }
4557              
4558             #
4559             # ShiftJIS parse path
4560 0     0   0 #
4561             sub _parse_path {
4562 0         0  
4563 0         0 my($path,$pathsep) = @_;
4564 0         0  
4565             $path .= '/';
4566             my @subpath = ();
4567             while ($path =~ /
4568 0         0 ((?: [^\x81-\x9F\xE0-\xFC\/\\]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] )+?) [\/\\]
4569             /oxmsg
4570             ) {
4571 0         0 push @subpath, $1;
4572 0         0 }
4573 0         0  
4574             my $tail = pop @subpath;
4575             my $head = join $pathsep, @subpath;
4576             return $head, $tail;
4577             }
4578              
4579             #
4580             # ShiftJIS path globbing on Mac OS
4581 0     0   0 #
4582 0         0 sub _do_glob_MacOS {
4583              
4584             my($cond,@expr) = @_;
4585 0         0 my @glob = ();
4586 0 0       0  
4587 0 0       0 OUTER_MACOS:
4588             for my $expr (@expr) {
4589 0         0 next OUTER_MACOS if not defined $expr;
4590 0         0 next OUTER_MACOS if $expr eq '';
4591 0         0  
4592 0         0 my @matched = ();
4593 0         0 my @globdir = ();
4594 0         0 my $head = ':';
4595             my $unesc_head = $head;
4596             my $pathsep = ':';
4597 0 0       0 my $tail;
4598 0         0  
4599             # if $expr is within quotes strip em and do no globbing
4600             if ($expr =~ /\A " ((?:$q_char)*?) " \z/oxms) {
4601 0         0 $expr = $1;
4602              
4603 0 0       0 # $expr may contain escaped metachars '\*', '\?', and '\'
4604 0 0       0 $expr = _unescape_MacOS($expr);
4605 0         0  
4606             if ($cond eq 'd') {
4607             if (Esjis::d $expr) {
4608             push @glob, $expr;
4609 0 0       0 }
4610 0         0 }
4611             else {
4612             if (Esjis::e $expr) {
4613 0         0 push @glob, $expr;
4614             }
4615             }
4616             next OUTER_MACOS;
4617 0 0       0 }
4618 0 0       0  
4619 0         0 # note: $1 is not greedy
4620 0         0 if (($head,$pathsep,$tail) = $expr =~ /\A ((?:$q_char)*?) (:+) ((?:[^\x81-\x9F\xE0-\xFC:]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])*?) \z/oxms) {
4621             if ($tail eq '') {
4622 0 0       0 push @glob, $expr;
4623 0 0       0 next OUTER_MACOS;
4624 0         0 }
  0         0  
4625 0         0 if (_hasmeta_MacOS($head)) {
4626             if (@globdir = _do_glob_MacOS('d', $head)) {
4627             push @glob, _do_glob_MacOS($cond, map {"$_$pathsep$tail"} @globdir);
4628 0         0 next OUTER_MACOS;
4629             }
4630             }
4631 0         0 $head .= $pathsep;
4632              
4633 0         0 # unescape $head for file operations
4634             $unesc_head = _unescape_MacOS($head);
4635              
4636             $expr = $tail;
4637 0 0       0 }
4638 0 0       0  
4639 0         0 # If file component has no wildcards, we can avoid opendir
4640             if (not _hasmeta_MacOS($expr)) {
4641 0         0 if ($head eq ':') {
4642             $unesc_head = $head = '';
4643             }
4644 0         0 $head .= $expr;
4645              
4646 0 0       0 # unescape $head and $expr for file operations
4647 0 0       0 $unesc_head .= _unescape_MacOS($expr);
4648 0         0  
4649             if ($cond eq 'd') {
4650             if (Esjis::d $unesc_head) {
4651             push @glob, $head;
4652 0 0       0 }
4653 0         0 }
4654             else {
4655             if (Esjis::e $unesc_head) {
4656 0         0 push @glob, $head;
4657             }
4658 0 0       0 }
4659 0         0 next OUTER_MACOS;
4660 0         0 }
4661             Esjis::opendir(*DIR, $head) or next OUTER_MACOS;
4662 0         0 my @leaf = readdir DIR;
4663 0     0   0 closedir DIR;
  0         0  
4664              
4665             my $pattern = _quotemeta_MacOS($expr);
4666             my $matchsub = sub { Esjis::fc($_[0]) =~ /\A $pattern \z/xms };
4667              
4668             # if ($@) {
4669             # print STDERR "$0: $@\n";
4670             # next OUTER_MACOS;
4671 0         0 # }
4672 0 0 0     0  
4673 0         0 INNER_MACOS:
4674             for my $leaf (@leaf) {
4675 0 0 0     0 if ($leaf eq '.' or $leaf eq '..') {
4676 0         0 next INNER_MACOS;
4677             }
4678             if ($cond eq 'd' and not Esjis::d qq{$unesc_head$leaf}) {
4679 0 0       0 next INNER_MACOS;
4680 0 0 0     0 }
4681              
4682             if (&$matchsub($leaf)) {
4683 0         0 if (($unesc_head eq ':') and (Esjis::f qq{$unesc_head$leaf})) {
4684             }
4685             else {
4686             $leaf = $unesc_head . $leaf;
4687             }
4688              
4689 0         0 # On Mac OS, the two glob metachars '*' and '?' and the escape
4690 0         0 # char '\' are valid characters for file and directory names.
4691             # We have to escape and treat them specially.
4692             push @matched, _escape_MacOS($leaf);
4693 0 0       0 next INNER_MACOS;
4694 0         0 }
4695             }
4696             if (@matched) {
4697 0         0 push @glob, @matched;
4698             }
4699             }
4700             return @glob;
4701             }
4702              
4703             #
4704             # _expand_volume_MacOS() will only be used on Mac OS (OS9 or older):
4705             # Takes an array of original patterns as argument and returns an array of
4706             # possibly modified patterns. Each original pattern is processed like
4707             # that:
4708             # + If there's a volume name in the pattern, we push a separate pattern
4709             # for each mounted volume that matches (with '*', '?', and '\' escaped).
4710             # + If there's no volume name in the original pattern, it is pushed
4711             # unchanged.
4712             # Note that the returned array of patterns may be empty.
4713 0     0   0 #
4714 0 0       0 sub _expand_volume_MacOS {
4715              
4716 0         0 CORE::eval q{ CORE::require MacPerl; };
4717 0         0 croak "Can't require MacPerl;" if $@;
4718 0         0  
4719             my @volume_glob = @_;
4720             my @expand_volume = ();
4721 0 0       0 for my $volume_glob (@volume_glob) {
4722 0         0  
4723 0         0 # volume name in pattern
4724             if ($volume_glob =~ /\A ((?:[^\x81-\x9F\xE0-\xFC:]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])+:) (.*) \z/oxms) {
4725 0         0 my $pattern = _quotemeta_MacOS($1);
  0         0  
4726 0 0       0 my $tail = $2;
4727              
4728             for my $volume (map { MacPerl::MakePath($_) } MacPerl::Volumes()) {
4729             if ($volume =~ /\A $pattern \z/xmsi) {
4730              
4731 0         0 # On Mac OS, the two glob metachars '*' and '?' and the
4732             # escape char '\' are valid characters for volume names.
4733             # We have to escape and treat them specially.
4734             push @expand_volume, _escape_MacOS($volume) . $tail;
4735             }
4736             }
4737             }
4738 0         0  
4739             # no volume name in pattern
4740             else {
4741 0         0 push @expand_volume, $volume_glob;
4742             }
4743             }
4744             return @expand_volume;
4745             }
4746              
4747             #
4748             # _canonpath_MacOS() will only be used on Mac OS (OS9 or older):
4749             # Resolves any updirs in the pattern. Removes a single trailing colon
4750 0     0   0 # from the pattern, unless it's a volume name pattern like "*HD:"
4751             #
4752 0         0 sub _canonpath_MacOS {
4753             my(@expr) = @_;
4754              
4755 0         0 for my $expr (@expr) {
4756              
4757             # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*"
4758 0         0 1 while ($expr =~ s/\A ((?:[^\x81-\x9F\xE0-\xFC:]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])*?) : (?:[^\x81-\x9F\xE0-\xFC:]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])+ :: ((?:$q_char)*?) \z/$1:$2/oxms);
4759              
4760 0         0 # remove a single trailing colon, e.g. ":*:" -> ":*"
4761             $expr =~ s/ : ((?:[^\x81-\x9F\xE0-\xFC:]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])+) : \z/:$1/oxms;
4762             }
4763             return @expr;
4764             }
4765              
4766             #
4767             # _escape_MacOS() will only be used on Mac OS (OS9 or older):
4768 0     0   0 # Escape metachars '*', '?', and '\' of arguments.
4769             #
4770             sub _escape_MacOS {
4771 0         0 my($expr) = @_;
4772 0         0  
4773 0         0 # escape regex metachars but not '\' and glob chars '*', '?'
4774 0 0       0 my $escape = '';
4775 0         0 while ($expr =~ / \G ($q_char) /oxmsgc) {
4776             my $char = $1;
4777             if ($char =~ /\A [*?\\] \z/oxms) {
4778 0         0 $escape .= '\\' . $char;
4779             }
4780             else {
4781 0         0 $escape .= $char;
4782             }
4783             }
4784             return $escape;
4785             }
4786              
4787             #
4788             # _unescape_MacOS() will only be used on Mac OS (OS9 or older):
4789             # Unescapes a list of arguments which may contain escaped
4790 0     0   0 # metachars '*', '?', and '\'.
4791             #
4792 0         0 sub _unescape_MacOS {
4793 0         0 my($expr) = @_;
4794 0         0  
4795 0 0       0 my $unescape = '';
4796 0         0 while ($expr =~ / \G (\\[*?\\] | $q_char) /oxmsgc) {
4797             my $char = $1;
4798             if ($char =~ /\A \\([*?\\]) \z/oxms) {
4799 0         0 $unescape .= $1;
4800             }
4801             else {
4802 0         0 $unescape .= $char;
4803             }
4804             }
4805             return $unescape;
4806             }
4807              
4808             #
4809 0     0   0 # _hasmeta_MacOS() will only be used on Mac OS (OS9 or older):
4810             #
4811             sub _hasmeta_MacOS {
4812             my($expr) = @_;
4813              
4814 0         0 # if a '*' or '?' is preceded by an odd count of '\', temporary delete
4815 0         0 # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as
4816 0 0       0 # wildcards
    0          
4817 0         0 while ($expr =~ / \G (\\[*?\\] | $q_char) /oxgc) {
4818             my $char = $1;
4819             if ($char eq '*') {
4820 0         0 return 1;
4821             }
4822             elsif ($char eq '?') {
4823 0         0 return 1;
4824             }
4825             }
4826             return 0;
4827             }
4828              
4829             #
4830 0     0   0 # _quotemeta_MacOS() will only be used on Mac OS (OS9 or older):
4831             #
4832             sub _quotemeta_MacOS {
4833 0         0 my($expr) = @_;
4834 0         0  
4835 0         0 # escape regex metachars but not '\' and glob chars '*', '?'
4836 0 0       0 my $quotemeta = '';
    0          
    0          
    0          
4837 0         0 while ($expr =~ / \G (\\[*?\\] | $q_char) /oxgc) {
4838             my $char = $1;
4839             if ($char =~ /\A \\[*?\\] \z/oxms) {
4840 0         0 $quotemeta .= $char;
4841             }
4842             elsif ($char eq '*') {
4843 0         0 $quotemeta .= "(?:$your_char)*",
4844             }
4845             elsif ($char eq '?') {
4846             $quotemeta .= "(?:$your_char)?", # DOS style
4847 0         0 # $quotemeta .= "(?:$your_char)", # UNIX style
4848             }
4849             elsif ((my $fc = Esjis::fc($char)) ne $char) {
4850 0         0 $quotemeta .= $fc;
4851             }
4852             else {
4853 0         0 $quotemeta .= quotemeta $char;
4854             }
4855             }
4856             return $quotemeta;
4857             }
4858              
4859             #
4860             # via File::HomeDir::Windows 1.00
4861             #
4862             sub my_home_MSWin32 {
4863              
4864 0 0 0 0 0 0 # A lot of unix people and unix-derived tools rely on
    0 0        
    0 0        
      0        
      0        
4865 0         0 # the ability to overload HOME. We will support it too
4866             # so that they can replace raw HOME calls with File::HomeDir.
4867             if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
4868             return $ENV{'HOME'};
4869             }
4870 0         0  
4871             # Do we have a user profile?
4872             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
4873             return $ENV{'USERPROFILE'};
4874             }
4875 0         0  
4876             # Some Windows use something like $ENV{'HOME'}
4877             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
4878 0         0 return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
4879             }
4880              
4881             return undef;
4882             }
4883              
4884             #
4885             # via File::HomeDir::MacOS9 1.00
4886             #
4887 0 0   0 0 0 sub my_home_MacOS {
4888 0         0  
4889             # Try for $ENV{'HOME'} if we have it
4890             if (defined $ENV{'HOME'}) {
4891             return $ENV{'HOME'};
4892             }
4893              
4894             ### DESPERATION SETS IN
4895 0         0  
  0         0  
4896 0         0 # We could use the desktop
4897             SCOPE: {
4898 0         0 local $@;
4899 0         0 CORE::eval {
4900 0         0 # Find the desktop via Mac::Files
4901             local $SIG{'__DIE__'} = '';
4902             CORE::require Mac::Files;
4903             my $home = Mac::Files::FindFolder(
4904 0 0 0     0 Mac::Files::kOnSystemDisk(),
4905             Mac::Files::kDesktopFolderType(),
4906             );
4907             return $home if $home and Esjis::d($home);
4908             };
4909             }
4910              
4911 0         0 # Desperation on any platform
  0         0  
4912 0         0 SCOPE: {
4913 0 0 0     0 # On some platforms getpwuid dies if called at all
4914             local $SIG{'__DIE__'} = '';
4915             my $home = CORE::eval q{ (getpwuid($<))[7] };
4916 0         0 return $home if $home and Esjis::d($home);
4917             }
4918              
4919             croak "Could not locate current user's home directory";
4920             }
4921              
4922             #
4923 0     0 0 0 # via File::HomeDir::Unix 1.00
4924             #
4925 0 0 0     0 sub my_home {
    0 0        
4926 0         0 my $home;
4927              
4928             if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
4929             $home = $ENV{'HOME'};
4930             }
4931              
4932 0         0 # This is from the original code, but I'm guessing
4933             # it means "login directory" and exists on some Unixes.
4934             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
4935             $home = $ENV{'LOGDIR'};
4936             }
4937              
4938             ### More-desperate methods
4939 0         0  
4940             # Light desperation on any (Unixish) platform
4941             else {
4942             $home = CORE::eval q{ (getpwuid($<))[7] };
4943             }
4944 0 0 0     0  
4945 0         0 # On Unix in general, a non-existant home means "no home"
4946             # For example, "nobody"-like users might use /nonexistant
4947 0         0 if (defined $home and ! Esjis::d($home)) {
4948             $home = undef;
4949             }
4950             return $home;
4951             }
4952              
4953             #
4954             # ShiftJIS file lstat (with parameter)
4955 0 0   0 0 0 #
4956             sub Esjis::lstat(*) {
4957 0 0       0  
    0          
4958 0         0 local $_ = shift if @_;
4959              
4960             if (-e $_) {
4961             return CORE::lstat _;
4962             }
4963             elsif (_MSWin32_5Cended_path($_)) {
4964              
4965             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Esjis::lstat()
4966 0         0 # on Windows opens the file for the path which has 5c at end.
4967 0 0       0 # (and so on)
4968 0 0       0  
4969 0         0 local *MUST_BE_BAREWORD_AT_HERE;
4970 0 0       0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4971 0         0 if (wantarray) {
4972             my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4973             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4974 0         0 return @stat;
4975 0 0       0 }
4976 0         0 else {
4977             my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4978             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
4979             return $stat;
4980 0 0       0 }
4981             }
4982             }
4983             return wantarray ? () : undef;
4984             }
4985              
4986             #
4987             # ShiftJIS file lstat (without parameter)
4988 0 0   0 0 0 #
    0          
4989 0         0 sub Esjis::lstat_() {
4990              
4991             if (-e $_) {
4992 0         0 return CORE::lstat _;
4993 0 0       0 }
4994 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
4995 0         0 local *MUST_BE_BAREWORD_AT_HERE;
4996 0 0       0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
4997 0         0 if (wantarray) {
4998             my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
4999             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
5000 0         0 return @stat;
5001 0 0       0 }
5002 0         0 else {
5003             my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE; # not CORE::lstat
5004             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
5005             return $stat;
5006 0 0       0 }
5007             }
5008             }
5009             return wantarray ? () : undef;
5010             }
5011              
5012             #
5013             # ShiftJIS path opendir
5014 0     0 0 0 #
5015 0 0       0 sub Esjis::opendir(*$) {
    0          
5016 0         0  
5017             my $dh = qualify_to_ref $_[0];
5018             if (CORE::opendir $dh, $_[1]) {
5019 0 0       0 return 1;
5020 0         0 }
5021             elsif (_MSWin32_5Cended_path($_[1])) {
5022             if (CORE::opendir $dh, "$_[1]/.") {
5023 0         0 return 1;
5024             }
5025             }
5026             return undef;
5027             }
5028              
5029             #
5030             # ShiftJIS file stat (with parameter)
5031 0 50   386 0 0 #
5032             sub Esjis::stat(*) {
5033 386         2512  
5034 386 50       2141 local $_ = shift if @_;
    50          
    0          
5035 386         13301  
5036             my $fh = qualify_to_ref $_;
5037             if (defined fileno $fh) {
5038 0         0 return CORE::stat $fh;
5039             }
5040             elsif (-e $_) {
5041             return CORE::stat _;
5042             }
5043             elsif (_MSWin32_5Cended_path($_)) {
5044              
5045             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Esjis::stat()
5046 386         3114 # on Windows opens the file for the path which has 5c at end.
5047 0 0       0 # (and so on)
5048 0 0       0  
5049 0         0 local *MUST_BE_BAREWORD_AT_HERE;
5050 0 0       0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
5051 0         0 if (wantarray) {
5052             my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
5053             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
5054 0         0 return @stat;
5055 0 0       0 }
5056 0         0 else {
5057             my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
5058             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
5059             return $stat;
5060 0 0       0 }
5061             }
5062             }
5063             return wantarray ? () : undef;
5064             }
5065              
5066             #
5067             # ShiftJIS file stat (without parameter)
5068 0     0 0 0 #
5069 0 0       0 sub Esjis::stat_() {
    0          
    0          
5070 0         0  
5071             my $fh = qualify_to_ref $_;
5072             if (defined fileno $fh) {
5073 0         0 return CORE::stat $fh;
5074             }
5075             elsif (-e $_) {
5076 0         0 return CORE::stat _;
5077 0 0       0 }
5078 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
5079 0         0 local *MUST_BE_BAREWORD_AT_HERE;
5080 0 0       0 if (CORE::open(MUST_BE_BAREWORD_AT_HERE, $_)) {
5081 0         0 if (wantarray) {
5082             my @stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
5083             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
5084 0         0 return @stat;
5085 0 0       0 }
5086 0         0 else {
5087             my $stat = CORE::stat MUST_BE_BAREWORD_AT_HERE;
5088             close(MUST_BE_BAREWORD_AT_HERE) or die "Can't close file: $_: $!";
5089             return $stat;
5090 0 0       0 }
5091             }
5092             }
5093             return wantarray ? () : undef;
5094             }
5095              
5096             #
5097             # ShiftJIS path unlink
5098 0 0   0 0 0 #
5099             sub Esjis::unlink(@) {
5100 0         0  
5101 0         0 local @_ = ($_) unless @_;
5102 0 0       0  
    0          
    0          
5103 0         0 my $unlink = 0;
5104             for (@_) {
5105             if (CORE::unlink) {
5106             $unlink++;
5107             }
5108 0         0 elsif (Esjis::d($_)) {
5109 0 0       0 }
  0         0  
5110 0 0       0 elsif (_MSWin32_5Cended_path($_)) {
5111 0         0 my @char = /\G (?>$q_char) /oxmsg;
5112             my $file = join '', map {{'/' => '\\'}->{$_} || $_} @char;
5113 0         0 if ($file =~ / \A (?:$q_char)*? [ ] /oxms) {
5114 0 0       0 $file = qq{"$file"};
5115 0 0       0 }
5116             my $fh = gensym();
5117             if (_open_r($fh, $_)) {
5118 0 0 0     0 close($fh) or die "Can't close file: $_: $!";
    0          
5119 0         0  
5120             # cmd.exe on Windows NT, Windows 2000, Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
5121             if ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
5122             CORE::system 'DEL', '/F', $file, '2>NUL';
5123             }
5124 0         0  
5125             # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
5126             elsif (qx{ver} =~ /\b(?:Windows 2000)\b/oms) {
5127             CORE::system 'DEL', '/F', $file, '2>NUL';
5128             }
5129              
5130 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
5131 0         0 # command.com can not "2>NUL"
5132             else {
5133             CORE::system 'ATTRIB', '-R', $file; # clears Read-only file attribute
5134 0 0       0 CORE::system 'DEL', $file;
5135 0 0       0 }
5136              
5137             if (_open_r($fh, $_)) {
5138 0         0 close($fh) or die "Can't close file: $_: $!";
5139             }
5140             else {
5141             $unlink++;
5142             }
5143 0         0 }
5144             }
5145             }
5146             return $unlink;
5147             }
5148              
5149             #
5150             # ShiftJIS chdir
5151 0 0   0 0 0 #
5152 0         0 sub Esjis::chdir(;$) {
5153              
5154             if (@_ == 0) {
5155 0         0 return CORE::chdir;
5156             }
5157 0 0       0  
5158 0 0       0 my($dir) = @_;
5159 0         0  
5160             if (_MSWin32_5Cended_path($dir)) {
5161             if (not Esjis::d $dir) {
5162 0 0 0     0 return 0;
    0          
5163 0         0 }
5164              
5165             if ($] =~ /^5\.005/oxms) {
5166 0         0 return CORE::chdir $dir;
5167 0         0 }
5168             elsif (($] =~ /^(?:5\.006|5\.008000)/oxms) and ($^O eq 'MSWin32')) {
5169             local $@;
5170             my $chdir = CORE::eval q{
5171             CORE::require 'jacode.pl';
5172              
5173             # P.676 ${^WIDE_SYSTEM_CALLS}
5174             # in Chapter 28: Special Names
5175             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5176              
5177             # P.790 ${^WIDE_SYSTEM_CALLS}
5178             # in Chapter 25: Special Names
5179             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5180              
5181 0 0       0 local ${^WIDE_SYSTEM_CALLS} = 1;
5182 0         0 return CORE::chdir jcode::utf8($dir,'sjis');
5183             };
5184             if (not $@) {
5185             return $chdir;
5186             }
5187             }
5188              
5189             # old idea (Win32 module required)
5190             elsif (0) {
5191             local $@;
5192             my $shortdir = '';
5193             my $chdir = CORE::eval q{
5194             use Win32;
5195             $shortdir = Win32::GetShortPathName($dir);
5196             if ($shortdir ne $dir) {
5197             return CORE::chdir $shortdir;
5198             }
5199             else {
5200             return 0;
5201             }
5202             };
5203             if ($@) {
5204             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
5205             while ($char[-1] eq "\x5C") {
5206             pop @char;
5207             }
5208             $dir = join '', @char;
5209             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path), Win32.pm module may help you";
5210             }
5211             elsif ($shortdir eq $dir) {
5212             my @char = $dir =~ /\G (?>$q_char) /oxmsg;
5213             while ($char[-1] eq "\x5C") {
5214             pop @char;
5215             }
5216             $dir = join '', @char;
5217             croak "Perl$] can't chdir to $dir (chr(0x5C) ended path)";
5218             }
5219             return $chdir;
5220 0         0 }
5221              
5222             # rejected idea ...
5223             elsif (0) {
5224              
5225             # MSDN SetCurrentDirectory function
5226             # http://msdn.microsoft.com/ja-jp/library/windows/desktop/aa365530(v=vs.85).aspx
5227             #
5228             # Data Execution Prevention (DEP)
5229             # http://vlaurie.com/computers2/Articles/dep.htm
5230             #
5231             # Learning x86 assembler with Perl -- Shibuya.pm#11
5232             # http://developer.cybozu.co.jp/takesako/2009/06/perl-x86-shibuy.html
5233             #
5234             # Introduction to Win32::API programming in Perl
5235             # http://d.hatena.ne.jp/TAKESAKO/20090324/1237879559
5236             #
5237             # DynaLoader - Dynamically load C libraries into Perl code
5238             # http://perldoc.perl.org/DynaLoader.html
5239             #
5240             # Basic knowledge of DynaLoader
5241             # http://blog.64p.org/entry/20090313/1236934042
5242              
5243             if (($] =~ /^5\.006/oxms) and
5244             ($^O eq 'MSWin32') and
5245             ($ENV{'PROCESSOR_ARCHITECTURE'} eq 'x86') and
5246             CORE::eval(q{CORE::require 'Dyna'.'Loader'})
5247             ) {
5248             my $x86 = join('',
5249              
5250             # PUSH Iv
5251             "\x68", pack('P', "$dir\\\0"),
5252              
5253             # MOV eAX, Iv
5254             "\xb8", pack('L',
5255             *{'Dyna'.'Loader::dl_find_symbol'}{'CODE'}->(
5256             *{'Dyna'.'Loader::dl_load_file'}{'CODE'}->("$ENV{'SystemRoot'}\\system32\\kernel32.dll"),
5257             'SetCurrentDirectoryA'
5258             )
5259             ),
5260              
5261             # CALL eAX
5262             "\xff\xd0",
5263              
5264             # RETN
5265             "\xc3",
5266             );
5267             *{'Dyna'.'Loader::dl_install_xsub'}{'CODE'}->('_SetCurrentDirectoryA', unpack('L', pack 'P', $x86));
5268             _SetCurrentDirectoryA();
5269             chomp(my $chdir = qx{chdir});
5270             if (Esjis::fc($chdir) eq Esjis::fc($dir)) {
5271             return 1;
5272             }
5273             else {
5274             return 0;
5275             }
5276             }
5277             }
5278              
5279             # COMMAND.COM's unhelpful tips:
5280             # Displays a list of files and subdirectories in a directory.
5281             # http://www.lagmonster.org/docs/DOS7/z-dir.html
5282             #
5283             # Syntax:
5284             #
5285             # DIR [drive:] [path] [filename] [/Switches]
5286             #
5287             # /Z Long file names are not displayed in the file listing
5288             #
5289             # Limitations
5290             # The undocumented /Z switch (no long names) would appear to
5291             # have been not fully developed and has a couple of problems:
5292             #
5293             # 1. It will only work if:
5294             # There is no path specified (ie. for the current directory in
5295             # the current drive)
5296             # The path is specified as the root directory of any drive
5297             # (eg. C:\, D:\, etc.)
5298             # The path is specified as the current directory of any drive
5299             # by using the drive letter only (eg. C:, D:, etc.)
5300             # The path is specified as the parent directory using the ..
5301             # notation (eg. DIR .. /Z)
5302             # Any other syntax results in a "File Not Found" error message.
5303             #
5304             # 2. The /Z switch is compatable with the /S switch to show
5305             # subdirectories (as long as the above rules are followed) and
5306             # all the files are shown with short names only. The
5307             # subdirectories are also shown with short names only. However,
5308             # the header for each subdirectory after the first level gives
5309             # the subdirectory's long name.
5310             #
5311             # 3. The /Z switch is also compatable with the /B switch to give
5312             # a simple list of files with short names only. When used with
5313             # the /S switch as well, all files are listed with their full
5314             # paths. The file names themselves are all in short form, and
5315             # the path of those files in the current directory are in short
5316 0         0 # form, but the paths of any files in subdirectories are in
5317 0         0 # long filename form.
5318 0         0  
5319 0         0 my $shortdir = '';
5320 0         0 my $i = 0;
5321 0 0 0     0 my @subdir = ();
5322 0         0 while ($dir =~ / \G ($q_char) /oxgc) {
5323 0         0 my $char = $1;
5324 0         0 if (($char eq '\\') or ($char eq '/')) {
5325             $i++;
5326             $subdir[$i] = $char;
5327 0         0 $i++;
5328             }
5329             else {
5330 0 0 0     0 $subdir[$i] .= $char;
5331 0         0 }
5332             }
5333             if (($subdir[-1] eq '\\') or ($subdir[-1] eq '/')) {
5334             pop @subdir;
5335             }
5336              
5337             # P.504 PERL5SHELL (Microsoft ports only)
5338             # in Chapter 19: The Command-Line Interface
5339             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5340              
5341             # P.597 PERL5SHELL (Microsoft ports only)
5342             # in Chapter 17: The Command-Line Interface
5343             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5344 0 0 0     0  
    0          
5345 0         0 # Win95Cmd.exe on any Windows (when SET PERL5SHELL=Win95Cmd.exe /c, `var` returns "Windows 2000")
5346 0         0 # cmd.exe on Windows NT, Windows 2000
  0         0  
5347 0 0       0 if (qx{ver} =~ /\b(?:Windows NT|Windows 2000)\b/oms) {
5348             chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5349             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5350 0         0 if (Esjis::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Esjis::fc($subdir[-1])) {
5351 0         0  
5352 0         0 # short file name (8dot3name) here-----vv
5353 0         0 my $shortleafdir = CORE::substr $dirx, 39, 8+1+3;
5354             $shortleafdir =~ s/ [ ]+ \z//oxms;
5355             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5356             last;
5357             }
5358             }
5359             }
5360              
5361             # an idea (not so portable, only Windows 2000 or later)
5362             elsif (0) {
5363             chomp($shortdir = qx{for %I in ("$dir") do \@echo %~sI 2>NUL});
5364             }
5365 0         0  
5366 0         0 # cmd.exe on Windows XP, Windows Vista, Windows 7, Windows 8, Windows 8.1, Windows 10 or later
  0         0  
5367 0 0       0 elsif ((defined $ENV{'OS'}) and ($ENV{'OS'} eq 'Windows_NT')) {
5368             chomp(my @dirx = grep //oxms, qx{dir /ad /x "$dir*" 2>NUL});
5369             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5370 0         0 if (Esjis::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Esjis::fc($subdir[-1])) {
5371 0         0  
5372 0         0 # short file name (8dot3name) here-----vv
5373 0         0 my $shortleafdir = CORE::substr $dirx, 36, 8+1+3;
5374             $shortleafdir =~ s/ [ ]+ \z//oxms;
5375             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5376             last;
5377             }
5378             }
5379             }
5380 0         0  
5381 0         0 # COMMAND.COM on Windows 95, Windows 98, Windows 98 Second Edition, Windows Millennium Edition
  0         0  
5382 0 0       0 else {
5383             chomp(my @dirx = grep //oxms, qx{dir /ad "$dir*"});
5384             for my $dirx (sort { CORE::length($a) <=> CORE::length($b) } @dirx) {
5385 0         0 if (Esjis::fc(CORE::substr $dirx,-CORE::length($subdir[-1]),CORE::length($subdir[-1])) eq Esjis::fc($subdir[-1])) {
5386 0         0  
5387 0         0 # short file name (8dot3name) here-----v
5388 0         0 my $shortleafdir = CORE::substr $dirx, 0, 8+1+3;
5389 0         0 CORE::substr($shortleafdir,8,1) = '.';
5390             $shortleafdir =~ s/ \. [ ]+ \z//oxms;
5391             $shortdir = join '', @subdir[0..$#subdir-1], $shortleafdir;
5392             last;
5393             }
5394 0 0       0 }
    0          
5395 0         0 }
5396              
5397             if ($shortdir eq '') {
5398 0         0 return 0;
5399             }
5400 0         0 elsif (Esjis::fc($shortdir) eq Esjis::fc($dir)) {
5401             return 0;
5402             }
5403 0         0 return CORE::chdir $shortdir;
5404             }
5405             else {
5406             return CORE::chdir $dir;
5407             }
5408             }
5409              
5410             #
5411             # ShiftJIS chr(0x5C) ended path on MSWin32
5412 0 50 33 772   0 #
5413 772 50       5467 sub _MSWin32_5Cended_path {
5414 772         4685  
5415 0 0       0 if ((@_ >= 1) and ($_[0] ne '')) {
5416 0         0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
5417             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5418             if ($char[-1] =~ / \x5C \z/oxms) {
5419             return 1;
5420 0         0 }
5421             }
5422             }
5423             return undef;
5424             }
5425              
5426             #
5427             # do ShiftJIS file
5428 772     0 0 2213 #
5429             sub Esjis::do($) {
5430 0         0  
5431             my($filename) = @_;
5432              
5433             my $realfilename;
5434 0         0 my $result;
  0         0  
5435 0 0       0 ITER_DO:
5436 0         0 {
5437             for my $prefix (@INC) {
5438             if ($^O eq 'MacOS') {
5439 0         0 $realfilename = "$prefix$filename";
5440             }
5441             else {
5442 0 0       0 $realfilename = "$prefix/$filename";
5443             }
5444 0         0  
5445             if (Esjis::f($realfilename)) {
5446 0 0       0  
5447 0         0 my $script = '';
5448 0         0  
5449 0         0 if (Esjis::e("$realfilename.e")) {
5450 0 0 0     0 my $e_mtime = (Esjis::stat("$realfilename.e"))[9];
5451 0         0 my $mtime = (Esjis::stat($realfilename))[9];
5452             my $module_mtime = (Esjis::stat(__FILE__))[9];
5453             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5454             Esjis::unlink "$realfilename.e";
5455 0 0       0 }
5456 0         0 }
5457 0 0       0  
5458 0 0       0 if (Esjis::e("$realfilename.e")) {
    0          
5459 0         0 my $fh = gensym();
5460             if (_open_r($fh, "$realfilename.e")) {
5461             if ($^O eq 'MacOS') {
5462             CORE::eval q{
5463             CORE::require Mac::Files;
5464             Mac::Files::FSpSetFLock("$realfilename.e");
5465             };
5466             }
5467             elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5468              
5469             # P.419 File Locking
5470             # in Chapter 16: Interprocess Communication
5471             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5472              
5473             # P.524 File Locking
5474             # in Chapter 15: Interprocess Communication
5475             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5476 0         0  
5477 0 0       0 # (and so on)
5478 0         0  
5479             CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5480             if ($@) {
5481             carp "Can't immediately read-lock the file: $realfilename.e";
5482 0         0 }
5483             }
5484 0         0 else {
5485 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5486 0 0       0 }
5487 0         0 local $/ = undef; # slurp mode
5488             $script = <$fh>;
5489             if ($^O eq 'MacOS') {
5490             CORE::eval q{
5491             CORE::require Mac::Files;
5492 0 0       0 Mac::Files::FSpRstFLock("$realfilename.e");
5493             };
5494             }
5495             close($fh) or die "Can't close file: $realfilename.e: $!";
5496 0         0 }
5497 0 0       0 }
5498 0 0       0 else {
    0          
5499 0         0 my $fh = gensym();
5500             if (_open_r($fh, $realfilename)) {
5501             if ($^O eq 'MacOS') {
5502             CORE::eval q{
5503             CORE::require Mac::Files;
5504             Mac::Files::FSpSetFLock($realfilename);
5505 0         0 };
5506 0 0       0 }
5507 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5508             CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5509             if ($@) {
5510             carp "Can't immediately read-lock the file: $realfilename";
5511 0         0 }
5512             }
5513 0         0 else {
5514 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5515 0 0       0 }
5516 0         0 local $/ = undef; # slurp mode
5517             $script = <$fh>;
5518             if ($^O eq 'MacOS') {
5519             CORE::eval q{
5520             CORE::require Mac::Files;
5521 0 0       0 Mac::Files::FSpRstFLock($realfilename);
5522             };
5523             }
5524 0 0       0 close($fh) or die "Can't close file: $realfilename.e: $!";
5525 0         0 }
5526 0         0  
5527 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
5528 0 0       0 CORE::require Sjis;
5529 0 0       0 $script = Sjis::escape_script($script);
    0          
5530 0         0 my $fh = gensym();
5531             open($fh, ">$realfilename.e") or die __FILE__, ": Can't write open file: $realfilename.e\n";
5532             if ($^O eq 'MacOS') {
5533             CORE::eval q{
5534             CORE::require Mac::Files;
5535             Mac::Files::FSpSetFLock("$realfilename.e");
5536 0         0 };
5537 0 0       0 }
5538 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5539             CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5540             if ($@) {
5541             carp "Can't immediately write-lock the file: $realfilename.e";
5542 0         0 }
5543             }
5544 0         0 else {
5545 0 0       0 CORE::eval q{ flock($fh, LOCK_EX) };
5546 0         0 }
  0         0  
5547 0 0       0 CORE::eval q{ truncate($fh, 0) };
5548 0         0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5549             print {$fh} $script;
5550             if ($^O eq 'MacOS') {
5551             CORE::eval q{
5552             CORE::require Mac::Files;
5553 0 0       0 Mac::Files::FSpRstFLock("$realfilename.e");
5554             };
5555             }
5556             close($fh) or die "Can't close file: $realfilename.e: $!";
5557             }
5558 391     391   5180 }
  391         2359  
  391         341323  
  0         0  
5559 0         0  
5560             {
5561 0         0 no strict;
5562             $result = scalar CORE::eval $script;
5563             }
5564             last ITER_DO;
5565             }
5566 0 0       0 }
    0          
5567 0         0 }
5568 0         0  
5569             if ($@) {
5570             $INC{$filename} = undef;
5571 0         0 return undef;
5572             }
5573             elsif (not $result) {
5574 0         0 return undef;
5575 0         0 }
5576             else {
5577             $INC{$filename} = $realfilename;
5578             return $result;
5579             }
5580             }
5581              
5582             #
5583             # require ShiftJIS file
5584             #
5585              
5586             # require
5587             # in Chapter 3: Functions
5588             # of ISBN 1-56592-149-6 Programming Perl, Second Edition.
5589             #
5590             # sub require {
5591             # my($filename) = @_;
5592             # return 1 if $INC{$filename};
5593             # my($realfilename, $result);
5594             # ITER: {
5595             # foreach $prefix (@INC) {
5596             # $realfilename = "$prefix/$filename";
5597             # if (-f $realfilename) {
5598             # $result = CORE::eval `cat $realfilename`;
5599             # last ITER;
5600             # }
5601             # }
5602             # die "Can't find $filename in \@INC";
5603             # }
5604             # die $@ if $@;
5605             # die "$filename did not return true value" unless $result;
5606             # $INC{$filename} = $realfilename;
5607             # return $result;
5608             # }
5609              
5610             # require
5611             # in Chapter 9: perlfunc: Perl builtin functions
5612             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5613             #
5614             # sub require {
5615             # my($filename) = @_;
5616             # if (exists $INC{$filename}) {
5617             # return 1 if $INC{$filename};
5618             # die "Compilation failed in require";
5619             # }
5620             # my($realfilename, $result);
5621             # ITER: {
5622             # foreach $prefix (@INC) {
5623             # $realfilename = "$prefix/$filename";
5624             # if (-f $realfilename) {
5625             # $INC{$filename} = $realfilename;
5626             # $result = do $realfilename;
5627             # last ITER;
5628             # }
5629             # }
5630             # die "Can't find $filename in \@INC";
5631             # }
5632             # if ($@) {
5633             # $INC{$filename} = undef;
5634             # die $@;
5635             # }
5636             # elsif (!$result) {
5637             # delete $INC{$filename};
5638             # die "$filename did not return true value";
5639             # }
5640             # else {
5641             # return $result;
5642             # }
5643             # }
5644 0 0   0 0 0  
5645             sub Esjis::require(;$) {
5646 0 0       0  
5647 0 0       0 local $_ = shift if @_;
5648 0         0  
5649             if (exists $INC{$_}) {
5650             return 1 if $INC{$_};
5651             croak "Compilation failed in require: $_";
5652             }
5653              
5654             # jcode.pl
5655             # ftp://ftp.iij.ad.jp/pub/IIJ/dist/utashiro/perl/
5656              
5657 0 0       0 # jacode.pl
5658 0         0 # http://search.cpan.org/dist/jacode/
5659              
5660             if (/ \b (?: jcode\.pl | jacode(?>[0-9]*)\.pl ) \z /oxms) {
5661 0         0 return CORE::require($_);
5662             }
5663              
5664             my $realfilename;
5665 0         0 my $result;
  0         0  
5666 0 0       0 ITER_REQUIRE:
5667 0         0 {
5668             for my $prefix (@INC) {
5669             if ($^O eq 'MacOS') {
5670 0         0 $realfilename = "$prefix$_";
5671             }
5672             else {
5673 0 0       0 $realfilename = "$prefix/$_";
5674 0         0 }
5675              
5676 0         0 if (Esjis::f($realfilename)) {
5677             $INC{$_} = $realfilename;
5678 0 0       0  
5679 0         0 my $script = '';
5680 0         0  
5681 0         0 if (Esjis::e("$realfilename.e")) {
5682 0 0 0     0 my $e_mtime = (Esjis::stat("$realfilename.e"))[9];
5683 0         0 my $mtime = (Esjis::stat($realfilename))[9];
5684             my $module_mtime = (Esjis::stat(__FILE__))[9];
5685             if (($e_mtime < $mtime) or ($mtime < $module_mtime)) {
5686             Esjis::unlink "$realfilename.e";
5687 0 0       0 }
5688 0         0 }
5689 0 0       0  
5690 0 0       0 if (Esjis::e("$realfilename.e")) {
    0          
5691 0         0 my $fh = gensym();
5692             _open_r($fh, "$realfilename.e") or croak "Can't open file: $realfilename.e";
5693             if ($^O eq 'MacOS') {
5694             CORE::eval q{
5695             CORE::require Mac::Files;
5696             Mac::Files::FSpSetFLock("$realfilename.e");
5697 0         0 };
5698 0 0       0 }
5699 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5700             CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5701             if ($@) {
5702             carp "Can't immediately read-lock the file: $realfilename.e";
5703 0         0 }
5704             }
5705 0         0 else {
5706 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5707 0 0       0 }
5708 0         0 local $/ = undef; # slurp mode
5709             $script = <$fh>;
5710             if ($^O eq 'MacOS') {
5711             CORE::eval q{
5712             CORE::require Mac::Files;
5713 0 0       0 Mac::Files::FSpRstFLock("$realfilename.e");
5714             };
5715             }
5716 0         0 close($fh) or croak "Can't close file: $realfilename: $!";
5717 0 0       0 }
5718 0 0       0 else {
    0          
5719 0         0 my $fh = gensym();
5720             _open_r($fh, $realfilename) or croak "Can't open file: $realfilename";
5721             if ($^O eq 'MacOS') {
5722             CORE::eval q{
5723             CORE::require Mac::Files;
5724             Mac::Files::FSpSetFLock($realfilename);
5725 0         0 };
5726 0 0       0 }
5727 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5728             CORE::eval q{ flock($fh, LOCK_SH | LOCK_NB) };
5729             if ($@) {
5730             carp "Can't immediately read-lock the file: $realfilename";
5731 0         0 }
5732             }
5733 0         0 else {
5734 0         0 CORE::eval q{ flock($fh, LOCK_SH) };
5735 0 0       0 }
5736 0         0 local $/ = undef; # slurp mode
5737             $script = <$fh>;
5738             if ($^O eq 'MacOS') {
5739             CORE::eval q{
5740             CORE::require Mac::Files;
5741 0 0       0 Mac::Files::FSpRstFLock($realfilename);
5742             };
5743 0 0       0 }
5744 0         0 close($fh) or croak "Can't close file: $realfilename: $!";
5745 0         0  
5746 0         0 if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
5747 0 0       0 CORE::require Sjis;
5748 0 0       0 $script = Sjis::escape_script($script);
    0          
5749 0         0 my $fh = gensym();
5750             open($fh, ">$realfilename.e") or croak "Can't write open file: $realfilename.e";
5751             if ($^O eq 'MacOS') {
5752             CORE::eval q{
5753             CORE::require Mac::Files;
5754             Mac::Files::FSpSetFLock("$realfilename.e");
5755 0         0 };
5756 0 0       0 }
5757 0         0 elsif (exists $ENV{'CHAR_NONBLOCK'}) {
5758             CORE::eval q{ flock($fh, LOCK_EX | LOCK_NB) };
5759             if ($@) {
5760             carp "Can't immediately write-lock the file: $realfilename.e";
5761 0         0 }
5762             }
5763 0         0 else {
5764 0 0       0 CORE::eval q{ flock($fh, LOCK_EX) };
5765 0         0 }
  0         0  
5766 0 0       0 CORE::eval q{ truncate($fh, 0) };
5767 0         0 seek($fh, 0, 0) or croak "Can't seek file: $realfilename.e";
5768             print {$fh} $script;
5769             if ($^O eq 'MacOS') {
5770             CORE::eval q{
5771             CORE::require Mac::Files;
5772 0 0       0 Mac::Files::FSpRstFLock("$realfilename.e");
5773             };
5774             }
5775             close($fh) or croak "Can't close file: $realfilename: $!";
5776             }
5777 391     391   6371 }
  391         896  
  391         370536  
  0         0  
5778 0         0  
5779             {
5780 0         0 no strict;
5781             $result = scalar CORE::eval $script;
5782             }
5783 0         0 last ITER_REQUIRE;
5784             }
5785             }
5786 0 0       0 croak "Can't find $_ in \@INC";
    0          
5787 0         0 }
5788 0         0  
5789             if ($@) {
5790             $INC{$_} = undef;
5791 0         0 croak $@;
5792 0         0 }
5793             elsif (not $result) {
5794             delete $INC{$_};
5795 0         0 croak "$_ did not return true value";
5796             }
5797             else {
5798             return $result;
5799             }
5800             }
5801              
5802             #
5803             # ShiftJIS telldir avoid warning
5804 0     772 0 0 #
5805             sub Esjis::telldir(*) {
5806 772         2318  
5807             local $^W = 0;
5808              
5809             return CORE::telldir $_[0];
5810             }
5811              
5812             #
5813 772 0   0 0 11948 # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
5814 0 0 0     0 #
5815 0         0 sub Esjis::PREMATCH {
5816             if (defined($&)) {
5817             if (defined($1) and (CORE::substr($&,-CORE::length($1),CORE::length($1)) eq $1)) {
5818 0         0 return CORE::substr($&,0,CORE::length($&)-CORE::length($1));
5819             }
5820             else {
5821             croak 'Use of "$`", $PREMATCH, and ${^PREMATCH} need to /( capture all )/ in regexp';
5822 0         0 }
5823             }
5824 0         0 else {
5825             return '';
5826             }
5827             return $`;
5828             }
5829              
5830             #
5831 0 0   0 0 0 # ${^MATCH}, $MATCH, $& the string that matched
5832 0 0       0 #
5833 0         0 sub Esjis::MATCH {
5834             if (defined($&)) {
5835             if (defined($1)) {
5836 0         0 return $1;
5837             }
5838             else {
5839             croak 'Use of "$&", $MATCH, and ${^MATCH} need to /( capture all )/ in regexp';
5840 0         0 }
5841             }
5842 0         0 else {
5843             return '';
5844             }
5845             return $&;
5846             }
5847              
5848             #
5849 0     0 0 0 # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
5850             #
5851             sub Esjis::POSTMATCH {
5852             return $';
5853             }
5854              
5855             #
5856             # ShiftJIS character to order (with parameter)
5857 0 0   0 1 0 #
5858             sub Sjis::ord(;$) {
5859 0 0       0  
5860 0         0 local $_ = shift if @_;
5861 0         0  
5862 0         0 if (/\A ($q_char) /oxms) {
5863 0         0 my @ord = unpack 'C*', $1;
5864             my $ord = 0;
5865 0         0 while (my $o = shift @ord) {
5866             $ord = $ord * 0x100 + $o;
5867             }
5868 0         0 return $ord;
5869             }
5870             else {
5871             return CORE::ord $_;
5872             }
5873             }
5874              
5875             #
5876             # ShiftJIS character to order (without parameter)
5877 0 0   0 0 0 #
5878 0         0 sub Sjis::ord_() {
5879 0         0  
5880 0         0 if (/\A ($q_char) /oxms) {
5881 0         0 my @ord = unpack 'C*', $1;
5882             my $ord = 0;
5883 0         0 while (my $o = shift @ord) {
5884             $ord = $ord * 0x100 + $o;
5885             }
5886 0         0 return $ord;
5887             }
5888             else {
5889             return CORE::ord $_;
5890             }
5891             }
5892              
5893             #
5894             # ShiftJIS reverse
5895 0 0   0 0 0 #
5896 0         0 sub Sjis::reverse(@) {
5897              
5898             if (wantarray) {
5899             return CORE::reverse @_;
5900             }
5901             else {
5902              
5903             # One of us once cornered Larry in an elevator and asked him what
5904             # problem he was solving with this, but he looked as far off into
5905 0         0 # the distance as he could in an elevator and said, "It seemed like
5906             # a good idea at the time."
5907              
5908             return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
5909             }
5910             }
5911              
5912             #
5913             # ShiftJIS getc (with parameter, without parameter)
5914 0     0 0 0 #
5915 0 0       0 sub Sjis::getc(;*@) {
5916 0 0 0     0  
5917             my($package) = caller;
5918 0         0 my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
  0         0  
5919 0         0 croak 'Too many arguments for Sjis::getc' if @_ and not wantarray;
5920 0         0  
5921 0         0 my @length = sort { $a <=> $b } keys %range_tr;
5922 0 0       0 my $getc = '';
5923 0 0       0 for my $length ($length[0] .. $length[-1]) {
5924 0 0       0 $getc .= CORE::getc($fh);
5925             if (exists $range_tr{CORE::length($getc)}) {
5926             if ($getc =~ /\A ${Esjis::dot_s} \z/oxms) {
5927             return wantarray ? ($getc,@_) : $getc;
5928 0 0       0 }
5929             }
5930             }
5931             return wantarray ? ($getc,@_) : $getc;
5932             }
5933              
5934             #
5935             # ShiftJIS length by character
5936 0 0   0 1 0 #
5937             sub Sjis::length(;$) {
5938 0         0  
5939 0         0 local $_ = shift if @_;
5940              
5941             local @_ = /\G ($q_char) /oxmsg;
5942             return scalar @_;
5943             }
5944              
5945             #
5946             # ShiftJIS substr by character
5947             #
5948             BEGIN {
5949              
5950             # P.232 The lvalue Attribute
5951             # in Chapter 6: Subroutines
5952             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
5953              
5954             # P.336 The lvalue Attribute
5955             # in Chapter 7: Subroutines
5956             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
5957              
5958             # P.144 8.4 Lvalue subroutines
5959 391 50 0 391 1 264377 # in Chapter 8: perlsub: Perl subroutines
  0 0   0   0  
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
5960             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
5961              
5962             CORE::eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
5963             # vv----------------------*******
5964             sub Sjis::substr($$;$$) %s {
5965              
5966             my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
5967              
5968             # If the substring is beyond either end of the string, substr() returns the undefined
5969             # value and produces a warning. When used as an lvalue, specifying a substring that
5970             # is entirely outside the string raises an exception.
5971             # http://perldoc.perl.org/functions/substr.html
5972              
5973             # A return with no argument returns the scalar value undef in scalar context,
5974             # an empty list () in list context, and (naturally) nothing at all in void
5975             # context.
5976              
5977             my $offset = $_[1];
5978             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
5979             return;
5980             }
5981              
5982             # substr($string,$offset,$length,$replacement)
5983             if (@_ == 4) {
5984             my(undef,undef,$length,$replacement) = @_;
5985             my $substr = join '', splice(@char, $offset, $length, $replacement);
5986             $_[0] = join '', @char;
5987              
5988             # return $substr; this doesn't work, don't say "return"
5989             $substr;
5990             }
5991              
5992             # substr($string,$offset,$length)
5993             elsif (@_ == 3) {
5994             my(undef,undef,$length) = @_;
5995             my $octet_offset = 0;
5996             my $octet_length = 0;
5997             if ($offset == 0) {
5998             $octet_offset = 0;
5999             }
6000             elsif ($offset > 0) {
6001             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
6002             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
6003             }
6004             else {
6005             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
6006             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
6007             }
6008             if ($length == 0) {
6009             $octet_length = 0;
6010             }
6011             elsif ($length > 0) {
6012             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
6013             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
6014             }
6015             else {
6016             local $SIG{__WARN__} = sub {}; # avoid: Use of uninitialized value in join or string at here
6017             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
6018             }
6019             CORE::substr($_[0], $octet_offset, $octet_length);
6020             }
6021              
6022             # substr($string,$offset)
6023             else {
6024             my $octet_offset = 0;
6025             if ($offset == 0) {
6026             $octet_offset = 0;
6027             }
6028             elsif ($offset > 0) {
6029             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
6030             }
6031             else {
6032             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
6033             }
6034             CORE::substr($_[0], $octet_offset);
6035             }
6036             }
6037             END
6038             }
6039              
6040             #
6041             # ShiftJIS index by character
6042 0     0 1 0 #
6043 0 0       0 sub Sjis::index($$;$) {
6044 0         0  
6045             my $index;
6046             if (@_ == 3) {
6047 0         0 $index = Esjis::index($_[0], $_[1], CORE::length(Sjis::substr($_[0], 0, $_[2])));
6048             }
6049             else {
6050 0 0       0 $index = Esjis::index($_[0], $_[1]);
6051 0         0 }
6052              
6053             if ($index == -1) {
6054 0         0 return -1;
6055             }
6056             else {
6057             return Sjis::length(CORE::substr $_[0], 0, $index);
6058             }
6059             }
6060              
6061             #
6062             # ShiftJIS rindex by character
6063 0     0 1 0 #
6064 0 0       0 sub Sjis::rindex($$;$) {
6065 0         0  
6066             my $rindex;
6067             if (@_ == 3) {
6068 0         0 $rindex = Esjis::rindex($_[0], $_[1], CORE::length(Sjis::substr($_[0], 0, $_[2])));
6069             }
6070             else {
6071 0 0       0 $rindex = Esjis::rindex($_[0], $_[1]);
6072 0         0 }
6073              
6074             if ($rindex == -1) {
6075 0         0 return -1;
6076             }
6077             else {
6078             return Sjis::length(CORE::substr $_[0], 0, $rindex);
6079             }
6080             }
6081 391     391   6430  
  391         2531  
  391         42959  
6082             # when 'm//', '/' means regexp match 'm//' and '?' means regexp match '??'
6083             # when 'div', '/' means division operator and '?' means conditional operator (condition ? then : else)
6084             use vars qw($slash); $slash = 'm//';
6085              
6086             # ord() to ord() or Sjis::ord()
6087             my $function_ord = 'ord';
6088              
6089             # ord to ord or Sjis::ord_
6090             my $function_ord_ = 'ord';
6091              
6092             # reverse to reverse or Sjis::reverse
6093             my $function_reverse = 'reverse';
6094              
6095             # getc to getc or Sjis::getc
6096             my $function_getc = 'getc';
6097              
6098             # P.1023 Appendix W.9 Multibyte Anchoring
6099             # of ISBN 1-56592-224-7 CJKV Information Processing
6100              
6101 391     391   4267 my $anchor = '';
  391     0   897  
  391         22073000  
6102             $anchor = q{${Esjis::anchor}};
6103              
6104             use vars qw($nest);
6105              
6106             # regexp of nested parens in qqXX
6107              
6108             # P.340 Matching Nested Constructs with Embedded Code
6109             # in Chapter 7: Perl
6110             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6111              
6112             my $qq_paren = qr{(?{local $nest=0}) (?>(?:
6113             [^\x81-\x9F\xE0-\xFC\\()] |
6114             \( (?{$nest++}) |
6115             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6116             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6117             \\ [^\x81-\x9F\xE0-\xFCc] |
6118             \\c[\x40-\x5F] |
6119             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6120             [\x00-\xFF]
6121             }xms;
6122              
6123             my $qq_brace = qr{(?{local $nest=0}) (?>(?:
6124             [^\x81-\x9F\xE0-\xFC\\{}] |
6125             \{ (?{$nest++}) |
6126             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6127             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6128             \\ [^\x81-\x9F\xE0-\xFCc] |
6129             \\c[\x40-\x5F] |
6130             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6131             [\x00-\xFF]
6132             }xms;
6133              
6134             my $qq_bracket = qr{(?{local $nest=0}) (?>(?:
6135             [^\x81-\x9F\xE0-\xFC\\\[\]] |
6136             \[ (?{$nest++}) |
6137             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6138             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6139             \\ [^\x81-\x9F\xE0-\xFCc] |
6140             \\c[\x40-\x5F] |
6141             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6142             [\x00-\xFF]
6143             }xms;
6144              
6145             my $qq_angle = qr{(?{local $nest=0}) (?>(?:
6146             [^\x81-\x9F\xE0-\xFC\\<>] |
6147             \< (?{$nest++}) |
6148             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6149             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6150             \\ [^\x81-\x9F\xE0-\xFCc] |
6151             \\c[\x40-\x5F] |
6152             \\ [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6153             [\x00-\xFF]
6154             }xms;
6155              
6156             my $qq_scalar = qr{(?: \{ (?:$qq_brace)*? \} |
6157             (?: ::)? (?:
6158             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
6159             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
6160             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
6161             ))
6162             }xms;
6163              
6164             my $qq_variable = qr{(?: \{ (?:$qq_brace)*? \} |
6165             (?: ::)? (?:
6166             (?>[0-9]+) |
6167             [^\x81-\x9F\xE0-\xFCa-zA-Z_0-9\[\]] |
6168             ^[A-Z] |
6169             (?> [a-zA-Z_][a-zA-Z_0-9]* (?: ::[a-zA-Z_][a-zA-Z_0-9]*)* )
6170             (?>(?: \[ (?: \$\[ | \$\] | $qq_char )*? \] | \{ (?:$qq_brace)*? \} )*)
6171             (?>(?: (?: -> )? (?: [\$\@\%\&\*]\* | \$\#\* | [\@\%]? \[ (?: \$\[ | \$\] | $qq_char )*? \] | [\@\%\*]? \{ (?:$qq_brace)*? \} ) )*)
6172             ))
6173             }xms;
6174              
6175             my $qq_substr = qr{(?> Char::substr | Sjis::substr | CORE::substr | substr ) (?>\s*) \( $qq_paren \)
6176             }xms;
6177              
6178             # regexp of nested parens in qXX
6179             my $q_paren = qr{(?{local $nest=0}) (?>(?:
6180             [^\x81-\x9F\xE0-\xFC()] |
6181             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6182             \( (?{$nest++}) |
6183             \) (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6184             [\x00-\xFF]
6185             }xms;
6186              
6187             my $q_brace = qr{(?{local $nest=0}) (?>(?:
6188             [^\x81-\x9F\xE0-\xFC\{\}] |
6189             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6190             \{ (?{$nest++}) |
6191             \} (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6192             [\x00-\xFF]
6193             }xms;
6194              
6195             my $q_bracket = qr{(?{local $nest=0}) (?>(?:
6196             [^\x81-\x9F\xE0-\xFC\[\]] |
6197             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6198             \[ (?{$nest++}) |
6199             \] (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6200             [\x00-\xFF]
6201             }xms;
6202              
6203             my $q_angle = qr{(?{local $nest=0}) (?>(?:
6204             [^\x81-\x9F\xE0-\xFC<>] |
6205             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
6206             \< (?{$nest++}) |
6207             \> (?(?{$nest>0})(?{$nest--})|(?!)))*) (?(?{$nest!=0})(?!)) |
6208             [\x00-\xFF]
6209             }xms;
6210              
6211             my $matched = '';
6212             my $s_matched = '';
6213             $matched = q{$Esjis::matched};
6214             $s_matched = q{ Esjis::s_matched();};
6215              
6216             my $tr_variable = ''; # variable of tr///
6217             my $sub_variable = ''; # variable of s///
6218             my $bind_operator = ''; # =~ or !~
6219              
6220             my @heredoc = (); # here document
6221             my @heredoc_delimiter = ();
6222             my $here_script = ''; # here script
6223              
6224             #
6225 0 50   386 0 0 # escape ShiftJIS script
6226             #
6227             sub Sjis::escape(;$) {
6228             local($_) = $_[0] if @_;
6229              
6230             # P.359 The Study Function
6231 386         1443 # in Chapter 7: Perl
6232             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6233              
6234             study $_; # Yes, I studied study yesterday.
6235              
6236             # while all script
6237              
6238             # 6.14. Matching from Where the Last Pattern Left Off
6239             # in Chapter 6. Pattern Matching
6240             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
6241             # (and so on)
6242              
6243             # one member of Tag-team
6244             #
6245             # P.128 Start of match (or end of previous match): \G
6246             # P.130 Advanced Use of \G with Perl
6247             # in Chapter 3: Overview of Regular Expression Features and Flavors
6248             # P.255 Use leading anchors
6249             # P.256 Expose ^ and \G at the front expressions
6250             # in Chapter 6: Crafting an Efficient Expression
6251             # P.315 "Tag-team" matching with /gc
6252 386         880 # in Chapter 7: Perl
6253 386         746 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6254 386         1542  
6255             my $e_script = '';
6256             while (not /\G \z/oxgc) { # member
6257 187610         308754 $e_script .= Sjis::escape_token();
6258             }
6259              
6260             return $e_script;
6261             }
6262              
6263             #
6264             # escape ShiftJIS token of script
6265             #
6266             sub Sjis::escape_token {
6267 386     187610 0 6569  
6268             # \n output here document
6269              
6270             my $ignore_modules = join('|', qw(
6271             utf8
6272             bytes
6273             charnames
6274             I18N::Japanese
6275             I18N::Collate
6276             I18N::JExt
6277             File::DosGlob
6278             Wild
6279             Wildcard
6280             Japanese
6281             ));
6282              
6283             # another member of Tag-team
6284             #
6285             # P.315 "Tag-team" matching with /gc
6286 187610 100 100     230069 # in Chapter 7: Perl
    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          
6287 187610         15028739 # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
6288 31566 100       41115  
6289 31566         57692 if (/\G ( \n ) /oxgc) { # another member (and so on)
6290             my $heredoc = '';
6291 197         299 if (scalar(@heredoc_delimiter) >= 1) {
6292 197         434 $slash = 'm//';
6293              
6294             $heredoc = join '', @heredoc;
6295 197         380 @heredoc = ();
6296 197         380  
6297             # skip here document
6298 205         1333 for my $heredoc_delimiter (@heredoc_delimiter) {
6299             /\G .*? \n $heredoc_delimiter \n/xmsgc;
6300 197         417 }
6301             @heredoc_delimiter = ();
6302 197         311  
6303             $here_script = '';
6304             }
6305             return "\n" . $heredoc;
6306 31566         98371 }
6307              
6308             # ignore space, comment
6309             elsif (/\G ((?>\s+)|\#.*) /oxgc) { return $1; }
6310              
6311             # if (, elsif (, unless (, while (, until (, given (, and when (
6312              
6313             # given, when
6314              
6315             # P.225 The given Statement
6316             # in Chapter 15: Smart Matching and given-when
6317             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6318              
6319             # P.133 The given Statement
6320             # in Chapter 4: Statements and Declarations
6321 42866         136671 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6322 3797         6036  
6323             elsif (/\G ( (?: if | elsif | unless | while | until | given | when ) (?>\s*) \( ) /oxgc) {
6324             $slash = 'm//';
6325             return $1;
6326             }
6327              
6328             # scalar variable ($scalar = ...) =~ tr///;
6329             # scalar variable ($scalar = ...) =~ s///;
6330              
6331             # state
6332              
6333             # P.68 Persistent, Private Variables
6334             # in Chapter 4: Subroutines
6335             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6336              
6337             # P.160 Persistent Lexically Scoped Variables: state
6338             # in Chapter 4: Statements and Declarations
6339             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6340              
6341 3797         12174 # (and so on)
6342              
6343 170 50       471 elsif (/\G ( \( (?>\s*) (?: local \b | my \b | our \b | state \b )? (?>\s*) \$ $qq_scalar ) /oxgc) {
    50          
6344 170         6667 my $e_string = e_string($1);
6345 0         0  
6346 0         0 if (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6347 0         0 $tr_variable = $e_string . e_string($1);
6348             $bind_operator = $2;
6349             $slash = 'm//';
6350 0         0 return '';
6351 0         0 }
6352 0         0 elsif (/\G ( (?>\s*) = $qq_paren \) ) ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6353 0         0 $sub_variable = $e_string . e_string($1);
6354             $bind_operator = $2;
6355             $slash = 'm//';
6356 0         0 return '';
6357 170         357 }
6358             else {
6359             $slash = 'div';
6360             return $e_string;
6361             }
6362             }
6363 170         737  
6364 4         19 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Esjis::PREMATCH()
6365             elsif (/\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
6366             $slash = 'div';
6367             return q{Esjis::PREMATCH()};
6368             }
6369 4         15  
6370 28         60 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Esjis::MATCH()
6371             elsif (/\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
6372             $slash = 'div';
6373             return q{Esjis::MATCH()};
6374             }
6375 28         88  
6376 1         2 # $', ${'} --> $', ${'}
6377             elsif (/\G ( \$' | \$\{'\} ) /oxmsgc) {
6378             $slash = 'div';
6379             return $1;
6380             }
6381 1         8  
6382 3         8 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Esjis::POSTMATCH()
6383             elsif (/\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
6384             $slash = 'div';
6385             return q{Esjis::POSTMATCH()};
6386             }
6387              
6388             # scalar variable $scalar =~ tr///;
6389             # scalar variable $scalar =~ s///;
6390 3         10 # substr() =~ tr///;
6391             # substr() =~ s///;
6392 2895 100       6896 elsif (/\G ( \$ $qq_scalar | $qq_substr ) /oxgc) {
    100          
6393 2895         11982 my $scalar = e_string($1);
6394 9         15  
6395 9         17 if (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= (?: tr | y ) \b ) /oxgc) {
6396 9         13 $tr_variable = $scalar;
6397             $bind_operator = $1;
6398             $slash = 'm//';
6399 9         28 return '';
6400 254         432 }
6401 254         485 elsif (/\G ( (?>\s*) (?: =~ | !~ ) (?>\s*) ) (?= s \b ) /oxgc) {
6402 254         352 $sub_variable = $scalar;
6403             $bind_operator = $1;
6404             $slash = 'm//';
6405 254         757 return '';
6406 2632         4059 }
6407             else {
6408             $slash = 'div';
6409             return $scalar;
6410             }
6411             }
6412 2632         7515  
6413             # end of statement
6414             elsif (/\G ( [,;] ) /oxgc) {
6415 12285         19311 $slash = 'm//';
6416              
6417             # clear tr/// variable
6418 12285         15113 $tr_variable = '';
6419              
6420 12285         14292 # clear s/// variable
6421             $sub_variable = '';
6422 12285         14061  
6423             $bind_operator = '';
6424              
6425             return $1;
6426             }
6427 12285         43866  
6428             # bareword
6429             elsif (/\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
6430             return $1;
6431             }
6432 0         0  
6433 2         5 # $0 --> $0
6434             elsif (/\G ( \$ 0 ) /oxmsgc) {
6435             $slash = 'div';
6436 2         8 return $1;
6437 0         0 }
6438             elsif (/\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
6439             $slash = 'div';
6440             return $1;
6441             }
6442 0         0  
6443 1         3 # $$ --> $$
6444             elsif (/\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
6445             $slash = 'div';
6446             return $1;
6447             }
6448              
6449 1         4 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
6450 219         385 # $1, $2, $3 --> $1, $2, $3 otherwise
6451             elsif (/\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
6452             $slash = 'div';
6453 219         552 return e_capture($1);
6454 0         0 }
6455             elsif (/\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
6456             $slash = 'div';
6457             return e_capture($1);
6458             }
6459 0         0  
6460 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
6461             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
6462             $slash = 'div';
6463             return e_capture($1.'->'.$2);
6464             }
6465 0         0  
6466 0         0 # $$foo{ ... } --> $ $foo->{ ... }
6467             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
6468             $slash = 'div';
6469             return e_capture($1.'->'.$2);
6470             }
6471 0         0  
6472 0         0 # $$foo
6473             elsif (/\G \$ ( \$ (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
6474             $slash = 'div';
6475             return e_capture($1);
6476             }
6477 0         0  
6478 0         0 # ${ foo }
6479             elsif (/\G \$ (?>\s*) \{ ( (?>\s*) (?> [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* ) (?>\s*) ) \} /oxmsgc) {
6480             $slash = 'div';
6481             return '${' . $1 . '}';
6482             }
6483 0         0  
6484 0         0 # ${ ... }
6485             elsif (/\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
6486             $slash = 'div';
6487             return e_capture($1);
6488             }
6489              
6490 0         0 # variable or function
6491 605         1071 # $ @ % & * $ #
6492             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) {
6493             $slash = 'div';
6494             return $1;
6495             }
6496 605         2236 # $ $ $ $ $ $ $ $ $ $ $ $ $ $
6497 103         240 # $ @ # \ ' " / ? ( ) [ ] < >
6498             elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
6499             $slash = 'div';
6500             return $1;
6501             }
6502 103         397  
6503             # while ()
6504             elsif (/\G \b (while (?>\s*) \( (?>\s*) <[\$]?[A-Za-z_][A-Za-z_0-9]*> (?>\s*) \)) \b /oxgc) {
6505             return $1;
6506             }
6507              
6508             # while () --- glob
6509              
6510 0         0 # avoid "Error: Runtime exception" of perl version 5.005_03
6511              
6512             elsif (/\G \b while (?>\s*) \( (?>\s*) < ((?:[^\x81-\x9F\xE0-\xFC>\0\a\e\f\n\r\t]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])+?) > (?>\s*) \) \b /oxgc) {
6513             return 'while ($_ = Esjis::glob("' . $1 . '"))';
6514             }
6515 0         0  
6516             # while (glob)
6517             elsif (/\G \b while (?>\s*) \( (?>\s*) glob (?>\s*) \) /oxgc) {
6518             return 'while ($_ = Esjis::glob_)';
6519             }
6520 0         0  
6521             # while (glob(WILDCARD))
6522             elsif (/\G \b while (?>\s*) \( (?>\s*) glob \b /oxgc) {
6523             return 'while ($_ = Esjis::glob';
6524 0         0 }
  484         1167  
6525              
6526             # doit if, doit unless, doit while, doit until, doit for, doit when
6527 484         1928 elsif (/\G \b ( if | unless | while | until | for | when ) \b /oxgc) { $slash = 'm//'; return $1; }
  19         34  
6528 19         64  
  0         0  
6529 0         0 # subroutines of package Esjis
  13         28  
6530 13         44 elsif (/\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $slash = 'm//'; return $1; }
  0         0  
6531 0         0 elsif (/\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  114         191  
6532 114         410 elsif (/\G \b Sjis::eval (?= (?>\s*) \{ ) /oxgc) { $slash = 'm//'; return 'eval'; }
  2         5  
6533 2         6 elsif (/\G \b Char::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Char::escape'; }
  2         5  
6534 2         8 elsif (/\G \b Sjis::eval \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'eval Sjis::escape'; }
  2         5  
6535 2         7 elsif (/\G \b bytes::substr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'substr'; }
  0         0  
6536 0         0 elsif (/\G \b chop \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::chop'; }
  2         5  
6537 2         33 elsif (/\G \b bytes::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'index'; }
  2         5  
6538 2         7 elsif (/\G \b Char::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::index'; }
  2         4  
6539 2         8 elsif (/\G \b Sjis::index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Sjis::index'; }
  0         0  
6540 0         0 elsif (/\G \b index \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::index'; }
  2         4  
6541 2         24 elsif (/\G \b bytes::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'rindex'; }
  2         3  
6542 2         7 elsif (/\G \b Char::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Char::rindex'; }
  1         3  
6543 1         5 elsif (/\G \b Sjis::rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Sjis::rindex'; }
  0         0  
6544 0         0 elsif (/\G \b rindex \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::rindex'; }
  0         0  
6545 0         0 elsif (/\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::lc'; }
  0         0  
6546 0         0 elsif (/\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::lcfirst'; }
  3         4  
6547             elsif (/\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::uc'; }
6548             elsif (/\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::ucfirst'; }
6549             elsif (/\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::fc'; }
6550              
6551             # stacked file test operators
6552              
6553             # P.179 File Test Operators
6554             # in Chapter 12: File Tests
6555             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
6556              
6557             # P.106 Named Unary and File Test Operators
6558             # in Chapter 3: Unary and Binary Operators
6559             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
6560              
6561 3         9 # (and so on)
  0         0  
6562 0         0  
  0         0  
6563 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6564 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6565 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6566 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6567 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  1         3  
6568             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6569             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
6570 1         7 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; }
  5         12  
6571 5         23  
  0         0  
6572 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6573 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6574 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6575 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6576 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  1         4  
6577             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6578             elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
6579 1         6 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6580 0         0  
  0         0  
6581 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6582 0         0 { $slash = 'm//'; return "Esjis::filetest(qw($1),$2)"; }
  0         0  
6583             elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1),$2)"; }
6584 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $slash = 'm//'; return "Esjis::filetest qw($1),"; }
  0         0  
6585 0         0 elsif (/\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Esjis::filetest(qw($1),$2)"; }
  0         0  
6586 0         0  
  0         0  
6587 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('', $2,$4,$3) . ")"; }
  0         0  
6588 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6589 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6590 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  2         6  
6591             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
6592 2         8 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  103         237  
6593 103         385 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; }
  0         0  
6594 0         0  
  0         0  
6595 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('', $2,$4,$3) . ")"; }
  0         0  
6596 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6597 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  0         0  
6598 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  2         21  
6599             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6600             elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; }
6601 2         12 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $slash = 'm//'; return "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; }
  6         11  
6602 6         28  
  0         0  
6603 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6604 0         0 { $slash = 'm//'; return "Esjis::$1($2)"; }
  50         133  
6605 50         294 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "Esjis::$1($2)"; }
  2         8  
6606 2         13 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return "Esjis::$1"; }
  1         4  
6607 1         5 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "Esjis::$1(::"."$2)"; }
  3         7  
6608             elsif (/\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-t $2"; }
6609             elsif (/\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::lstat'; }
6610 3         11 elsif (/\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::stat'; }
  0         0  
6611 0         0  
  0         0  
6612 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
6613 0         0 elsif (/\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $slash = 'm//'; return '-s ' . e_qq('', $1,$3,$2); }
  0         0  
6614 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6615 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6616 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6617             elsif (/\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
6618 0         0 elsif (/\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_qq('qq',$1,$3,$2); }
  0         0  
6619 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  
6620 0         0  
  0         0  
6621 0         0 elsif (/\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $slash = 'm//'; return '-s ' . e_q ('', $1,$3,$2); }
  0         0  
6622 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6623 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6624 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6625             elsif (/\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6626             elsif (/\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
6627 0         0 elsif (/\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $slash = 'm//'; return '-s ' . e_q ('q', $1,$3,$2); }
  0         0  
6628 0         0  
  0         0  
6629 0         0 elsif (/\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)* ) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
6630 0         0 { $slash = 'm//'; return "-s $1"; }
  0         0  
6631             elsif (/\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $slash = 'm//'; return "-s ($1)"; }
6632 0         0 elsif (/\G -s (?= (?>\s+) [a-z]+) /oxgc) { $slash = 'm//'; return '-s'; }
  2         5  
6633 2         9 elsif (/\G -s (?>\s+) ((?>\w+)) /oxgc) { $slash = 'm//'; return "-s $1"; }
  2         5  
6634 2         8  
  36         82  
6635 36         164 elsif (/\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'length'; }
  2         7  
6636 2         10 elsif (/\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         5  
6637 2         10 elsif (/\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::chr'; }
  8         23  
6638 8         33 elsif (/\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return 'ord'; }
  0         0  
6639 0         0 elsif (/\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'div'; return $function_ord; }
  0         0  
6640 0         0 elsif (/\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $slash = 'm//'; return 'Esjis::glob'; }
  0         0  
6641 0         0 elsif (/\G \b lc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::lc_'; }
  0         0  
6642 0         0 elsif (/\G \b lcfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::lcfirst_'; }
  0         0  
6643 0         0 elsif (/\G \b uc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::uc_'; }
  0         0  
6644 0         0 elsif (/\G \b ucfirst \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::ucfirst_'; }
  0         0  
6645             elsif (/\G \b fc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::fc_'; }
6646 0         0 elsif (/\G \b lstat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::lstat_'; }
  0         0  
6647             elsif (/\G \b stat \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::stat_'; }
6648 0         0 elsif (/\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
6649             \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Esjis::filetest_(qw($1))"; }
6650 0         0 elsif (/\G -([rwxoRWXOezsfdlpSbcugkTBMAC])
  0         0  
6651             \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return "Esjis::${1}_"; }
6652 0         0  
  0         0  
6653 0         0 elsif (/\G -s \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return '-s '; }
  0         0  
6654 0         0  
  0         0  
6655 0         0 elsif (/\G \b bytes::length \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'length'; }
  0         0  
6656 0         0 elsif (/\G \b bytes::chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'chr'; }
  2         6  
6657 2         8 elsif (/\G \b chr \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::chr_'; }
  0         0  
6658 0         0 elsif (/\G \b bytes::ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return 'ord'; }
  4         7  
6659 4         15 elsif (/\G \b ord \b (?! (?>\s*) => ) /oxgc) { $slash = 'div'; return $function_ord_; }
  8         24  
6660 8         31 elsif (/\G \b glob \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::glob_'; }
  2         9  
6661 2         16 elsif (/\G \b reverse \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_reverse; }
  0         0  
6662 0         0 elsif (/\G \b getc \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return $function_getc; }
  87         254  
6663             elsif (/\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Esjis::opendir$1*"; }
6664             elsif (/\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $slash = 'm//'; return "Esjis::opendir$1*"; }
6665             elsif (/\G \b unlink \b (?! (?>\s*) => ) /oxgc) { $slash = 'm//'; return 'Esjis::unlink'; }
6666 87         354  
6667             # chdir
6668 3         9 elsif (/\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
6669             $slash = 'm//';
6670 3         5  
6671 3         15 my $e = 'Esjis::chdir';
6672              
6673             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6674             $e .= $1;
6675 3 50       15 }
  3 100       278  
    50          
    50          
    50          
    0          
6676              
6677             # end of chdir
6678 0         0 if (/\G (?= [,;\)\}\]] ) /oxgc) { return $e; }
6679              
6680             # chdir scalar value
6681             elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return $e . e_string($1); }
6682 1 0       5  
  0         0  
6683             # chdir qq//
6684 0         0 elsif (/\G \b (qq) \b /oxgc) {
6685 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6686 0         0 else {
6687 0         0 while (not /\G \z/oxgc) {
6688 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6689 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq ( ) --> qr ( )
6690 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq { } --> qr { }
6691 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq [ ] --> qr [ ]
6692             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq < > --> qr < >
6693 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq','{','}',$2); } # qq | | --> qr { }
6694             elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_chdir('qq',$1,$3,$2); } # qq * * --> qr * *
6695             }
6696             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6697             }
6698             }
6699 0 0       0  
  0         0  
6700             # chdir q//
6701 0         0 elsif (/\G \b (q) \b /oxgc) {
6702 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6703 0         0 else {
6704 0         0 while (not /\G \z/oxgc) {
6705 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6706 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q ( ) --> qr ( )
6707 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q { } --> qr { }
6708 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q [ ] --> qr [ ]
6709             elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q < > --> qr < >
6710 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q','{','}',$2); } # q | | --> qr { }
6711             elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return $e . e_chdir_q('q',$1,$3,$2); } # q * * --> qr * *
6712             }
6713             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6714             }
6715             }
6716 0         0  
6717 2         6 # chdir ''
6718 2 50       8 elsif (/\G (\') /oxgc) {
  13 50       70  
    100          
    50          
6719 0         0 my $q_string = '';
6720 0         0 while (not /\G \z/oxgc) {
6721 2         7 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6722             elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
6723 11         28 elsif (/\G \' /oxgc) { return $e . e_chdir_q('',"'","'",$q_string); }
6724             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6725             }
6726             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6727             }
6728 0         0  
6729 0         0 # chdir ""
6730 0 0       0 elsif (/\G (\") /oxgc) {
  0 0       0  
    0          
    0          
6731 0         0 my $qq_string = '';
6732 0         0 while (not /\G \z/oxgc) {
6733 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6734             elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
6735 0         0 elsif (/\G \" /oxgc) { return $e . e_chdir('','"','"',$qq_string); }
6736             elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6737             }
6738             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6739             }
6740             }
6741 0         0  
6742             # split
6743 404         951 elsif (/\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
6744 404         622 $slash = 'm//';
6745 404         1460  
6746             my $e = '';
6747             while (/\G ( (?>\s+) | \( | \#.* ) /oxgc) {
6748             $e .= $1;
6749 401 100       1703 }
  404 100       18520  
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    100          
    50          
    50          
    50          
6750              
6751             # end of split
6752 3         17 if (/\G (?= [,;\)\}\]] ) /oxgc) { return 'Esjis::split' . $e; }
6753              
6754             # split scalar value
6755 1         8 elsif (/\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { return 'Esjis::split' . $e . e_string($1); }
6756 0         0  
6757 0         0 # split literal space
6758 0         0 elsif (/\G \b qq (\#) [ ] (\#) /oxgc) { return 'Esjis::split' . $e . qq {qq$1 $2}; }
6759 0         0 elsif (/\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Esjis::split' . $e . qq{$1qq$2 $3}; }
6760 0         0 elsif (/\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Esjis::split' . $e . qq{$1qq$2 $3}; }
6761 0         0 elsif (/\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Esjis::split' . $e . qq{$1qq$2 $3}; }
6762 0         0 elsif (/\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Esjis::split' . $e . qq{$1qq$2 $3}; }
6763 0         0 elsif (/\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Esjis::split' . $e . qq{$1qq$2 $3}; }
6764 0         0 elsif (/\G \b q (\#) [ ] (\#) /oxgc) { return 'Esjis::split' . $e . qq {q$1 $2}; }
6765 0         0 elsif (/\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { return 'Esjis::split' . $e . qq {$1q$2 $3}; }
6766 0         0 elsif (/\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { return 'Esjis::split' . $e . qq {$1q$2 $3}; }
6767 0         0 elsif (/\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { return 'Esjis::split' . $e . qq {$1q$2 $3}; }
6768 13         95 elsif (/\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { return 'Esjis::split' . $e . qq {$1q$2 $3}; }
6769             elsif (/\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { return 'Esjis::split' . $e . qq {$1q$2 $3}; }
6770             elsif (/\G ' [ ] ' /oxgc) { return 'Esjis::split' . $e . qq {' '}; }
6771             elsif (/\G " [ ] " /oxgc) { return 'Esjis::split' . $e . qq {" "}; }
6772 2 0       12  
  0         0  
6773             # split qq//
6774 0         0 elsif (/\G \b (qq) \b /oxgc) {
6775 0 0       0 if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6776 0         0 else {
6777 0         0 while (not /\G \z/oxgc) {
6778 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6779 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq ( ) --> qr ( )
6780 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq { } --> qr { }
6781 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq [ ] --> qr [ ]
6782             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq < > --> qr < >
6783 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr','{','}',$2,''); } # qq | | --> qr { }
6784             elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return e_split($e.'qr',$1,$3,$2,''); } # qq * * --> qr * *
6785             }
6786             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6787             }
6788             }
6789 0 50       0  
  124         896  
6790             # split qr//
6791 0         0 elsif (/\G \b (qr) \b /oxgc) {
6792 124 50       355 if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # qr# #
  124 50       6330  
    50          
    50          
    50          
    100          
    50          
    50          
6793 0         0 else {
6794 0         0 while (not /\G \z/oxgc) {
6795 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6796 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr ( )
6797 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr { }
6798 56         174 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr [ ]
6799 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr < >
6800             elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # qr ' '
6801 68         369 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # qr | | --> qr { }
6802             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # qr * *
6803             }
6804             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6805             }
6806             }
6807 0 0       0  
  0         0  
6808             # split q//
6809 0         0 elsif (/\G \b (q) \b /oxgc) {
6810 0 0       0 if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
6811 0         0 else {
6812 0         0 while (not /\G \z/oxgc) {
6813 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6814 0         0 elsif (/\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q ( ) --> qr ( )
6815 0         0 elsif (/\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q { } --> qr { }
6816 0         0 elsif (/\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q [ ] --> qr [ ]
6817             elsif (/\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q < > --> qr < >
6818 0         0 elsif (/\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr','{','}',$2,''); } # q | | --> qr { }
6819             elsif (/\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { return e_split_q($e.'qr',$1,$3,$2,''); } # q * * --> qr * *
6820             }
6821             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6822             }
6823             }
6824 0 50       0  
  136         1121  
6825             # split m//
6826 0         0 elsif (/\G \b (m) \b /oxgc) {
6827 136 50       471 if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1,$3,$2,$4); } # m# # --> qr # #
  136 50       7162  
    50          
    50          
    50          
    100          
    50          
    50          
6828 0         0 else {
6829 0         0 while (not /\G \z/oxgc) {
6830 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6831 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m ( ) --> qr ( )
6832 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m { } --> qr { }
6833 56         207 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m [ ] --> qr [ ]
6834 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m < > --> qr < >
6835             elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return e_split_q($e.'qr',$1, $3, $2,$4); } # m ' ' --> qr ' '
6836 80         422 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr','{','}',$2,$4); } # m | | --> qr { }
6837             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return e_split ($e.'qr',$1, $3, $2,$4); } # m * * --> qr * *
6838             }
6839             die __FILE__, ": Search pattern not terminated\n";
6840             }
6841             }
6842 0         0  
6843 0         0 # split ''
6844 0 0       0 elsif (/\G (\') /oxgc) {
  0 0       0  
    0          
    0          
6845 0         0 my $q_string = '';
6846 0         0 while (not /\G \z/oxgc) {
6847 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
6848             elsif (/\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
6849 0         0 elsif (/\G \' /oxgc) { return e_split_q($e.q{ qr},"'","'",$q_string,''); } # ' ' --> qr ' '
6850             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
6851             }
6852             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6853             }
6854 0         0  
6855 0         0 # split ""
6856 0 0       0 elsif (/\G (\") /oxgc) {
  0 0       0  
    0          
    0          
6857 0         0 my $qq_string = '';
6858 0         0 while (not /\G \z/oxgc) {
6859 0         0 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6860             elsif (/\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
6861 0         0 elsif (/\G \" /oxgc) { return e_split($e.q{ qr},'"','"',$qq_string,''); } # " " --> qr " "
6862             elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
6863             }
6864             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6865             }
6866 0         0  
6867 125         318 # split //
6868 125 50       395 elsif (/\G (\/) /oxgc) {
  558 50       3042  
    100          
    50          
6869 0         0 my $regexp = '';
6870 0         0 while (not /\G \z/oxgc) {
6871 125         499 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
6872             elsif (/\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
6873 433         1097 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_split($e.q{ qr}, '/','/',$regexp,$1); } # / / --> qr / /
6874             elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
6875             }
6876             die __FILE__, ": Search pattern not terminated\n";
6877             }
6878             }
6879              
6880             # tr/// or y///
6881              
6882             # about [cdsrbB]* (/B modifier)
6883             #
6884             # P.559 appendix C
6885             # of ISBN 4-89052-384-7 Programming perl
6886 0         0 # (Japanese title is: Perl puroguramingu)
6887              
6888             elsif (/\G \b ( tr | y ) \b /oxgc) {
6889 11 50       33 my $ope = $1;
6890 11         174  
6891 0         0 # $1 $2 $3 $4 $5 $6
6892             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cdsrbB]*) /oxgc) { # tr# # #
6893             my @tr = ($tr_variable,$2);
6894 0         0 return e_tr(@tr,'',$4,$6);
6895 11         22 }
6896 11 50       34 else {
  11 50       822  
    50          
    50          
    50          
    50          
6897             my $e = '';
6898 0         0 while (not /\G \z/oxgc) {
6899 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6900 0 0       0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
6901 0         0 my @tr = ($tr_variable,$2);
6902 0         0 while (not /\G \z/oxgc) {
6903 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6904 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) ( )
6905 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) { }
6906             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) [ ]
6907 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) < >
6908             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr ( ) * *
6909             }
6910 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
6911 0         0 }
6912 0 0       0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
6913 0         0 my @tr = ($tr_variable,$2);
6914 0         0 while (not /\G \z/oxgc) {
6915 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6916 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } ( )
6917 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } { }
6918             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } [ ]
6919 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } < >
6920             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr { } * *
6921             }
6922 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
6923 0         0 }
6924 0 0       0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
6925 0         0 my @tr = ($tr_variable,$2);
6926 0         0 while (not /\G \z/oxgc) {
6927 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6928 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] ( )
6929 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] { }
6930             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] [ ]
6931 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] < >
6932             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr [ ] * *
6933             }
6934 0         0 die __FILE__, ": Transliteration replacement not terminated\n";
6935 0         0 }
6936 0 0       0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
6937 0         0 my @tr = ($tr_variable,$2);
6938 0         0 while (not /\G \z/oxgc) {
6939 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6940 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > ( )
6941 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > { }
6942             elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > [ ]
6943 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > < >
6944             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { return e_tr(@tr,$e,$2,$4); } # tr < > * *
6945             }
6946             die __FILE__, ": Transliteration replacement not terminated\n";
6947 0         0 }
6948 11         55 # $1 $2 $3 $4 $5 $6
6949             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cdsrbB]*) /oxgc) { # tr * * *
6950             my @tr = ($tr_variable,$2);
6951 11         35 return e_tr(@tr,'',$4,$6);
6952             }
6953             }
6954             die __FILE__, ": Transliteration pattern not terminated\n";
6955             }
6956             }
6957 0         0  
6958             # qq//
6959             elsif (/\G \b (qq) \b /oxgc) {
6960 5900 100       16529 my $ope = $1;
6961 5900         12257  
6962 40         69 # if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { return e_qq($ope,$1,$3,$2); } # qq# #
6963 40 100       104 if (/\G (\#) /oxgc) { # qq# #
  1948 50       6376  
    100          
    50          
6964 80         179 my $qq_string = '';
6965 0         0 while (not /\G \z/oxgc) {
6966 40         119 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6967             elsif (/\G (\\\#) /oxgc) { $qq_string .= $1; }
6968 1828         4054 elsif (/\G (\#) /oxgc) { return e_qq($ope,'#','#',$qq_string); }
6969             elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6970             }
6971             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6972 0         0 }
6973 5860         8187  
6974 5860 50       14712 else {
  5860 50       23305  
    100          
    50          
    100          
    50          
6975             my $e = '';
6976             while (not /\G \z/oxgc) {
6977             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
6978 0         0  
6979 0         0 # elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq ( )
6980 0         0 elsif (/\G (\() /oxgc) { # qq ( )
6981 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
    0          
6982 0         0 local $nest = 1;
6983 0         0 while (not /\G \z/oxgc) {
  0         0  
6984             if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
6985 0 0       0 elsif (/\G (\\\)) /oxgc) { $qq_string .= $1; }
  0         0  
6986 0         0 elsif (/\G (\() /oxgc) { $qq_string .= $1; $nest++; }
6987             elsif (/\G (\)) /oxgc) {
6988 0         0 if (--$nest == 0) { return $e . e_qq($ope,'(',')',$qq_string); }
6989             else { $qq_string .= $1; }
6990 0         0 }
6991             elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
6992             }
6993             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
6994             }
6995 0         0  
6996 5778         8159 # elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq { }
6997 5778         8429 elsif (/\G (\{) /oxgc) { # qq { }
6998 5778 100       12834 my $qq_string = '';
  246074 50       805153  
    100          
    100          
    50          
6999 720         1594 local $nest = 1;
7000 0         0 while (not /\G \z/oxgc) {
  1384         2202  
7001             if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7002 1384 100       2618 elsif (/\G (\\\}) /oxgc) { $qq_string .= $1; }
  7162         12212  
7003 5778         12924 elsif (/\G (\{) /oxgc) { $qq_string .= $1; $nest++; }
7004             elsif (/\G (\}) /oxgc) {
7005 1384         2951 if (--$nest == 0) { return $e . e_qq($ope,'{','}',$qq_string); }
7006             else { $qq_string .= $1; }
7007 236808         482098 }
7008             elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
7009             }
7010             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7011             }
7012 0         0  
7013 0         0 # elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq [ ]
7014 0         0 elsif (/\G (\[) /oxgc) { # qq [ ]
7015 0 0       0 my $qq_string = '';
  0 0       0  
    0          
    0          
    0          
7016 0         0 local $nest = 1;
7017 0         0 while (not /\G \z/oxgc) {
  0         0  
7018             if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7019 0 0       0 elsif (/\G (\\\]) /oxgc) { $qq_string .= $1; }
  0         0  
7020 0         0 elsif (/\G (\[) /oxgc) { $qq_string .= $1; $nest++; }
7021             elsif (/\G (\]) /oxgc) {
7022 0         0 if (--$nest == 0) { return $e . e_qq($ope,'[',']',$qq_string); }
7023             else { $qq_string .= $1; }
7024 0         0 }
7025             elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
7026             }
7027             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7028             }
7029 0         0  
7030 62         121 # elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq < >
7031 62         116 elsif (/\G (\<) /oxgc) { # qq < >
7032 62 100       194 my $qq_string = '';
  2040 50       8158  
    100          
    100          
    50          
7033 22         56 local $nest = 1;
7034 0         0 while (not /\G \z/oxgc) {
  2         3  
7035             if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7036 2 100       6 elsif (/\G (\\\>) /oxgc) { $qq_string .= $1; }
  64         172  
7037 62         181 elsif (/\G (\<) /oxgc) { $qq_string .= $1; $nest++; }
7038             elsif (/\G (\>) /oxgc) {
7039 2         5 if (--$nest == 0) { return $e . e_qq($ope,'<','>',$qq_string); }
7040             else { $qq_string .= $1; }
7041 1952         4173 }
7042             elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
7043             }
7044             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7045             }
7046 0         0  
7047 20         33 # elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qq * *
7048 20         61 elsif (/\G (\S) /oxgc) { # qq * *
7049 20 50       49 my $delimiter = $1;
  840 50       2785  
    100          
    50          
7050 0         0 my $qq_string = '';
7051 0         0 while (not /\G \z/oxgc) {
7052 20         49 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7053             elsif (/\G (\\\Q$delimiter\E) /oxgc) { $qq_string .= $1; }
7054 820         1752 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_qq($ope,$delimiter,$delimiter,$qq_string); }
7055             elsif (/\G ($qq_char) /oxgc) { $qq_string .= $1; }
7056             }
7057 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7058             }
7059             }
7060             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7061             }
7062             }
7063 0         0  
7064 184 50       571 # qr//
7065 184         872 elsif (/\G \b (qr) \b /oxgc) {
7066             my $ope = $1;
7067             if (/\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { # qr# # #
7068 0         0 return e_qr($ope,$1,$3,$2,$4);
7069 184         289 }
7070 184 50       499 else {
  184 50       5405  
    100          
    50          
    50          
    100          
    50          
    50          
7071 0         0 my $e = '';
7072 0         0 while (not /\G \z/oxgc) {
7073 1         6 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7074 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr ( )
7075 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr { }
7076 76         263 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr [ ]
7077 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr < >
7078             elsif (/\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # qr ' '
7079 107         388 elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # qr | | --> qr { }
7080             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # qr * *
7081             }
7082             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7083             }
7084             }
7085 0         0  
7086 34 50       106 # qw//
7087 34         99 elsif (/\G \b (qw) \b /oxgc) {
7088             my $ope = $1;
7089             if (/\G (\#) (.*?) (\#) /oxmsgc) { # qw# #
7090 0         0 return e_qw($ope,$1,$3,$2);
7091 34         59 }
7092 34 50       112 else {
  34 50       187  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7093             my $e = '';
7094 0         0 while (not /\G \z/oxgc) {
7095 34         113 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7096              
7097 0         0 elsif (/\G (\() ([^(]*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
7098 0         0 elsif (/\G (\() ((?:$q_paren)*?) (\)) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw ( )
7099              
7100 0         0 elsif (/\G (\{) ([^{]*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
7101 0         0 elsif (/\G (\{) ((?:$q_brace)*?) (\}) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw { }
7102              
7103 0         0 elsif (/\G (\[) ([^[]*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
7104 0         0 elsif (/\G (\[) ((?:$q_bracket)*?) (\]) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw [ ]
7105              
7106 0         0 elsif (/\G (\<) ([^<]*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
7107 0         0 elsif (/\G (\<) ((?:$q_angle)*?) (\>) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw < >
7108              
7109 0         0 elsif (/\G ([\x21-\x3F]) (.*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
7110             elsif (/\G (\S) ((?:$q_char)*?) (\1) /oxmsgc) { return $e . e_qw($ope,$1,$3,$2); } # qw * *
7111             }
7112             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7113             }
7114             }
7115 0         0  
7116 3 50       12 # qx//
7117 3         79 elsif (/\G \b (qx) \b /oxgc) {
7118             my $ope = $1;
7119             if (/\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
7120 0         0 return e_qq($ope,$1,$3,$2);
7121 3         6 }
7122 3 50       13 else {
  3 50       466  
    100          
    50          
    50          
    50          
    50          
7123 0         0 my $e = '';
7124 0         0 while (not /\G \z/oxgc) {
7125 2         7 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7126 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx ( )
7127 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx { }
7128 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx [ ]
7129             elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx < >
7130 1         6 elsif (/\G (\') ((?:$qq_char)*?) (\') /oxgc) { return $e . e_q ($ope,$1,$3,$2); } # qx ' '
7131             elsif (/\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { return $e . e_qq($ope,$1,$3,$2); } # qx * *
7132             }
7133             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7134             }
7135             }
7136 0         0  
7137             # q//
7138             elsif (/\G \b (q) \b /oxgc) {
7139             my $ope = $1;
7140              
7141             # if (/\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { return e_q($ope,$1,$3,$2); } # q# #
7142              
7143 607 50       2259 # avoid "Error: Runtime exception" of perl version 5.005_03
7144 607         2086 # (and so on)
7145 0         0  
7146 0 0       0 if (/\G (\#) /oxgc) { # q# #
  0 0       0  
    0          
    0          
7147 0         0 my $q_string = '';
7148 0         0 while (not /\G \z/oxgc) {
7149 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7150             elsif (/\G (\\\#) /oxgc) { $q_string .= $1; }
7151 0         0 elsif (/\G (\#) /oxgc) { return e_q($ope,'#','#',$q_string); }
7152             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7153             }
7154             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7155 0         0 }
7156 607         1273  
7157 607 50       2182 else {
  607 100       3951  
    100          
    50          
    100          
    50          
7158             my $e = '';
7159             while (not /\G \z/oxgc) {
7160             if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7161 0         0  
7162 1         3 # elsif (/\G (\() ((?:\\\)|\\\\|$q_paren)*?) (\)) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q ( )
7163 1         2 elsif (/\G (\() /oxgc) { # q ( )
7164 1 50       5 my $q_string = '';
  7 50       60  
    50          
    50          
    100          
    50          
7165 0         0 local $nest = 1;
7166 0         0 while (not /\G \z/oxgc) {
7167 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7168             elsif (/\G (\\\)) /oxgc) { $q_string .= $1; }
7169 0 50       0 elsif (/\G (\\\() /oxgc) { $q_string .= $1; }
  1         8  
7170 1         4 elsif (/\G (\() /oxgc) { $q_string .= $1; $nest++; }
7171             elsif (/\G (\)) /oxgc) {
7172 0         0 if (--$nest == 0) { return $e . e_q($ope,'(',')',$q_string); }
7173             else { $q_string .= $1; }
7174 6         17 }
7175             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7176             }
7177             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7178             }
7179 0         0  
7180 600         1193 # elsif (/\G (\{) ((?:\\\}|\\\\|$q_brace)*?) (\}) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q { }
7181 600         1237 elsif (/\G (\{) /oxgc) { # q { }
7182 600 50       1967 my $q_string = '';
  8204 50       40220  
    50          
    100          
    100          
    50          
7183 0         0 local $nest = 1;
7184 0         0 while (not /\G \z/oxgc) {
7185 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  114         206  
7186             elsif (/\G (\\\}) /oxgc) { $q_string .= $1; }
7187 114 100       240 elsif (/\G (\\\{) /oxgc) { $q_string .= $1; }
  714         1752  
7188 600         2146 elsif (/\G (\{) /oxgc) { $q_string .= $1; $nest++; }
7189             elsif (/\G (\}) /oxgc) {
7190 114         287 if (--$nest == 0) { return $e . e_q($ope,'{','}',$q_string); }
7191             else { $q_string .= $1; }
7192 7376         16708 }
7193             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7194             }
7195             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7196             }
7197 0         0  
7198 0         0 # elsif (/\G (\[) ((?:\\\]|\\\\|$q_bracket)*?) (\]) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q [ ]
7199 0         0 elsif (/\G (\[) /oxgc) { # q [ ]
7200 0 0       0 my $q_string = '';
  0 0       0  
    0          
    0          
    0          
    0          
7201 0         0 local $nest = 1;
7202 0         0 while (not /\G \z/oxgc) {
7203 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7204             elsif (/\G (\\\]) /oxgc) { $q_string .= $1; }
7205 0 0       0 elsif (/\G (\\\[) /oxgc) { $q_string .= $1; }
  0         0  
7206 0         0 elsif (/\G (\[) /oxgc) { $q_string .= $1; $nest++; }
7207             elsif (/\G (\]) /oxgc) {
7208 0         0 if (--$nest == 0) { return $e . e_q($ope,'[',']',$q_string); }
7209             else { $q_string .= $1; }
7210 0         0 }
7211             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7212             }
7213             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7214             }
7215 0         0  
7216 5         11 # elsif (/\G (\<) ((?:\\\>|\\\\|$q_angle)*?) (\>) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q < >
7217 5         9 elsif (/\G (\<) /oxgc) { # q < >
7218 5 50       19 my $q_string = '';
  82 50       400  
    50          
    50          
    100          
    50          
7219 0         0 local $nest = 1;
7220 0         0 while (not /\G \z/oxgc) {
7221 0         0 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
  0         0  
7222             elsif (/\G (\\\>) /oxgc) { $q_string .= $1; }
7223 0 50       0 elsif (/\G (\\\<) /oxgc) { $q_string .= $1; }
  5         12  
7224 5         17 elsif (/\G (\<) /oxgc) { $q_string .= $1; $nest++; }
7225             elsif (/\G (\>) /oxgc) {
7226 0         0 if (--$nest == 0) { return $e . e_q($ope,'<','>',$q_string); }
7227             else { $q_string .= $1; }
7228 77         152 }
7229             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7230             }
7231             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7232             }
7233 0         0  
7234 1         4 # elsif (/\G (\S) ((?:\\\1|\\\\|$q_char)*?) (\1) /oxgc) { return $e . e_q($ope,$1,$3,$2); } # q * *
7235 1         2 elsif (/\G (\S) /oxgc) { # q * *
7236 1 50       11 my $delimiter = $1;
  14 50       88  
    100          
    50          
7237 0         0 my $q_string = '';
7238 0         0 while (not /\G \z/oxgc) {
7239 1         3 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7240             elsif (/\G (\\\Q$delimiter\E) /oxgc) { $q_string .= $1; }
7241 13         32 elsif (/\G (\Q$delimiter\E) /oxgc) { return $e . e_q($ope,$delimiter,$delimiter,$q_string); }
7242             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7243             }
7244 0         0 die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7245             }
7246             }
7247             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7248             }
7249             }
7250 0         0  
7251 491 50       1444 # m//
7252 491         2947 elsif (/\G \b (m) \b /oxgc) {
7253             my $ope = $1;
7254             if (/\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { # m# #
7255 0         0 return e_qr($ope,$1,$3,$2,$4);
7256 491         803 }
7257 491 50       1525 else {
  491 50       21916  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
7258 0         0 my $e = '';
7259 0         0 while (not /\G \z/oxgc) {
7260 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7261 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ( )
7262 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m { }
7263 92         275 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m [ ]
7264 87         265 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m < >
7265 0         0 elsif (/\G (\?) ((?:$qq_char)*?) (\?) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m ? ?
7266             elsif (/\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr_q($ope,$1, $3, $2,$4); } # m ' '
7267 312         1143 elsif (/\G ([*\-:\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,'{','}',$2,$4); } # m | | --> m { }
7268             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { return $e . e_qr ($ope,$1, $3, $2,$4); } # m * *
7269             }
7270             die __FILE__, ": Search pattern not terminated\n";
7271             }
7272             }
7273              
7274             # s///
7275              
7276             # about [cegimosxpradlunbB]* (/cg modifier)
7277             #
7278             # P.67 Pattern-Matching Operators
7279 0         0 # of ISBN 0-596-00241-6 Perl in a Nutshell, Second Edition.
7280              
7281             elsif (/\G \b (s) \b /oxgc) {
7282 291 100       948 my $ope = $1;
7283 291         4328  
7284             # $1 $2 $3 $4 $5 $6
7285             if (/\G (\#) ((?:$qq_char)*?) (\#) ((?:$qq_char)*?) (\#) ([cegimosxpradlunbB]*) /oxgc) { # s# # #
7286 1         4 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7287 290         515 }
7288 290 50       881 else {
  290 50       29513  
    50          
    50          
    50          
    100          
    100          
    50          
    50          
7289             my $e = '';
7290 0         0 while (not /\G \z/oxgc) {
7291 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7292 0 0       0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7293             my @s = ($1,$2,$3);
7294 0         0 while (not /\G \z/oxgc) {
7295 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7296 0         0 # $1 $2 $3 $4
7297 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7298 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7299 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7300 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7301 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7302 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7303             elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7304 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7305             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7306             }
7307 0         0 die __FILE__, ": Substitution replacement not terminated\n";
7308 0         0 }
7309 0 0       0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7310             my @s = ($1,$2,$3);
7311 0         0 while (not /\G \z/oxgc) {
7312 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7313 0         0 # $1 $2 $3 $4
7314 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7315 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7316 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7317 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7318 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7319 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7320             elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7321 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7322             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7323             }
7324 0         0 die __FILE__, ": Substitution replacement not terminated\n";
7325 0         0 }
7326 0 0       0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
7327             my @s = ($1,$2,$3);
7328 0         0 while (not /\G \z/oxgc) {
7329 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7330 0         0 # $1 $2 $3 $4
7331 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7332 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7333 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7334 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7335             elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7336 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7337             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7338             }
7339 0         0 die __FILE__, ": Substitution replacement not terminated\n";
7340 0         0 }
7341 0 0       0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
7342             my @s = ($1,$2,$3);
7343 0         0 while (not /\G \z/oxgc) {
7344 0         0 if (/\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
7345 0         0 # $1 $2 $3 $4
7346 0         0 elsif (/\G (\() ((?:$qq_paren)*?) (\)) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7347 0         0 elsif (/\G (\{) ((?:$qq_brace)*?) (\}) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7348 0         0 elsif (/\G (\[) ((?:$qq_bracket)*?) (\]) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7349 0         0 elsif (/\G (\<) ((?:$qq_angle)*?) (\>) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7350 0         0 elsif (/\G (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7351 0         0 elsif (/\G (\$) ((?:$qq_char)*?) (\$) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7352             elsif (/\G (\:) ((?:$qq_char)*?) (\:) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7353 0         0 elsif (/\G (\@) ((?:$qq_char)*?) (\@) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7354             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) { return e_sub($sub_variable,@s,$1,$2,$3,$4); }
7355             }
7356             die __FILE__, ": Substitution replacement not terminated\n";
7357 0         0 }
7358             # $1 $2 $3 $4 $5 $6
7359             elsif (/\G (\') ((?:$qq_char)*?) (\') ((?:$qq_char)*?) (\') ([cegimosxpradlunbB]*) /oxgc) {
7360             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7361 96         265 }
7362             # $1 $2 $3 $4 $5 $6
7363             elsif (/\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7364             return e_sub($sub_variable,'{',$2,'}','{',$4,'}',$6); # s | | | --> s { } { }
7365 2         14 }
7366             # $1 $2 $3 $4 $5 $6
7367             elsif (/\G (\$) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7368             return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7369 0         0 }
7370             # $1 $2 $3 $4 $5 $6
7371             elsif (/\G (\S) ((?:$qq_char)*?) (\1) ((?:$qq_char)*?) (\1) ([cegimosxpradlunbB]*) /oxgc) {
7372 192         794 return e_sub($sub_variable,$1,$2,$3,$3,$4,$5,$6);
7373             }
7374             }
7375             die __FILE__, ": Substitution pattern not terminated\n";
7376             }
7377 0         0 }
7378 1         4  
7379 0         0 # do
7380 0         0 elsif (/\G \b do (?= (?>\s*) \{ ) /oxmsgc) { return 'do'; }
7381 0         0 elsif (/\G \b do (?= (?>\s+) (?: q | qq | qx ) \b) /oxmsgc) { return 'Esjis::do'; }
7382             elsif (/\G \b do (?= (?>\s+) (?>\w+)) /oxmsgc) { return 'do'; }
7383             elsif (/\G \b do (?= (?>\s*) \$ (?> \w+ (?: ::\w+)* ) \( ) /oxmsgc) { return 'do'; }
7384 2         11 elsif (/\G \b do \b /oxmsgc) { return 'Esjis::do'; }
7385 0         0  
7386 0         0 # require ignore module
7387             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# require$1$2"; }
7388             elsif (/\G \b require ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFC#]) /oxmsgc) { return "# require$1\n$2"; }
7389 0         0 elsif (/\G \b require ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# require$1"; }
7390 0         0  
7391 0         0 # require version number
7392             elsif (/\G \b require (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7393             elsif (/\G \b require (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7394 0         0 elsif (/\G \b require (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7395              
7396             # require bare package name
7397 18         137 elsif (/\G \b require (?>\s+) ((?>[A-Za-z_]\w* (?: :: [A-Za-z_]\w*)*)) (?>\s*) ; /oxmsgc) { return "require $1;"; }
7398 0         0  
7399             # require else
7400             elsif (/\G \b require (?>\s*) ; /oxmsgc) { return 'Esjis::require;'; }
7401 1         5 elsif (/\G \b require \b /oxmsgc) { return 'Esjis::require'; }
7402 70         636  
7403 0         0 # use strict; --> use strict; no strict qw(refs);
7404             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "use$1 no strict qw(refs);$2"; }
7405             elsif (/\G \b use ((?>\s+) strict .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFC#]) /oxmsgc) { return "use$1 no strict qw(refs);\n$2"; }
7406             elsif (/\G \b use ((?>\s+) strict) \b /oxmsgc) { return "use$1; no strict qw(refs)"; }
7407 0 50 33     0  
      33        
7408 3         52 # use 5.12.0; --> use 5.12.0; no strict qw(refs);
7409             elsif (/\G \b use (?>\s+) ((?>([1-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7410             if (($2 >= 6) or (($2 == 5) and ($3 ge '012'))) {
7411 0         0 return "use $1; no strict qw(refs);";
7412             }
7413             else {
7414             return "use $1;";
7415 3 0 0     18 }
      0        
7416 0         0 }
7417             elsif (/\G \b use (?>\s+) ((?>v([0-9][0-9_]*)(?:\.([0-9_]+))*)) (?>\s*) ; /oxmsgc) {
7418             if (($2 >= 6) or (($2 == 5) and ($3 >= 12))) {
7419 0         0 return "use $1; no strict qw(refs);";
7420             }
7421             else {
7422             return "use $1;";
7423             }
7424 0         0 }
7425 2         21  
7426 0         0 # ignore use module
7427             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# use$1$2"; }
7428             elsif (/\G \b use ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFC#]) /oxmsgc) { return "# use$1\n$2"; }
7429 0         0 elsif (/\G \b use ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# use$1"; }
7430 0         0  
7431 0         0 # ignore no module
7432             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [#\n]) /oxmsgc) { return "# no$1$2"; }
7433             elsif (/\G \b no ((?>\s+) (?:$ignore_modules) .*? ;) ([ \t]* [^\x81-\x9F\xE0-\xFC#]) /oxmsgc) { return "# no$1\n$2"; }
7434 0         0 elsif (/\G \b no ((?>\s+) (?:$ignore_modules)) \b /oxmsgc) { return "# no$1"; }
7435 0         0  
7436 0         0 # use without import
7437 0         0 elsif (/\G \b use (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7438 0         0 elsif (/\G \b use (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7439 0         0 elsif (/\G \b use (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "use $1;"; }
7440 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7441 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7442 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7443 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7444             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7445             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7446 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_use_noimport($1); }
7447              
7448             # use with import no parameter
7449 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_use_noparam($1); }
7450 0         0  
7451 0         0 # use with import parameters
7452 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\x9F\xE0-\xFC)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7453 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\x9F\xE0-\xFC']* \') (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7454 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\x9F\xE0-\xFC"]* \") (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7455 0         0 elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\x9F\xE0-\xFC)]* \)) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7456 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); }
7457 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); }
7458             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\x9F\xE0-\xFC>]* \>) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7459             elsif (/\G \b use (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_use($1,$2); }
7460 0         0 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); }
7461 0         0  
7462 0         0 # no without unimport
7463 0         0 elsif (/\G \b no (?>\s+) ((?>0[0-7_]*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7464 0         0 elsif (/\G \b no (?>\s+) ((?>[1-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7465 0         0 elsif (/\G \b no (?>\s+) ((?>v[0-9][0-9_]*(?:\.[0-9_]+)*)) (?>\s*) ; /oxmsgc) { return "no $1;"; }
7466 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7467 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\() (?>\s*) \) (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7468 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\{) (?>\s*) \} (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7469 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\[) (?>\s*) \] (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7470             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\<) (?>\s*) \> (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7471             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) ([\x21-\x3F]) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7472 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) qw (?>\s*) (\S) (?>\s*) \2 (?>\s*) ; /oxmsgc) { return e_no_nounimport($1); }
7473              
7474             # no with unimport no parameter
7475 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ; /oxmsgc) { return e_no_noparam($1); }
7476 0         0  
7477 0         0 # no with unimport parameters
7478 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\() [^\x81-\x9F\xE0-\xFC)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7479 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\') [^\x81-\x9F\xE0-\xFC']* \') (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7480 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s*) ( (\") [^\x81-\x9F\xE0-\xFC"]* \") (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7481 0         0 elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\() [^\x81-\x9F\xE0-\xFC)]* \)) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7482 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); }
7483 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); }
7484             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) (\<) [^\x81-\x9F\xE0-\xFC>]* \>) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7485             elsif (/\G \b no (?>\s+) ((?>[A-Z]\w*(?: ::\w+)*)) (?>\s+) ((?: q | qq | qw ) (?>\s*) ([\x21-\x3F]) .*? \3) (?>\s*) ; /oxmsgc) { return e_no($1,$2); }
7486 0         0 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); }
7487              
7488             # use else
7489 0         0 elsif (/\G \b use \b /oxmsgc) { return "use"; }
7490              
7491             # use else
7492             elsif (/\G \b no \b /oxmsgc) { return "no"; }
7493 2         13  
7494 3199         7614 # ''
7495 3199 100       8852 elsif (/\G (?
  15823 100       57221  
    100          
    50          
7496 8         20 my $q_string = '';
7497 48         109 while (not /\G \z/oxgc) {
7498 3199         7897 if (/\G (\\\\) /oxgc) { $q_string .= $1; }
7499             elsif (/\G (\\\') /oxgc) { $q_string .= $1; }
7500 12568         28296 elsif (/\G \' /oxgc) { return e_q('', "'","'",$q_string); }
7501             elsif (/\G ($q_char) /oxgc) { $q_string .= $1; }
7502             }
7503             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7504             }
7505 0         0  
7506 3442         8488 # ""
7507 3442 100       9503 elsif (/\G (\") /oxgc) {
  72128 100       213416  
    100          
    50          
7508 109         230 my $qq_string = '';
7509 14         27 while (not /\G \z/oxgc) {
7510 3442         9160 if (/\G (\\\\) /oxgc) { $qq_string .= $1; }
7511             elsif (/\G (\\\") /oxgc) { $qq_string .= $1; }
7512 68563         136535 elsif (/\G \" /oxgc) { return e_qq('', '"','"',$qq_string); }
7513             elsif (/\G ($q_char) /oxgc) { $qq_string .= $1; }
7514             }
7515             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7516             }
7517 0         0  
7518 37         118 # ``
7519 37 50       158 elsif (/\G (\`) /oxgc) {
  313 50       1846  
    100          
    50          
7520 0         0 my $qx_string = '';
7521 0         0 while (not /\G \z/oxgc) {
7522 37         453 if (/\G (\\\\) /oxgc) { $qx_string .= $1; }
7523             elsif (/\G (\\\`) /oxgc) { $qx_string .= $1; }
7524 276         652 elsif (/\G \` /oxgc) { return e_qq('', '`','`',$qx_string); }
7525             elsif (/\G ($q_char) /oxgc) { $qx_string .= $1; }
7526             }
7527             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
7528             }
7529 0         0  
7530 1231         3182 # // --- not divide operator (num / num), not defined-or
7531 1231 100       3507 elsif (($slash eq 'm//') and /\G (\/) /oxgc) {
  12525 50       43601  
    100          
    50          
7532 11         35 my $regexp = '';
7533 0         0 while (not /\G \z/oxgc) {
7534 1231         3420 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7535             elsif (/\G (\\\/) /oxgc) { $regexp .= $1; }
7536 11283         24151 elsif (/\G \/ ([cgimosxpadlunbB]*) /oxgc) { return e_qr('', '/','/',$regexp,$1); }
7537             elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7538             }
7539             die __FILE__, ": Search pattern not terminated\n";
7540             }
7541 0         0  
7542 92         202 # ?? --- not conditional operator (condition ? then : else)
7543 92 50       218 elsif (($slash eq 'm//') and /\G (\?) /oxgc) {
  266 50       986  
    100          
    50          
7544 0         0 my $regexp = '';
7545 0         0 while (not /\G \z/oxgc) {
7546 92         228 if (/\G (\\\\) /oxgc) { $regexp .= $1; }
7547             elsif (/\G (\\\?) /oxgc) { $regexp .= $1; }
7548 174         437 elsif (/\G \? ([cgimosxpadlunbB]*) /oxgc) { return e_qr('m','?','?',$regexp,$1); }
7549             elsif (/\G ($q_char) /oxgc) { $regexp .= $1; }
7550             }
7551             die __FILE__, ": Search pattern not terminated\n";
7552 0         0 }
  0         0  
7553              
7554             # <<>> (a safer ARGV)
7555 0         0 elsif (/\G ( <<>> ) /oxgc) { $slash = 'm//'; return $1; }
  0         0  
7556              
7557             # << (bit shift) --- not here document
7558             elsif (/\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) { $slash = 'm//'; return $1; }
7559 0         0  
7560 6         16 # <<~'HEREDOC'
7561 6         14 elsif (/\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
7562             $slash = 'm//';
7563             my $here_quote = $1;
7564 6 50       11 my $delimiter = $2;
7565 6         15  
7566 6         28 # get here document
7567             if ($here_script eq '') {
7568 6 50       48 $here_script = CORE::substr $_, pos $_;
7569 6         74 $here_script =~ s/.*?\n//oxm;
7570 6         16 }
7571 6         10 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7572 6         54 my $heredoc = $1;
7573 6         21 my $indent = $2;
7574             $heredoc =~ s{^$indent}{}msg; # no /ox
7575             push @heredoc, $heredoc . qq{\n$delimiter\n};
7576 6         14 push @heredoc_delimiter, qq{\\s*$delimiter};
7577             }
7578 0         0 else {
7579             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7580             }
7581             return qq{<<'$delimiter'};
7582             }
7583              
7584             # <<~\HEREDOC
7585              
7586             # P.66 2.6.6. "Here" Documents
7587             # in Chapter 2: Bits and Pieces
7588             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7589              
7590             # P.73 "Here" Documents
7591             # in Chapter 2: Bits and Pieces
7592 6         31 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7593 3         11  
7594 3         9 elsif (/\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
7595             $slash = 'm//';
7596             my $here_quote = $1;
7597 3 50       6 my $delimiter = $2;
7598 3         8  
7599 3         28 # get here document
7600             if ($here_script eq '') {
7601 3 50       22 $here_script = CORE::substr $_, pos $_;
7602 3         43 $here_script =~ s/.*?\n//oxm;
7603 3         9 }
7604 3         5 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7605 3         41 my $heredoc = $1;
7606 3         11 my $indent = $2;
7607             $heredoc =~ s{^$indent}{}msg; # no /ox
7608             push @heredoc, $heredoc . qq{\n$delimiter\n};
7609 3         8 push @heredoc_delimiter, qq{\\s*$delimiter};
7610             }
7611 0         0 else {
7612             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7613             }
7614             return qq{<<\\$delimiter};
7615             }
7616 3         15  
7617 6         18 # <<~"HEREDOC"
7618 6         13 elsif (/\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
7619             $slash = 'm//';
7620             my $here_quote = $1;
7621 6 50       10 my $delimiter = $2;
7622 6         15  
7623 6         25 # get here document
7624             if ($here_script eq '') {
7625 6 50       38 $here_script = CORE::substr $_, pos $_;
7626 6         71 $here_script =~ s/.*?\n//oxm;
7627 6         14 }
7628 6         11 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7629 6         54 my $heredoc = $1;
7630 6         20 my $indent = $2;
7631             $heredoc =~ s{^$indent}{}msg; # no /ox
7632             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7633 6         15 push @heredoc_delimiter, qq{\\s*$delimiter};
7634             }
7635 0         0 else {
7636             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7637             }
7638             return qq{<<"$delimiter"};
7639             }
7640 6         26  
7641 3         9 # <<~HEREDOC
7642 3         7 elsif (/\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
7643             $slash = 'm//';
7644             my $here_quote = $1;
7645 3 50       7 my $delimiter = $2;
7646 3         8  
7647 3         28 # get here document
7648             if ($here_script eq '') {
7649 3 50       21 $here_script = CORE::substr $_, pos $_;
7650 3         44 $here_script =~ s/.*?\n//oxm;
7651 3         7 }
7652 3         7 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7653 3         40 my $heredoc = $1;
7654 3         11 my $indent = $2;
7655             $heredoc =~ s{^$indent}{}msg; # no /ox
7656             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7657 3         10 push @heredoc_delimiter, qq{\\s*$delimiter};
7658             }
7659 0         0 else {
7660             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7661             }
7662             return qq{<<$delimiter};
7663             }
7664 3         14  
7665 6         17 # <<~`HEREDOC`
7666 6         14 elsif (/\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
7667             $slash = 'm//';
7668             my $here_quote = $1;
7669 6 50       11 my $delimiter = $2;
7670 6         14  
7671 6         41 # get here document
7672             if ($here_script eq '') {
7673 6 50       37 $here_script = CORE::substr $_, pos $_;
7674 6         73 $here_script =~ s/.*?\n//oxm;
7675 6         15 }
7676 6         11 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
7677 6         58 my $heredoc = $1;
7678 6         26 my $indent = $2;
7679             $heredoc =~ s{^$indent}{}msg; # no /ox
7680             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
7681 6         16 push @heredoc_delimiter, qq{\\s*$delimiter};
7682             }
7683 0         0 else {
7684             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7685             }
7686             return qq{<<`$delimiter`};
7687             }
7688 6         30  
7689 86         220 # <<'HEREDOC'
7690 86         216 elsif (/\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
7691             $slash = 'm//';
7692             my $here_quote = $1;
7693 86 100       159 my $delimiter = $2;
7694 86         212  
7695 83         477 # get here document
7696             if ($here_script eq '') {
7697 83 50       512 $here_script = CORE::substr $_, pos $_;
7698 86         766 $here_script =~ s/.*?\n//oxm;
7699 86         332 }
7700             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7701             push @heredoc, $1 . qq{\n$delimiter\n};
7702 86         156 push @heredoc_delimiter, $delimiter;
7703             }
7704 0         0 else {
7705             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7706             }
7707             return $here_quote;
7708             }
7709              
7710             # <<\HEREDOC
7711              
7712             # P.66 2.6.6. "Here" Documents
7713             # in Chapter 2: Bits and Pieces
7714             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7715              
7716             # P.73 "Here" Documents
7717             # in Chapter 2: Bits and Pieces
7718 86         367 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7719 2         4  
7720 2         5 elsif (/\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
7721             $slash = 'm//';
7722             my $here_quote = $1;
7723 2 100       5 my $delimiter = $2;
7724 2         5  
7725 1         7 # get here document
7726             if ($here_script eq '') {
7727 1 50       6 $here_script = CORE::substr $_, pos $_;
7728 2         28 $here_script =~ s/.*?\n//oxm;
7729 2         8 }
7730             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7731             push @heredoc, $1 . qq{\n$delimiter\n};
7732 2         4 push @heredoc_delimiter, $delimiter;
7733             }
7734 0         0 else {
7735             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7736             }
7737             return $here_quote;
7738             }
7739 2         30  
7740 39         102 # <<"HEREDOC"
7741 39         95 elsif (/\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
7742             $slash = 'm//';
7743             my $here_quote = $1;
7744 39 100       74 my $delimiter = $2;
7745 39         103  
7746 38         285 # get here document
7747             if ($here_script eq '') {
7748 38 50       237 $here_script = CORE::substr $_, pos $_;
7749 39         480 $here_script =~ s/.*?\n//oxm;
7750 39         182 }
7751             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7752             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7753 39         102 push @heredoc_delimiter, $delimiter;
7754             }
7755 0         0 else {
7756             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7757             }
7758             return $here_quote;
7759             }
7760 39         193  
7761 54         147 # <
7762 54         147 elsif (/\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
7763             $slash = 'm//';
7764             my $here_quote = $1;
7765 54 100       110 my $delimiter = $2;
7766 54         149  
7767 51         366 # get here document
7768             if ($here_script eq '') {
7769 51 50       436 $here_script = CORE::substr $_, pos $_;
7770 54         823 $here_script =~ s/.*?\n//oxm;
7771 54         209 }
7772             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7773             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7774 54         138 push @heredoc_delimiter, $delimiter;
7775             }
7776 0         0 else {
7777             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7778             }
7779             return $here_quote;
7780             }
7781 54         246  
7782 0         0 # <<`HEREDOC`
7783 0         0 elsif (/\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
7784             $slash = 'm//';
7785             my $here_quote = $1;
7786 0 0       0 my $delimiter = $2;
7787 0         0  
7788 0         0 # get here document
7789             if ($here_script eq '') {
7790 0 0       0 $here_script = CORE::substr $_, pos $_;
7791 0         0 $here_script =~ s/.*?\n//oxm;
7792 0         0 }
7793             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
7794             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
7795 0         0 push @heredoc_delimiter, $delimiter;
7796             }
7797 0         0 else {
7798             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
7799             }
7800             return $here_quote;
7801             }
7802 0         0  
7803             # <<= <=> <= < operator
7804             elsif (/\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) {
7805             return $1;
7806             }
7807 13         100  
7808             #
7809             elsif (/\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) {
7810             return $1;
7811             }
7812              
7813             # --- glob
7814              
7815 0         0 # avoid "Error: Runtime exception" of perl version 5.005_03
7816              
7817             elsif (/\G < ((?:[^\x81-\x9F\xE0-\xFC>\0\a\e\f\n\r\t]|[\x81-\x9F\xE0-\xFC][\x00-\xFF])+?) > /oxgc) {
7818             return 'Esjis::glob("' . $1 . '")';
7819 0         0 }
7820              
7821             # __DATA__
7822 0         0 elsif (/\G ^ ( __DATA__ \n .*) \z /oxmsgc) { return $1; }
7823              
7824             # __END__
7825             elsif (/\G ^ ( __END__ \n .*) \z /oxmsgc) { return $1; }
7826              
7827             # \cD Control-D
7828              
7829             # P.68 2.6.8. Other Literal Tokens
7830             # in Chapter 2: Bits and Pieces
7831             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
7832              
7833             # P.76 Other Literal Tokens
7834 385         3305 # in Chapter 2: Bits and Pieces
7835             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7836              
7837 0         0 elsif (/\G ( \cD .*) \z /oxmsgc) { return $1; }
7838              
7839             # \cZ Control-Z
7840             elsif (/\G ( \cZ .*) \z /oxmsgc) { return $1; }
7841              
7842             # any operator before div
7843             elsif (/\G (
7844 0         0 -- | \+\+ |
  14225         33049  
7845             [\)\}\]]
7846              
7847             ) /oxgc) { $slash = 'div'; return $1; }
7848              
7849             # yada-yada or triple-dot operator
7850 14225         73946 elsif (/\G (
  7         18  
7851             \.\.\.
7852              
7853             ) /oxgc) { $slash = 'm//'; return q{die('Unimplemented')}; }
7854              
7855             # any operator before m//
7856              
7857             # //, //= (defined-or)
7858              
7859             # P.164 Logical Operators
7860             # in Chapter 10: More Control Structures
7861             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7862              
7863             # P.119 C-Style Logical (Short-Circuit) Operators
7864             # in Chapter 3: Unary and Binary Operators
7865             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7866              
7867             # (and so on)
7868              
7869             # ~~
7870              
7871             # P.221 The Smart Match Operator
7872             # in Chapter 15: Smart Matching and given-when
7873             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
7874              
7875             # P.112 Smartmatch Operator
7876             # in Chapter 3: Unary and Binary Operators
7877             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
7878              
7879             # (and so on)
7880              
7881             elsif (/\G ((?>
7882              
7883             !~~ | !~ | != | ! |
7884             %= | % |
7885             &&= | && | &= | &\.= | &\. | & |
7886             -= | -> | - |
7887             :(?>\s*)= |
7888             : |
7889             <<>> |
7890             <<= | <=> | <= | < |
7891             == | => | =~ | = |
7892             >>= | >> | >= | > |
7893             \*\*= | \*\* | \*= | \* |
7894             \+= | \+ |
7895             \.\. | \.= | \. |
7896             \/\/= | \/\/ |
7897             \/= | \/ |
7898             \? |
7899             \\ |
7900             \^= | \^\.= | \^\. | \^ |
7901             \b x= |
7902             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
7903             ~~ | ~\. | ~ |
7904             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
7905             \b(?: print )\b |
7906 7         28  
  23932         52974  
7907             [,;\(\{\[]
7908              
7909 23932         120997 )) /oxgc) { $slash = 'm//'; return $1; }
  37289         80984  
7910              
7911             # other any character
7912             elsif (/\G ($q_char) /oxgc) { $slash = 'div'; return $1; }
7913 37289         202864  
7914             # system error
7915             else {
7916             die __FILE__, ": Oops, this shouldn't happen!\n";
7917             }
7918             }
7919 0     3114 0 0  
7920 3114         7671 # escape ShiftJIS string
7921             sub e_string {
7922 3114         4760 my($string) = @_;
7923             my $e_string = '';
7924              
7925             local $slash = 'm//';
7926              
7927             # P.1024 Appendix W.10 Multibyte Processing
7928 3114         4641 # of ISBN 1-56592-224-7 CJKV Information Processing
7929             # (and so on)
7930              
7931 3114 100 66     29577 my @char = $string =~ / \G (?>[^\x81-\x9F\xE0-\xFC\\]|\\$q_char|$q_char) /oxmsg;
7932 3114 50       15515  
7933 3023         7076 # without { ... }
7934             if (not (grep(/\A \{ \z/xms, @char) and grep(/\A \} \z/xms, @char))) {
7935             if ($string !~ /<
7936             return $string;
7937             }
7938 3023         7912 }
7939 91 50       313  
    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          
7940             E_STRING_LOOP:
7941             while ($string !~ /\G \z/oxgc) {
7942             if (0) {
7943 774         120242 }
7944 0         0  
7945 0         0 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> @{[Esjis::PREMATCH()]}
7946             elsif ($string =~ /\G ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH \b | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) /oxmsgc) {
7947             $e_string .= q{Esjis::PREMATCH()};
7948             $slash = 'div';
7949             }
7950 0         0  
7951 0         0 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> @{[Esjis::MATCH()]}
7952             elsif ($string =~ /\G ( \$& | \$\{&\} | \$ (?>\s*) MATCH \b | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) /oxmsgc) {
7953             $e_string .= q{Esjis::MATCH()};
7954             $slash = 'div';
7955             }
7956 0         0  
7957 0         0 # $', ${'} --> $', ${'}
7958             elsif ($string =~ /\G ( \$' | \$\{'\} ) /oxmsgc) {
7959             $e_string .= $1;
7960             $slash = 'div';
7961             }
7962 0         0  
7963 0         0 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> @{[Esjis::POSTMATCH()]}
7964             elsif ($string =~ /\G ( \$ (?>\s*) POSTMATCH \b | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) /oxmsgc) {
7965             $e_string .= q{Esjis::POSTMATCH()};
7966             $slash = 'div';
7967             }
7968 0         0  
7969 0         0 # bareword
7970             elsif ($string =~ /\G ( \{ (?>\s*) (?: tr | index | rindex | reverse ) (?>\s*) \} ) /oxmsgc) {
7971             $e_string .= $1;
7972             $slash = 'div';
7973             }
7974 0         0  
7975 0         0 # $0 --> $0
7976             elsif ($string =~ /\G ( \$ 0 ) /oxmsgc) {
7977             $e_string .= $1;
7978 0         0 $slash = 'div';
7979 0         0 }
7980             elsif ($string =~ /\G ( \$ \{ (?>\s*) 0 (?>\s*) \} ) /oxmsgc) {
7981             $e_string .= $1;
7982             $slash = 'div';
7983             }
7984 0         0  
7985 0         0 # $$ --> $$
7986             elsif ($string =~ /\G ( \$ \$ ) (?![\w\{]) /oxmsgc) {
7987             $e_string .= $1;
7988             $slash = 'div';
7989             }
7990              
7991 0         0 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
7992 0         0 # $1, $2, $3 --> $1, $2, $3 otherwise
7993             elsif ($string =~ /\G \$ ((?>[1-9][0-9]*)) /oxmsgc) {
7994             $e_string .= e_capture($1);
7995 0         0 $slash = 'div';
7996 0         0 }
7997             elsif ($string =~ /\G \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} /oxmsgc) {
7998             $e_string .= e_capture($1);
7999             $slash = 'div';
8000             }
8001 0         0  
8002 0         0 # $$foo[ ... ] --> $ $foo->[ ... ]
8003             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ .+? \] ) /oxmsgc) {
8004             $e_string .= e_capture($1.'->'.$2);
8005             $slash = 'div';
8006             }
8007 0         0  
8008 0         0 # $$foo{ ... } --> $ $foo->{ ... }
8009             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ .+? \} ) /oxmsgc) {
8010             $e_string .= e_capture($1.'->'.$2);
8011             $slash = 'div';
8012             }
8013 0         0  
8014 0         0 # $$foo
8015             elsif ($string =~ /\G \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) /oxmsgc) {
8016             $e_string .= e_capture($1);
8017             $slash = 'div';
8018             }
8019 0         0  
8020 0         0 # ${ foo }
8021             elsif ($string =~ /\G \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} /oxmsgc) {
8022             $e_string .= '${' . $1 . '}';
8023             $slash = 'div';
8024             }
8025 0         0  
8026 3         13 # ${ ... }
8027             elsif ($string =~ /\G \$ (?>\s*) \{ (?>\s*) ( $qq_brace ) (?>\s*) \} /oxmsgc) {
8028             $e_string .= e_capture($1);
8029             $slash = 'div';
8030             }
8031              
8032 3         16 # variable or function
8033 0         0 # $ @ % & * $ #
8034             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) {
8035             $e_string .= $1;
8036             $slash = 'div';
8037             }
8038 0         0 # $ $ $ $ $ $ $ $ $ $ $ $ $ $
8039 0         0 # $ @ # \ ' " / ? ( ) [ ] < >
8040             elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
8041             $e_string .= $1;
8042             $slash = 'div';
8043 0         0 }
  0         0  
8044 0         0  
  0         0  
8045 0         0 # subroutines of package Esjis
  0         0  
8046 0         0 elsif ($string =~ /\G \b (CORE:: | ->(>?\s*) (?: atan2 | [a-z]{2,})) \b /oxgc) { $e_string .= $1; $slash = 'm//'; }
  0         0  
8047 0         0 elsif ($string =~ /\G \b Char::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
8048 0         0 elsif ($string =~ /\G \b Sjis::eval (?= (?>\s*) \{ ) /oxgc) { $e_string .= 'eval'; $slash = 'm//'; }
  0         0  
8049 0         0 elsif ($string =~ /\G \b Char::eval \b /oxgc) { $e_string .= 'eval Char::escape'; $slash = 'm//'; }
  0         0  
8050 0         0 elsif ($string =~ /\G \b Sjis::eval \b /oxgc) { $e_string .= 'eval Sjis::escape'; $slash = 'm//'; }
  0         0  
8051 0         0 elsif ($string =~ /\G \b bytes::substr \b /oxgc) { $e_string .= 'substr'; $slash = 'm//'; }
  0         0  
8052 0         0 elsif ($string =~ /\G \b chop \b /oxgc) { $e_string .= 'Esjis::chop'; $slash = 'm//'; }
  0         0  
8053 0         0 elsif ($string =~ /\G \b bytes::index \b /oxgc) { $e_string .= 'index'; $slash = 'm//'; }
  0         0  
8054 0         0 elsif ($string =~ /\G \b Char::index \b /oxgc) { $e_string .= 'Char::index'; $slash = 'm//'; }
  0         0  
8055 0         0 elsif ($string =~ /\G \b Sjis::index \b /oxgc) { $e_string .= 'Sjis::index'; $slash = 'm//'; }
  0         0  
8056 0         0 elsif ($string =~ /\G \b index \b /oxgc) { $e_string .= 'Esjis::index'; $slash = 'm//'; }
  0         0  
8057 0         0 elsif ($string =~ /\G \b bytes::rindex \b /oxgc) { $e_string .= 'rindex'; $slash = 'm//'; }
  0         0  
8058 0         0 elsif ($string =~ /\G \b Char::rindex \b /oxgc) { $e_string .= 'Char::rindex'; $slash = 'm//'; }
  0         0  
8059 0         0 elsif ($string =~ /\G \b Sjis::rindex \b /oxgc) { $e_string .= 'Sjis::rindex'; $slash = 'm//'; }
  0         0  
8060 0         0 elsif ($string =~ /\G \b rindex \b /oxgc) { $e_string .= 'Esjis::rindex'; $slash = 'm//'; }
  0         0  
8061 0         0 elsif ($string =~ /\G \b lc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::lc'; $slash = 'm//'; }
  0         0  
8062 0         0 elsif ($string =~ /\G \b lcfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::lcfirst'; $slash = 'm//'; }
  0         0  
8063             elsif ($string =~ /\G \b uc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::uc'; $slash = 'm//'; }
8064 0         0 elsif ($string =~ /\G \b ucfirst (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::ucfirst'; $slash = 'm//'; }
  0         0  
8065 0         0 elsif ($string =~ /\G \b fc (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::fc'; $slash = 'm//'; }
  0         0  
8066 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
8067 0         0 (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8068 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8069 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8070 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         10  
8071             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
8072             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
8073 1         5 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         8  
8074 1         4  
  0         0  
8075 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
8076 0         0 (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8077 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8078 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8079 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  1         10  
8080             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
8081             elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
8082 1         5 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Esjis::filetest(qw($1)," . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8083 0         0  
  0         0  
8084 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
8085 0         0 { $e_string .= "Esjis::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
8086             elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+)) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Esjis::filetest(qw($1),$2)"; $slash = 'm//'; }
8087 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) (?= [a-z]+) /oxgc) { $e_string .= "Esjis::filetest qw($1),"; $slash = 'm//'; }
  0         0  
8088 0         0 elsif ($string =~ /\G ((?:-[rwxoRWXOezfdlpSbcugkTB](?>\s+)){2,}) ((?>\w+)) /oxgc) { $e_string .= "Esjis::filetest(qw($1),$2)"; $slash = 'm//'; }
  0         0  
8089 0         0  
  0         0  
8090 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= "Esjis::$1(" . e_qq('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8091 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\#) ((?:$qq_char)+?) (\#) /oxgc) { $e_string .= "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8092 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\() ((?:$qq_paren)+?) (\)) /oxgc) { $e_string .= "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8093 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\{) ((?:$qq_brace)+?) (\}) /oxgc) { $e_string .= "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  2         12  
8094             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
8095 2         9 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  1         17  
8096 1         4 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) qq (?>\s*) (\S) ((?:$qq_char)+?) (\2) /oxgc) { $e_string .= "Esjis::$1(" . e_qq('qq',$2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8097 0         0  
  0         0  
8098 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= "Esjis::$1(" . e_q ('', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8099 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\#) ((?:\\\#|\\\\|$q_char)+?) (\#) /oxgc) { $e_string .= "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8100 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\() ((?:\\\)|\\\\|$q_paren)+?) (\)) /oxgc) { $e_string .= "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8101 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\{) ((?:\\\}|\\\\|$q_brace)+?) (\}) /oxgc) { $e_string .= "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  2         13  
8102             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
8103             elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
8104 2         8 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) q (?>\s*) (\S) ((?:\\\2|\\\\|$q_char)+?) (\2) /oxgc) { $e_string .= "Esjis::$1(" . e_q ('q', $2,$4,$3) . ")"; $slash = 'm//'; }
  0         0  
8105 0         0  
  0         0  
8106 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ) )*) /oxgc)
  0         0  
8107 0         0 { $e_string .= "Esjis::$1($2)"; $slash = 'm//'; }
  0         0  
8108 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "Esjis::$1($2)"; $slash = 'm//'; }
  0         0  
8109 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= "Esjis::$1"; $slash = 'm//'; }
  0         0  
8110 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "Esjis::$1(::"."$2)"; $slash = 'm//'; }
  0         0  
8111             elsif ($string =~ /\G -(t) (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-t $2"; $slash = 'm//'; }
8112             elsif ($string =~ /\G \b lstat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::lstat'; $slash = 'm//'; }
8113 0         0 elsif ($string =~ /\G \b stat (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::stat'; $slash = 'm//'; }
  0         0  
8114 0         0  
  0         0  
8115 0         0 # "-s '' ..." means file test "-s 'filename' ..." (not means "- s/// ...")
  0         0  
8116 0         0 elsif ($string =~ /\G -s (?>\s*) (\") ((?:$qq_char)+?) (\") /oxgc) { $e_string .= '-s ' . e_qq('', $1,$3,$2); $slash = 'm//'; }
  0         0  
8117 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  
8118 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  
8119 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  
8120             elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\[) ((?:$qq_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
8121 0         0 elsif ($string =~ /\G -s (?>\s+) qq (?>\s*) (\<) ((?:$qq_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_qq('qq',$1,$3,$2); $slash = 'm//'; }
  0         0  
8122 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  
8123 0         0  
  0         0  
8124 0         0 elsif ($string =~ /\G -s (?>\s*) (\') ((?:\\\'|\\\\|$q_char)+?) (\') /oxgc) { $e_string .= '-s ' . e_q ('', $1,$3,$2); $slash = 'm//'; }
  0         0  
8125 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  
8126 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  
8127 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  
8128             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\[) ((?:\\\]|\\\\|$q_bracket)+?) (\]) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
8129             elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\<) ((?:\\\>|\\\\|$q_angle)+?) (\>) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
8130 0         0 elsif ($string =~ /\G -s (?>\s+) q (?>\s*) (\S) ((?:\\\1|\\\\|$q_char)+?) (\1) /oxgc) { $e_string .= '-s ' . e_q ('q', $1,$3,$2); $slash = 'm//'; }
  0         0  
8131 0         0  
  0         0  
8132 0         0 elsif ($string =~ /\G -s (?>\s*) (\$ (?> \w+ (?: ::\w+)*) (?: (?: ->)? (?: [\$\@\%\&\*]\* | \$\#\* | \( (?:$qq_paren)*? \) | [\@\%\*]? \{ (?:$qq_brace)+? \} | [\@\%]? \[ (?:$qq_bracket)+? \] ))*) /oxgc)
  0         0  
8133 0         0 { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
8134             elsif ($string =~ /\G -s (?>\s*) \( ((?:$qq_paren)*?) \) /oxgc) { $e_string .= "-s ($1)"; $slash = 'm//'; }
8135 0         0 elsif ($string =~ /\G -s (?= (?>\s+) [a-z]+) /oxgc) { $e_string .= '-s'; $slash = 'm//'; }
  0         0  
8136 0         0 elsif ($string =~ /\G -s (?>\s+) ((?>\w+)) /oxgc) { $e_string .= "-s $1"; $slash = 'm//'; }
  0         0  
8137 0         0  
  0         0  
8138 0         0 elsif ($string =~ /\G \b bytes::length (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
8139 0         0 elsif ($string =~ /\G \b bytes::chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
8140 0         0 elsif ($string =~ /\G \b chr (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::chr'; $slash = 'm//'; }
  0         0  
8141 0         0 elsif ($string =~ /\G \b bytes::ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
8142 0         0 elsif ($string =~ /\G \b ord (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= $function_ord; $slash = 'div'; }
  0         0  
8143 0         0 elsif ($string =~ /\G \b glob (?= (?>\s+)[A-Za-z_]|(?>\s*)['"`\$\@\&\*\(]) /oxgc) { $e_string .= 'Esjis::glob'; $slash = 'm//'; }
  0         0  
8144 0         0 elsif ($string =~ /\G \b lc \b /oxgc) { $e_string .= 'Esjis::lc_'; $slash = 'm//'; }
  0         0  
8145 0         0 elsif ($string =~ /\G \b lcfirst \b /oxgc) { $e_string .= 'Esjis::lcfirst_'; $slash = 'm//'; }
  0         0  
8146 0         0 elsif ($string =~ /\G \b uc \b /oxgc) { $e_string .= 'Esjis::uc_'; $slash = 'm//'; }
  0         0  
8147 0         0 elsif ($string =~ /\G \b ucfirst \b /oxgc) { $e_string .= 'Esjis::ucfirst_'; $slash = 'm//'; }
  0         0  
8148             elsif ($string =~ /\G \b fc \b /oxgc) { $e_string .= 'Esjis::fc_'; $slash = 'm//'; }
8149 0         0 elsif ($string =~ /\G \b lstat \b /oxgc) { $e_string .= 'Esjis::lstat_'; $slash = 'm//'; }
  0         0  
8150 0         0 elsif ($string =~ /\G \b stat \b /oxgc) { $e_string .= 'Esjis::stat_'; $slash = 'm//'; }
  0         0  
8151 0         0 elsif ($string =~ /\G (-[rwxoRWXOezfdlpSbcugkTB] (?>(?:\s+ -[rwxoRWXOezfdlpSbcugkTB])+))
  0         0  
8152             \b /oxgc) { $e_string .= "Esjis::filetest_(qw($1))"; $slash = 'm//'; }
8153 0         0 elsif ($string =~ /\G -([rwxoRWXOezsfdlpSbcugkTBMAC]) \b /oxgc) { $e_string .= "Esjis::${1}_"; $slash = 'm//'; }
  0         0  
8154 0         0 elsif ($string =~ /\G -s \b /oxgc) { $e_string .= '-s '; $slash = 'm//'; }
  0         0  
8155 0         0  
  0         0  
8156 0         0 elsif ($string =~ /\G \b bytes::length \b /oxgc) { $e_string .= 'length'; $slash = 'm//'; }
  0         0  
8157 0         0 elsif ($string =~ /\G \b bytes::chr \b /oxgc) { $e_string .= 'chr'; $slash = 'm//'; }
  0         0  
8158 0         0 elsif ($string =~ /\G \b chr \b /oxgc) { $e_string .= 'Esjis::chr_'; $slash = 'm//'; }
  0         0  
8159 0         0 elsif ($string =~ /\G \b bytes::ord \b /oxgc) { $e_string .= 'ord'; $slash = 'div'; }
  0         0  
8160 0         0 elsif ($string =~ /\G \b ord \b /oxgc) { $e_string .= $function_ord_; $slash = 'div'; }
  0         0  
8161 0         0 elsif ($string =~ /\G \b glob \b /oxgc) { $e_string .= 'Esjis::glob_'; $slash = 'm//'; }
  0         0  
8162 0         0 elsif ($string =~ /\G \b reverse \b /oxgc) { $e_string .= $function_reverse; $slash = 'm//'; }
  0         0  
8163 0         0 elsif ($string =~ /\G \b getc \b /oxgc) { $e_string .= $function_getc; $slash = 'm//'; }
  0         0  
8164             elsif ($string =~ /\G \b opendir ((?>\s*) \( (?>\s*)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Esjis::opendir$1*"; $slash = 'm//'; }
8165             elsif ($string =~ /\G \b opendir ((?>\s+)) (?=[A-Za-z_]) /oxgc) { $e_string .= "Esjis::opendir$1*"; $slash = 'm//'; }
8166             elsif ($string =~ /\G \b unlink \b /oxgc) { $e_string .= 'Esjis::unlink'; $slash = 'm//'; }
8167 0         0  
8168             # chdir
8169 0         0 elsif ($string =~ /\G \b (chdir) \b (?! (?>\s*) => ) /oxgc) {
8170             $slash = 'm//';
8171 0         0  
8172 0         0 $e_string .= 'Esjis::chdir';
8173              
8174             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
8175             $e_string .= $1;
8176 0 0       0 }
  0 0       0  
    0          
    0          
    0          
    0          
8177              
8178             # end of chdir
8179 0         0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return $e_string; }
  0         0  
8180              
8181             # chdir scalar value
8182             elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= e_string($1); next E_STRING_LOOP; }
8183 0 0       0  
  0         0  
  0         0  
8184             # chdir qq//
8185 0         0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8186 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8187 0         0 else {
  0         0  
8188 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8189 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
8190 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq ( ) --> qr ( )
  0         0  
8191 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq { } --> qr { }
  0         0  
8192 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq [ ] --> qr [ ]
  0         0  
8193             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq < > --> qr < >
8194 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq','{','}',$2); next E_STRING_LOOP; } # qq | | --> qr { }
8195             elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_chdir('qq',$1,$3,$2); next E_STRING_LOOP; } # qq * * --> qr * *
8196             }
8197             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8198             }
8199             }
8200 0 0       0  
  0         0  
  0         0  
8201             # chdir q//
8202 0         0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8203 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8204 0         0 else {
  0         0  
8205 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8206 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $1; }
  0         0  
8207 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  
8208 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  
8209 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  
8210             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q < > --> qr < >
8211 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q','{','}',$2); next E_STRING_LOOP; } # q | | --> qr { }
8212             elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= e_chdir_q('q',$1,$3,$2); next E_STRING_LOOP; } # q * * --> qr * *
8213             }
8214             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8215             }
8216             }
8217 0         0  
8218 0         0 # chdir ''
8219 0 0       0 elsif ($string =~ /\G (\') /oxgc) {
  0 0       0  
    0          
    0          
8220 0         0 my $q_string = '';
8221 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8222 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
8223             elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; }
8224 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_chdir_q('',"'","'",$q_string); next E_STRING_LOOP; }
8225             elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
8226             }
8227             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8228             }
8229 0         0  
8230 0         0 # chdir ""
8231 0 0       0 elsif ($string =~ /\G (\") /oxgc) {
  0 0       0  
    0          
    0          
8232 0         0 my $qq_string = '';
8233 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8234 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
8235             elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; }
8236 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_chdir('','"','"',$qq_string); next E_STRING_LOOP; }
8237             elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8238             }
8239             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8240             }
8241             }
8242 0         0  
8243             # split
8244 0         0 elsif ($string =~ /\G \b (split) \b (?! (?>\s*) => ) /oxgc) {
8245 0         0 $slash = 'm//';
8246 0         0  
8247             my $e = '';
8248             while ($string =~ /\G ( (?>\s+) | \( | \#.* ) /oxgc) {
8249             $e .= $1;
8250 0 0       0 }
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
8251              
8252             # end of split
8253 0         0 if ($string =~ /\G (?= [,;\)\}\]] ) /oxgc) { return 'Esjis::split' . $e; }
  0         0  
8254              
8255             # split scalar value
8256 0         0 elsif ($string =~ /\G ( [\$\@\&\*] $qq_scalar ) /oxgc) { $e_string .= 'Esjis::split' . $e . e_string($1); next E_STRING_LOOP; }
  0         0  
8257 0         0  
  0         0  
8258 0         0 # split literal space
  0         0  
8259 0         0 elsif ($string =~ /\G \b qq (\#) [ ] (\#) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {qq$1 $2}; next E_STRING_LOOP; }
  0         0  
8260 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Esjis::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
8261 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Esjis::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
8262 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Esjis::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
8263 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Esjis::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
8264 0         0 elsif ($string =~ /\G \b qq ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Esjis::split' . $e . qq{$1qq$2 $3}; next E_STRING_LOOP; }
  0         0  
8265 0         0 elsif ($string =~ /\G \b q (\#) [ ] (\#) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {q$1 $2}; next E_STRING_LOOP; }
  0         0  
8266 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\() [ ] (\)) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
8267 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\{) [ ] (\}) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
8268 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\[) [ ] (\]) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
8269 0         0 elsif ($string =~ /\G \b q ((?>\s*)) (\<) [ ] (\>) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
  0         0  
8270             elsif ($string =~ /\G \b q ((?>\s*)) (\S) [ ] (\2) /oxgc) { $e_string .= 'Esjis::split' . $e . qq {$1q$2 $3}; next E_STRING_LOOP; }
8271             elsif ($string =~ /\G ' [ ] ' /oxgc) { $e_string .= 'Esjis::split' . $e . qq {' '}; next E_STRING_LOOP; }
8272             elsif ($string =~ /\G " [ ] " /oxgc) { $e_string .= 'Esjis::split' . $e . qq {" "}; next E_STRING_LOOP; }
8273 0 0       0  
  0         0  
  0         0  
8274             # split qq//
8275 0         0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8276 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8277 0         0 else {
  0         0  
8278 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8279 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
8280 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  
8281 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  
8282 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  
8283             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq < > --> qr < >
8284 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # qq | | --> qr { }
8285             elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= e_split($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # qq * * --> qr * *
8286             }
8287             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8288             }
8289             }
8290 0 0       0  
  0         0  
  0         0  
8291             # split qr//
8292 0         0 elsif ($string =~ /\G \b (qr) \b /oxgc) {
8293 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # qr# #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
8294 0         0 else {
  0         0  
8295 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8296 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
8297 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  
8298 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  
8299 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  
8300 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  
8301             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr ' '
8302 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # qr | | --> qr { }
8303             elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) ([imosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # qr * *
8304             }
8305             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8306             }
8307             }
8308 0 0       0  
  0         0  
  0         0  
8309             # split q//
8310 0         0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8311 0 0       0 if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8312 0         0 else {
  0         0  
8313 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8314 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
8315 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  
8316 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  
8317 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  
8318             elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= e_split_q($e.'qr',$1,$3,$2,''); next E_STRING_LOOP; } # q < > --> qr < >
8319 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$q_char)*?) (\1) /oxgc) { $e_string .= e_split_q($e.'qr','{','}',$2,''); next E_STRING_LOOP; } # q | | --> qr { }
8320             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 * *
8321             }
8322             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8323             }
8324             }
8325 0 0       0  
  0         0  
  0         0  
8326             # split m//
8327 0         0 elsif ($string =~ /\G \b (m) \b /oxgc) {
8328 0 0       0 if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr',$1,$3,$2,$4); next E_STRING_LOOP; } # m# # --> qr # #
  0 0       0  
    0          
    0          
    0          
    0          
    0          
    0          
8329 0         0 else {
  0         0  
8330 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8331 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e_string .= $e . $1; }
  0         0  
8332 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  
8333 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  
8334 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  
8335 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  
8336             elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split_q($e.'qr',$1, $3, $2,$4); next E_STRING_LOOP; } # m ' ' --> qr ' '
8337 0         0 elsif ($string =~ /\G ([*\-:?\\^|]) ((?:$qq_char)*?) (\1) ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split ($e.'qr','{','}',$2,$4); next E_STRING_LOOP; } # m | | --> qr { }
8338             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 * *
8339             }
8340             die __FILE__, ": Search pattern not terminated\n";
8341             }
8342             }
8343 0         0  
8344 0         0 # split ''
8345 0 0       0 elsif ($string =~ /\G (\') /oxgc) {
  0 0       0  
    0          
    0          
8346 0         0 my $q_string = '';
8347 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8348 0         0 if ($string =~ /\G (\\\\) /oxgc) { $q_string .= $1; }
8349             elsif ($string =~ /\G (\\\') /oxgc) { $q_string .= $1; } # splitqr'' --> split qr''
8350 0         0 elsif ($string =~ /\G \' /oxgc) { $e_string .= e_split_q($e.q{ qr},"'","'",$q_string,''); next E_STRING_LOOP; } # ' ' --> qr ' '
8351             elsif ($string =~ /\G ($q_char) /oxgc) { $q_string .= $1; }
8352             }
8353             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8354             }
8355 0         0  
8356 0         0 # split ""
8357 0 0       0 elsif ($string =~ /\G (\") /oxgc) {
  0 0       0  
    0          
    0          
8358 0         0 my $qq_string = '';
8359 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8360 0         0 if ($string =~ /\G (\\\\) /oxgc) { $qq_string .= $1; }
8361             elsif ($string =~ /\G (\\\") /oxgc) { $qq_string .= $1; } # splitqr"" --> split qr""
8362 0         0 elsif ($string =~ /\G \" /oxgc) { $e_string .= e_split($e.q{ qr},'"','"',$qq_string,''); next E_STRING_LOOP; } # " " --> qr " "
8363             elsif ($string =~ /\G ($q_char) /oxgc) { $qq_string .= $1; }
8364             }
8365             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8366             }
8367 0         0  
8368 0         0 # split //
8369 0 0       0 elsif ($string =~ /\G (\/) /oxgc) {
  0 0       0  
    0          
    0          
8370 0         0 my $regexp = '';
8371 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8372 0         0 if ($string =~ /\G (\\\\) /oxgc) { $regexp .= $1; }
8373             elsif ($string =~ /\G (\\\/) /oxgc) { $regexp .= $1; } # splitqr// --> split qr//
8374 0         0 elsif ($string =~ /\G \/ ([cgimosxpadlunbB]*) /oxgc) { $e_string .= e_split($e.q{ qr}, '/','/',$regexp,$1); next E_STRING_LOOP; } # / / --> qr / /
8375             elsif ($string =~ /\G ($q_char) /oxgc) { $regexp .= $1; }
8376             }
8377             die __FILE__, ": Search pattern not terminated\n";
8378             }
8379             }
8380 0         0  
8381 0 0       0 # qq//
8382 0         0 elsif ($string =~ /\G \b (qq) \b /oxgc) {
8383             my $ope = $1;
8384             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qq# #
8385 0         0 $e_string .= e_qq($ope,$1,$3,$2);
8386 0         0 }
8387 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
8388 0         0 my $e = '';
  0         0  
8389 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8390 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8391 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq ( )
  0         0  
8392 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq { }
  0         0  
8393             elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq [ ]
8394 0         0 elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq < >
8395             elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qq * *
8396             }
8397             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8398             }
8399             }
8400 0         0  
8401 0 0       0 # qx//
8402 0         0 elsif ($string =~ /\G \b (qx) \b /oxgc) {
8403             my $ope = $1;
8404             if ($string =~ /\G (\#) ((?:$qq_char)*?) (\#) /oxgc) { # qx# #
8405 0         0 $e_string .= e_qq($ope,$1,$3,$2);
8406 0         0 }
8407 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
    0          
8408 0         0 my $e = '';
  0         0  
8409 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8410 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8411 0         0 elsif ($string =~ /\G (\() ((?:$qq_paren)*?) (\)) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ( )
  0         0  
8412 0         0 elsif ($string =~ /\G (\{) ((?:$qq_brace)*?) (\}) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx { }
  0         0  
8413 0         0 elsif ($string =~ /\G (\[) ((?:$qq_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx [ ]
  0         0  
8414             elsif ($string =~ /\G (\<) ((?:$qq_angle)*?) (\>) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx < >
8415 0         0 elsif ($string =~ /\G (\') ((?:$qq_char)*?) (\') /oxgc) { $e_string .= $e . e_q ($ope,$1,$3,$2); next E_STRING_LOOP; } # qx ' '
8416             elsif ($string =~ /\G (\S) ((?:$qq_char)*?) (\1) /oxgc) { $e_string .= $e . e_qq($ope,$1,$3,$2); next E_STRING_LOOP; } # qx * *
8417             }
8418             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8419             }
8420             }
8421 0         0  
8422 0 0       0 # q//
8423 0         0 elsif ($string =~ /\G \b (q) \b /oxgc) {
8424             my $ope = $1;
8425             if ($string =~ /\G (\#) ((?:\\\#|\\\\|$q_char)*?) (\#) /oxgc) { # q# #
8426 0         0 $e_string .= e_q($ope,$1,$3,$2);
8427 0         0 }
8428 0 0       0 else {
  0 0       0  
    0          
    0          
    0          
    0          
8429 0         0 my $e = '';
  0         0  
8430 0         0 while ($string !~ /\G \z/oxgc) {
  0         0  
8431 0         0 if ($string =~ /\G ((?>\s+)|\#.*) /oxgc) { $e .= $1; }
  0         0  
8432 0         0 elsif ($string =~ /\G (\() ((?:\\\\|\\\)|\\\(|$q_paren)*?) (\)) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q ( )
  0         0  
8433 0         0 elsif ($string =~ /\G (\{) ((?:\\\\|\\\}|\\\{|$q_brace)*?) (\}) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q { }
  0         0  
8434             elsif ($string =~ /\G (\[) ((?:\\\\|\\\]|\\\[|$q_bracket)*?) (\]) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q [ ]
8435 0         0 elsif ($string =~ /\G (\<) ((?:\\\\|\\\>|\\\<|$q_angle)*?) (\>) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q < >
8436             elsif ($string =~ /\G (\S) ((?:\\\\|\\\1| $q_char)*?) (\1) /oxgc) { $e_string .= $e . e_q($ope,$1,$3,$2); next E_STRING_LOOP; } # q * *
8437             }
8438             die __FILE__, ": Can't find string terminator anywhere before EOF\n";
8439             }
8440 0         0 }
8441              
8442             # ''
8443 44         204 elsif ($string =~ /\G (?
8444              
8445             # ""
8446 6         26 elsif ($string =~ /\G (\") ((?:$qq_char)*?) (\") /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8447              
8448             # ``
8449 0         0 elsif ($string =~ /\G (\`) ((?:$qq_char)*?) (\`) /oxgc) { $e_string .= e_qq('',$1,$3,$2); }
8450              
8451             # <<>> (a safer ARGV)
8452 0         0 elsif ($string =~ /\G ( <<>> ) /oxgc) { $e_string .= $1; }
8453              
8454             # <<= <=> <= < operator
8455 0         0 elsif ($string =~ /\G ( <<= | <=> | <= | < ) (?= (?>\s*) [A-Za-z_0-9'"`\$\@\&\*\(\+\-] )/oxgc) { $e_string .= $1; }
8456              
8457             #
8458             elsif ($string =~ /\G (<[\$]?[A-Za-z_][A-Za-z_0-9]*>) /oxgc) { $e_string .= $1; }
8459 0         0  
8460             # --- glob
8461             elsif ($string =~ /\G < ((?:$q_char)+?) > /oxgc) {
8462             $e_string .= 'Esjis::glob("' . $1 . '")';
8463             }
8464 0         0  
8465 0         0 # << (bit shift) --- not here document
8466             elsif ($string =~ /\G ( << (?>\s*) ) (?= [0-9\$\@\&] ) /oxgc) {
8467             $slash = 'm//';
8468             $e_string .= $1;
8469             }
8470 0         0  
8471 0         0 # <<~'HEREDOC'
8472 0         0 elsif ($string =~ /\G ( <<~ [\t ]* '([a-zA-Z_0-9]*)' ) /oxgc) {
8473             $slash = 'm//';
8474             my $here_quote = $1;
8475 0 0       0 my $delimiter = $2;
8476 0         0  
8477 0         0 # get here document
8478             if ($here_script eq '') {
8479 0 0       0 $here_script = CORE::substr $_, pos $_;
8480 0         0 $here_script =~ s/.*?\n//oxm;
8481 0         0 }
8482 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8483 0         0 my $heredoc = $1;
8484 0         0 my $indent = $2;
8485             $heredoc =~ s{^$indent}{}msg; # no /ox
8486             push @heredoc, $heredoc . qq{\n$delimiter\n};
8487 0         0 push @heredoc_delimiter, qq{\\s*$delimiter};
8488             }
8489 0         0 else {
8490             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8491             }
8492             $e_string .= qq{<<'$delimiter'};
8493             }
8494 0         0  
8495 0         0 # <<~\HEREDOC
8496 0         0 elsif ($string =~ /\G ( <<~ \\([a-zA-Z_0-9]+) ) /oxgc) {
8497             $slash = 'm//';
8498             my $here_quote = $1;
8499 0 0       0 my $delimiter = $2;
8500 0         0  
8501 0         0 # get here document
8502             if ($here_script eq '') {
8503 0 0       0 $here_script = CORE::substr $_, pos $_;
8504 0         0 $here_script =~ s/.*?\n//oxm;
8505 0         0 }
8506 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8507 0         0 my $heredoc = $1;
8508 0         0 my $indent = $2;
8509             $heredoc =~ s{^$indent}{}msg; # no /ox
8510             push @heredoc, $heredoc . qq{\n$delimiter\n};
8511 0         0 push @heredoc_delimiter, qq{\\s*$delimiter};
8512             }
8513 0         0 else {
8514             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8515             }
8516             $e_string .= qq{<<\\$delimiter};
8517             }
8518 0         0  
8519 0         0 # <<~"HEREDOC"
8520 0         0 elsif ($string =~ /\G ( <<~ [\t ]* "([a-zA-Z_0-9]*)" ) /oxgc) {
8521             $slash = 'm//';
8522             my $here_quote = $1;
8523 0 0       0 my $delimiter = $2;
8524 0         0  
8525 0         0 # get here document
8526             if ($here_script eq '') {
8527 0 0       0 $here_script = CORE::substr $_, pos $_;
8528 0         0 $here_script =~ s/.*?\n//oxm;
8529 0         0 }
8530 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8531 0         0 my $heredoc = $1;
8532 0         0 my $indent = $2;
8533             $heredoc =~ s{^$indent}{}msg; # no /ox
8534             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8535 0         0 push @heredoc_delimiter, qq{\\s*$delimiter};
8536             }
8537 0         0 else {
8538             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8539             }
8540             $e_string .= qq{<<"$delimiter"};
8541             }
8542 0         0  
8543 0         0 # <<~HEREDOC
8544 0         0 elsif ($string =~ /\G ( <<~ ([a-zA-Z_0-9]+) ) /oxgc) {
8545             $slash = 'm//';
8546             my $here_quote = $1;
8547 0 0       0 my $delimiter = $2;
8548 0         0  
8549 0         0 # get here document
8550             if ($here_script eq '') {
8551 0 0       0 $here_script = CORE::substr $_, pos $_;
8552 0         0 $here_script =~ s/.*?\n//oxm;
8553 0         0 }
8554 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8555 0         0 my $heredoc = $1;
8556 0         0 my $indent = $2;
8557             $heredoc =~ s{^$indent}{}msg; # no /ox
8558             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8559 0         0 push @heredoc_delimiter, qq{\\s*$delimiter};
8560             }
8561 0         0 else {
8562             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8563             }
8564             $e_string .= qq{<<$delimiter};
8565             }
8566 0         0  
8567 0         0 # <<~`HEREDOC`
8568 0         0 elsif ($string =~ /\G ( <<~ [\t ]* `([a-zA-Z_0-9]*)` ) /oxgc) {
8569             $slash = 'm//';
8570             my $here_quote = $1;
8571 0 0       0 my $delimiter = $2;
8572 0         0  
8573 0         0 # get here document
8574             if ($here_script eq '') {
8575 0 0       0 $here_script = CORE::substr $_, pos $_;
8576 0         0 $here_script =~ s/.*?\n//oxm;
8577 0         0 }
8578 0         0 if ($here_script =~ s/\A (.*?) \n ([\t ]*) $delimiter \n //xms) {
8579 0         0 my $heredoc = $1;
8580 0         0 my $indent = $2;
8581             $heredoc =~ s{^$indent}{}msg; # no /ox
8582             push @heredoc, e_heredoc($heredoc) . qq{\n$delimiter\n};
8583 0         0 push @heredoc_delimiter, qq{\\s*$delimiter};
8584             }
8585 0         0 else {
8586             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8587             }
8588             $e_string .= qq{<<`$delimiter`};
8589             }
8590 0         0  
8591 0         0 # <<'HEREDOC'
8592 0         0 elsif ($string =~ /\G ( << '([a-zA-Z_0-9]*)' ) /oxgc) {
8593             $slash = 'm//';
8594             my $here_quote = $1;
8595 0 0       0 my $delimiter = $2;
8596 0         0  
8597 0         0 # get here document
8598             if ($here_script eq '') {
8599 0 0       0 $here_script = CORE::substr $_, pos $_;
8600 0         0 $here_script =~ s/.*?\n//oxm;
8601 0         0 }
8602             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8603             push @heredoc, $1 . qq{\n$delimiter\n};
8604 0         0 push @heredoc_delimiter, $delimiter;
8605             }
8606 0         0 else {
8607             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8608             }
8609             $e_string .= $here_quote;
8610             }
8611 0         0  
8612 0         0 # <<\HEREDOC
8613 0         0 elsif ($string =~ /\G ( << \\([a-zA-Z_0-9]+) ) /oxgc) {
8614             $slash = 'm//';
8615             my $here_quote = $1;
8616 0 0       0 my $delimiter = $2;
8617 0         0  
8618 0         0 # get here document
8619             if ($here_script eq '') {
8620 0 0       0 $here_script = CORE::substr $_, pos $_;
8621 0         0 $here_script =~ s/.*?\n//oxm;
8622 0         0 }
8623             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8624             push @heredoc, $1 . qq{\n$delimiter\n};
8625 0         0 push @heredoc_delimiter, $delimiter;
8626             }
8627 0         0 else {
8628             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8629             }
8630             $e_string .= $here_quote;
8631             }
8632 0         0  
8633 0         0 # <<"HEREDOC"
8634 0         0 elsif ($string =~ /\G ( << "([a-zA-Z_0-9]*)" ) /oxgc) {
8635             $slash = 'm//';
8636             my $here_quote = $1;
8637 0 0       0 my $delimiter = $2;
8638 0         0  
8639 0         0 # get here document
8640             if ($here_script eq '') {
8641 0 0       0 $here_script = CORE::substr $_, pos $_;
8642 0         0 $here_script =~ s/.*?\n//oxm;
8643 0         0 }
8644             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8645             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8646 0         0 push @heredoc_delimiter, $delimiter;
8647             }
8648 0         0 else {
8649             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8650             }
8651             $e_string .= $here_quote;
8652             }
8653 0         0  
8654 0         0 # <
8655 0         0 elsif ($string =~ /\G ( << ([a-zA-Z_0-9]+) ) /oxgc) {
8656             $slash = 'm//';
8657             my $here_quote = $1;
8658 0 0       0 my $delimiter = $2;
8659 0         0  
8660 0         0 # get here document
8661             if ($here_script eq '') {
8662 0 0       0 $here_script = CORE::substr $_, pos $_;
8663 0         0 $here_script =~ s/.*?\n//oxm;
8664 0         0 }
8665             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8666             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8667 0         0 push @heredoc_delimiter, $delimiter;
8668             }
8669 0         0 else {
8670             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8671             }
8672             $e_string .= $here_quote;
8673             }
8674 0         0  
8675 0         0 # <<`HEREDOC`
8676 0         0 elsif ($string =~ /\G ( << `([a-zA-Z_0-9]*)` ) /oxgc) {
8677             $slash = 'm//';
8678             my $here_quote = $1;
8679 0 0       0 my $delimiter = $2;
8680 0         0  
8681 0         0 # get here document
8682             if ($here_script eq '') {
8683 0 0       0 $here_script = CORE::substr $_, pos $_;
8684 0         0 $here_script =~ s/.*?\n//oxm;
8685 0         0 }
8686             if ($here_script =~ s/\A (.*?) \n $delimiter \n //xms) {
8687             push @heredoc, e_heredoc($1) . qq{\n$delimiter\n};
8688 0         0 push @heredoc_delimiter, $delimiter;
8689             }
8690 0         0 else {
8691             die __FILE__, ": Can't find string terminator $delimiter anywhere before EOF\n";
8692             }
8693             $e_string .= $here_quote;
8694             }
8695              
8696             # any operator before div
8697             elsif ($string =~ /\G (
8698 0         0 -- | \+\+ |
  92         189  
8699             [\)\}\]]
8700              
8701             ) /oxgc) { $slash = 'div'; $e_string .= $1; }
8702              
8703             # yada-yada or triple-dot operator
8704 92         367 elsif ($string =~ /\G (
  0         0  
8705             \.\.\.
8706              
8707             ) /oxgc) { $slash = 'm//'; $e_string .= q{die('Unimplemented')}; }
8708              
8709             # any operator before m//
8710             elsif ($string =~ /\G ((?>
8711              
8712             !~~ | !~ | != | ! |
8713             %= | % |
8714             &&= | && | &= | &\.= | &\. | & |
8715             -= | -> | - |
8716             :(?>\s*)= |
8717             : |
8718             <<>> |
8719             <<= | <=> | <= | < |
8720             == | => | =~ | = |
8721             >>= | >> | >= | > |
8722             \*\*= | \*\* | \*= | \* |
8723             \+= | \+ |
8724             \.\. | \.= | \. |
8725             \/\/= | \/\/ |
8726             \/= | \/ |
8727             \? |
8728             \\ |
8729             \^= | \^\.= | \^\. | \^ |
8730             \b x= |
8731             \|\|= | \|\| | \|= | \|\.= | \|\. | \| |
8732             ~~ | ~\. | ~ |
8733             \b(?: and | cmp | eq | ge | gt | le | lt | ne | not | or | xor | x )\b |
8734             \b(?: print )\b |
8735 0         0  
  124         422  
8736             [,;\(\{\[]
8737              
8738 124         851 )) /oxgc) { $slash = 'm//'; $e_string .= $1; }
8739              
8740             # other any character
8741             elsif ($string =~ /\G ($q_char) /oxgc) { $e_string .= $1; }
8742 497         2389  
8743             # system error
8744             else {
8745             die __FILE__, ": Oops, this shouldn't happen!\n";
8746 0         0 }
8747             }
8748              
8749             return $e_string;
8750             }
8751              
8752             #
8753 91     5358 0 438 # character class
8754             #
8755 5358 100       10778 sub character_class {
8756 5358 100       8423 my($char,$modifier) = @_;
8757 115         271  
8758             if ($char eq '.') {
8759             if ($modifier =~ /s/) {
8760 23         70 return '${Esjis::dot_s}';
8761             }
8762             else {
8763             return '${Esjis::dot}';
8764 92         219 }
8765             }
8766             else {
8767             return Esjis::classic_character_class($char);
8768             }
8769             }
8770              
8771             #
8772             # escape capture ($1, $2, $3, ...)
8773 5243     637 0 9520 #
8774 637         2947 sub e_capture {
8775              
8776             return join '', '${Esjis::capture(', $_[0], ')}';
8777             return join '', '${', $_[0], '}';
8778             }
8779              
8780             #
8781 0     11 0 0 # escape transliteration (tr/// or y///)
8782 11         55 #
8783 11   100     23 sub e_tr {
8784             my($variable,$charclass,$e,$charclass2,$modifier) = @_;
8785 11         32 my $e_tr = '';
8786             $modifier ||= '';
8787              
8788 11         17 $slash = 'div';
8789              
8790             # quote character class 1
8791 11         25 $charclass = q_tr($charclass);
8792              
8793             # quote character class 2
8794 11 50       31 $charclass2 = q_tr($charclass2);
8795 11 0       32  
8796 0         0 # /b /B modifier
8797             if ($modifier =~ tr/bB//d) {
8798             if ($variable eq '') {
8799 0         0 $e_tr = qq{tr$charclass$e$charclass2$modifier};
8800             }
8801             else {
8802             $e_tr = qq{$variable${bind_operator}tr$charclass$e$charclass2$modifier};
8803 0 100       0 }
8804 11         23 }
8805             else {
8806             if ($variable eq '') {
8807 2         9 $e_tr = qq{Esjis::tr(\$_,' =~ ',$charclass,$e$charclass2,'$modifier')};
8808             }
8809             else {
8810             $e_tr = qq{Esjis::tr($variable,'$bind_operator',$charclass,$e$charclass2,'$modifier')};
8811             }
8812 9         28 }
8813 11         17  
8814             # clear tr/// variable
8815 11         14 $tr_variable = '';
8816             $bind_operator = '';
8817              
8818             return $e_tr;
8819             }
8820              
8821             #
8822 11     22 0 70 # quote for escape transliteration (tr/// or y///)
8823             #
8824             sub q_tr {
8825 22 50       38 my($charclass) = @_;
    0          
    0          
    0          
    0          
    0          
8826 22         46  
8827             # quote character class
8828             if ($charclass !~ /'/oxms) {
8829 22         35 return e_q('', "'", "'", $charclass); # --> q' '
8830             }
8831             elsif ($charclass !~ /\//oxms) {
8832 0         0 return e_q('q', '/', '/', $charclass); # --> q/ /
8833             }
8834             elsif ($charclass !~ /\#/oxms) {
8835 0         0 return e_q('q', '#', '#', $charclass); # --> q# #
8836             }
8837             elsif ($charclass !~ /[\<\>]/oxms) {
8838 0         0 return e_q('q', '<', '>', $charclass); # --> q< >
8839             }
8840             elsif ($charclass !~ /[\(\)]/oxms) {
8841 0         0 return e_q('q', '(', ')', $charclass); # --> q( )
8842             }
8843             elsif ($charclass !~ /[\{\}]/oxms) {
8844 0         0 return e_q('q', '{', '}', $charclass); # --> q{ }
8845 0 0       0 }
8846 0         0 else {
8847             for my $char (qw( ! " $ % & * + . : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
8848             if ($charclass !~ /\Q$char\E/xms) {
8849             return e_q('q', $char, $char, $charclass);
8850             }
8851 0         0 }
8852             }
8853              
8854             return e_q('q', '{', '}', $charclass);
8855             }
8856              
8857             #
8858 0     3990 0 0 # escape q string (q//, '')
8859             #
8860 3990         10695 sub e_q {
8861             my($ope,$delimiter,$end_delimiter,$string) = @_;
8862 3990         5971  
8863 3990         26783 $slash = 'div';
8864              
8865             my @char = $string =~ / \G (?>$q_char) /oxmsg;
8866 3990 100 100     11324 for (my $i=0; $i <= $#char; $i++) {
    100 100        
8867 21330         133669  
8868             # escape last octet of multiple-octet
8869             if ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
8870 1         5 $char[$i] = $1 . '\\' . $2;
8871             }
8872             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8873 22 100 100     214 $char[$i] = $1 . '\\' . $2;
8874 3990         15869 }
8875             }
8876             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
8877 204         723 $char[-1] = $1 . '\\' . $2;
8878 3990         22193 }
8879              
8880             return join '', $ope, $delimiter, @char, $end_delimiter;
8881             return join '', $ope, $delimiter, $string, $end_delimiter;
8882             }
8883              
8884             #
8885 0     9594 0 0 # escape qq string (qq//, "", qx//, ``)
8886             #
8887 9594         23086 sub e_qq {
8888             my($ope,$delimiter,$end_delimiter,$string) = @_;
8889 9594         14095  
8890 9594         12049 $slash = 'div';
8891              
8892             my $left_e = 0;
8893 9594         11101 my $right_e = 0;
8894              
8895             # split regexp
8896             my @char = $string =~ /\G((?>
8897             [^\x81-\x9F\xE0-\xFC\\\$]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
8898             \\x\{ (?>[0-9A-Fa-f]+) \} |
8899             \\o\{ (?>[0-7]+) \} |
8900             \\N\{ (?>[^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} |
8901             \\ $q_char |
8902             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
8903             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
8904             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
8905             \$ (?>\s* [0-9]+) |
8906             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
8907             \$ \$ (?![\w\{]) |
8908             \$ (?>\s*) \$ (?>\s*) $qq_variable |
8909 9594         372843 $q_char
8910             ))/oxmsg;
8911              
8912 9594 50 66     30853 for (my $i=0; $i <= $#char; $i++) {
    50 33        
    100          
    100          
    50          
8913 309953         1039985  
8914             # "\L\u" --> "\u\L"
8915             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
8916             @char[$i,$i+1] = @char[$i+1,$i];
8917             }
8918 0         0  
8919             # "\U\l" --> "\l\U"
8920             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
8921             @char[$i,$i+1] = @char[$i+1,$i];
8922             }
8923 0         0  
8924             # octal escape sequence
8925             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
8926             $char[$i] = Esjis::octchr($1);
8927             }
8928 1         3  
8929             # hexadecimal escape sequence
8930             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
8931             $char[$i] = Esjis::hexchr($1);
8932             }
8933 1         4  
8934             # \N{CHARNAME} --> N{CHARNAME}
8935             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} ) \z/oxms) {
8936 0 100       0 $char[$i] = $1;
    100          
    50          
    50          
    50          
    100          
    100          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
8937             }
8938              
8939             if (0) {
8940             }
8941              
8942 309953         3028941 # escape last octet of multiple-octet
8943 0         0 # my $metachar = qr/[\@\\\|]/oxms; # '|' is for qx//, ``, open(), and system()
8944             # variable $delimiter and $end_delimiter can be ''
8945             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\@\\\|$delimiter$end_delimiter]) \z/xms) {
8946             $char[$i] = $1 . '\\' . $2;
8947             }
8948              
8949             # \F
8950             #
8951             # P.69 Table 2-6. Translation escapes
8952             # in Chapter 2: Bits and Pieces
8953             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8954             # (and so on)
8955 1342 50       5295  
8956 650         1789 # \u \l \U \L \F \Q \E
8957             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
8958             if ($right_e < $left_e) {
8959             $char[$i] = '\\' . $char[$i];
8960             }
8961             }
8962             elsif ($char[$i] eq '\u') {
8963              
8964             # "STRING @{[ LIST EXPR ]} MORE STRING"
8965              
8966             # P.257 Other Tricks You Can Do with Hard References
8967             # in Chapter 8: References
8968             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
8969              
8970             # P.353 Other Tricks You Can Do with Hard References
8971             # in Chapter 8: References
8972             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
8973 0         0  
8974 0         0 # (and so on)
8975              
8976             $char[$i] = '@{[Esjis::ucfirst qq<';
8977 0         0 $left_e++;
8978 0         0 }
8979             elsif ($char[$i] eq '\l') {
8980             $char[$i] = '@{[Esjis::lcfirst qq<';
8981 0         0 $left_e++;
8982 0         0 }
8983             elsif ($char[$i] eq '\U') {
8984             $char[$i] = '@{[Esjis::uc qq<';
8985 0         0 $left_e++;
8986 6         10 }
8987             elsif ($char[$i] eq '\L') {
8988             $char[$i] = '@{[Esjis::lc qq<';
8989 6         14 $left_e++;
8990 9         16 }
8991             elsif ($char[$i] eq '\F') {
8992             $char[$i] = '@{[Esjis::fc qq<';
8993 9         22 $left_e++;
8994 0         0 }
8995             elsif ($char[$i] eq '\Q') {
8996             $char[$i] = '@{[CORE::quotemeta qq<';
8997 0 50       0 $left_e++;
8998 12         27 }
8999 12         21 elsif ($char[$i] eq '\E') {
9000             if ($right_e < $left_e) {
9001             $char[$i] = '>]}';
9002 12         27 $right_e++;
9003             }
9004             else {
9005             $char[$i] = '';
9006 0         0 }
9007 0 0       0 }
9008 0         0 elsif ($char[$i] eq '\Q') {
9009             while (1) {
9010 0 0       0 if (++$i > $#char) {
9011 0         0 last;
9012             }
9013             if ($char[$i] eq '\E') {
9014             last;
9015             }
9016             }
9017             }
9018             elsif ($char[$i] eq '\E') {
9019             }
9020              
9021             # $0 --> $0
9022             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9023             }
9024             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9025             }
9026              
9027             # $$ --> $$
9028             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9029             }
9030              
9031 0         0 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9032             # $1, $2, $3 --> $1, $2, $3 otherwise
9033             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9034 415         1530 $char[$i] = e_capture($1);
9035             }
9036             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9037             $char[$i] = e_capture($1);
9038             }
9039 0         0  
9040             # $$foo[ ... ] --> $ $foo->[ ... ]
9041             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
9042             $char[$i] = e_capture($1.'->'.$2);
9043             }
9044 0         0  
9045             # $$foo{ ... } --> $ $foo->{ ... }
9046             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
9047             $char[$i] = e_capture($1.'->'.$2);
9048             }
9049 0         0  
9050             # $$foo
9051             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9052             $char[$i] = e_capture($1);
9053             }
9054 0         0  
9055             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Esjis::PREMATCH()
9056             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9057             $char[$i] = '@{[Esjis::PREMATCH()]}';
9058             }
9059 44         151  
9060             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Esjis::MATCH()
9061             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9062             $char[$i] = '@{[Esjis::MATCH()]}';
9063             }
9064 45         154  
9065             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Esjis::POSTMATCH()
9066             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9067             $char[$i] = '@{[Esjis::POSTMATCH()]}';
9068             }
9069              
9070             # ${ foo } --> ${ foo }
9071             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
9072             }
9073 33         104  
9074             # ${ ... }
9075             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9076             $char[$i] = e_capture($1);
9077             }
9078 0 100       0 }
9079 9594         20865  
9080             # return string
9081 3         19 if ($left_e > $right_e) {
9082             return join '', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter;
9083             }
9084             return join '', $ope, $delimiter, @char, $end_delimiter;
9085             }
9086              
9087             #
9088 9591     34 0 83241 # escape qw string (qw//)
9089             #
9090 34         147 sub e_qw {
9091             my($ope,$delimiter,$end_delimiter,$string) = @_;
9092              
9093 34         70 $slash = 'div';
  34         310  
9094 621 50       949  
    0          
    0          
    0          
    0          
9095 34         161 # choice again delimiter
9096             my %octet = map {$_ => 1} ($string =~ /\G ([\x00-\xFF]) /oxmsg);
9097             if (not $octet{$end_delimiter}) {
9098 34         222 return join '', $ope, $delimiter, $string, $end_delimiter;
9099             }
9100             elsif (not $octet{')'}) {
9101 0         0 return join '', $ope, '(', $string, ')';
9102             }
9103             elsif (not $octet{'}'}) {
9104 0         0 return join '', $ope, '{', $string, '}';
9105             }
9106             elsif (not $octet{']'}) {
9107 0         0 return join '', $ope, '[', $string, ']';
9108             }
9109             elsif (not $octet{'>'}) {
9110 0         0 return join '', $ope, '<', $string, '>';
9111 0 0       0 }
9112 0         0 else {
9113             for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9114             if (not $octet{$char}) {
9115             return join '', $ope, $char, $string, $char;
9116             }
9117             }
9118 0         0 }
9119 0         0  
9120 0         0 # qw/AAA BBB C'CC/ --> ('AAA', 'BBB', 'C\'CC')
9121 0         0 my @string = CORE::split(/\s+/, $string);
9122 0 0       0 for my $string (@string) {
9123 0         0 my @octet = $string =~ /\G ([\x00-\xFF]) /oxmsg;
9124             for my $octet (@octet) {
9125             if ($octet =~ /\A (['\\]) \z/oxms) {
9126 0         0 $octet = '\\' . $1;
9127             }
9128 0         0 }
  0         0  
9129             $string = join '', @octet;
9130             }
9131             return join '', '(', (join ', ', map { "'$_'" } @string), ')';
9132             }
9133              
9134             #
9135 0     108 0 0 # escape here document (<<"HEREDOC", <
9136             #
9137 108         302 sub e_heredoc {
9138             my($string) = @_;
9139 108         203  
9140             $slash = 'm//';
9141 108         350  
9142 108         183 my $metachar = qr/[\@\\|]/oxms; # '|' is for <<`HEREDOC`
9143              
9144             my $left_e = 0;
9145 108         148 my $right_e = 0;
9146              
9147             # split regexp
9148             my @char = $string =~ /\G((?>
9149             [^\x81-\x9F\xE0-\xFC\\\$]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
9150             \\x\{ (?>[0-9A-Fa-f]+) \} |
9151             \\o\{ (?>[0-7]+) \} |
9152             \\N\{ (?>[^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} |
9153             \\ $q_char |
9154             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9155             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9156             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9157             \$ (?>\s* [0-9]+) |
9158             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9159             \$ \$ (?![\w\{]) |
9160             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9161 108         11434 $q_char
9162             ))/oxmsg;
9163              
9164 108 50 66     515 for (my $i=0; $i <= $#char; $i++) {
    50 33        
    100          
    100          
    50          
9165 3225         10598  
9166             # "\L\u" --> "\u\L"
9167             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9168             @char[$i,$i+1] = @char[$i+1,$i];
9169             }
9170 0         0  
9171             # "\U\l" --> "\l\U"
9172             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9173             @char[$i,$i+1] = @char[$i+1,$i];
9174             }
9175 0         0  
9176             # octal escape sequence
9177             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9178             $char[$i] = Esjis::octchr($1);
9179             }
9180 1         3  
9181             # hexadecimal escape sequence
9182             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9183             $char[$i] = Esjis::hexchr($1);
9184             }
9185 1         3  
9186             # \N{CHARNAME} --> N{CHARNAME}
9187             elsif ($char[$i] =~ /\A \\ ( N\{ ([^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} ) \z/oxms) {
9188 0 100       0 $char[$i] = $1;
    100          
    50          
    50          
    50          
    100          
    50          
    50          
    100          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    100          
    100          
    100          
    50          
    50          
9189             }
9190              
9191             if (0) {
9192 3225         30525 }
9193 0         0  
9194             # escape character
9195             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
9196             $char[$i] = $1 . '\\' . $2;
9197             }
9198 57 50       234  
9199 72         130 # \u \l \U \L \F \Q \E
9200             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
9201             if ($right_e < $left_e) {
9202             $char[$i] = '\\' . $char[$i];
9203 0         0 }
9204 0         0 }
9205             elsif ($char[$i] eq '\u') {
9206             $char[$i] = '@{[Esjis::ucfirst qq<';
9207 0         0 $left_e++;
9208 0         0 }
9209             elsif ($char[$i] eq '\l') {
9210             $char[$i] = '@{[Esjis::lcfirst qq<';
9211 0         0 $left_e++;
9212 0         0 }
9213             elsif ($char[$i] eq '\U') {
9214             $char[$i] = '@{[Esjis::uc qq<';
9215 0         0 $left_e++;
9216 6         11 }
9217             elsif ($char[$i] eq '\L') {
9218             $char[$i] = '@{[Esjis::lc qq<';
9219 6         12 $left_e++;
9220 0         0 }
9221             elsif ($char[$i] eq '\F') {
9222             $char[$i] = '@{[Esjis::fc qq<';
9223 0         0 $left_e++;
9224 0         0 }
9225             elsif ($char[$i] eq '\Q') {
9226             $char[$i] = '@{[CORE::quotemeta qq<';
9227 0 50       0 $left_e++;
9228 3         7 }
9229 3         4 elsif ($char[$i] eq '\E') {
9230             if ($right_e < $left_e) {
9231             $char[$i] = '>]}';
9232 3         7 $right_e++;
9233             }
9234             else {
9235             $char[$i] = '';
9236 0         0 }
9237 0 0       0 }
9238 0         0 elsif ($char[$i] eq '\Q') {
9239             while (1) {
9240 0 0       0 if (++$i > $#char) {
9241 0         0 last;
9242             }
9243             if ($char[$i] eq '\E') {
9244             last;
9245             }
9246             }
9247             }
9248             elsif ($char[$i] eq '\E') {
9249             }
9250              
9251             # $0 --> $0
9252             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9253             }
9254             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9255             }
9256              
9257             # $$ --> $$
9258             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9259             }
9260              
9261 0         0 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9262             # $1, $2, $3 --> $1, $2, $3 otherwise
9263             elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9264 0         0 $char[$i] = e_capture($1);
9265             }
9266             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9267             $char[$i] = e_capture($1);
9268             }
9269 0         0  
9270             # $$foo[ ... ] --> $ $foo->[ ... ]
9271             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
9272             $char[$i] = e_capture($1.'->'.$2);
9273             }
9274 0         0  
9275             # $$foo{ ... } --> $ $foo->{ ... }
9276             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
9277             $char[$i] = e_capture($1.'->'.$2);
9278             }
9279 0         0  
9280             # $$foo
9281             elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9282             $char[$i] = e_capture($1);
9283             }
9284 0         0  
9285             # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Esjis::PREMATCH()
9286             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9287             $char[$i] = '@{[Esjis::PREMATCH()]}';
9288             }
9289 8         55  
9290             # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Esjis::MATCH()
9291             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9292             $char[$i] = '@{[Esjis::MATCH()]}';
9293             }
9294 8         52  
9295             # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Esjis::POSTMATCH()
9296             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9297             $char[$i] = '@{[Esjis::POSTMATCH()]}';
9298             }
9299              
9300             # ${ foo } --> ${ foo }
9301             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ (?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* ) \} \z/oxms) {
9302             }
9303 6         38  
9304             # ${ ... }
9305             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9306             $char[$i] = e_capture($1);
9307             }
9308 0 100       0 }
9309 108         245  
9310             # return string
9311 3         24 if ($left_e > $right_e) {
9312             return join '', @char, '>]}' x ($left_e - $right_e);
9313             }
9314             return join '', @char;
9315             }
9316              
9317             #
9318 105     1835 0 877 # escape regexp (m//, qr//)
9319 1835   100     7835 #
9320             sub e_qr {
9321 1835         6691 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9322 1835 50       3482 $modifier ||= '';
9323 1835         4669  
9324 0         0 $modifier =~ tr/p//d;
9325 0 0       0 if ($modifier =~ /([adlu])/oxms) {
9326 0         0 my $line = 0;
9327 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9328             if ($filename ne __FILE__) {
9329             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9330 0         0 last;
9331             }
9332             }
9333 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
9334             }
9335              
9336 1835 100       3043 $slash = 'div';
    100          
9337 1835         5867  
9338 8         11 # literal null string pattern
9339 8         11 if ($string eq '') {
9340             $modifier =~ tr/bB//d;
9341             $modifier =~ tr/i//d;
9342             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9343             }
9344              
9345             # /b /B modifier
9346 8 50       49 elsif ($modifier =~ tr/bB//d) {
9347 240         594  
9348 0         0 # choice again delimiter
  0         0  
9349 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
9350 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
9351 0         0 my %octet = map {$_ => 1} @char;
9352             if (not $octet{')'}) {
9353             $delimiter = '(';
9354 0         0 $end_delimiter = ')';
9355 0         0 }
9356             elsif (not $octet{'}'}) {
9357             $delimiter = '{';
9358 0         0 $end_delimiter = '}';
9359 0         0 }
9360             elsif (not $octet{']'}) {
9361             $delimiter = '[';
9362 0         0 $end_delimiter = ']';
9363 0         0 }
9364             elsif (not $octet{'>'}) {
9365             $delimiter = '<';
9366 0         0 $end_delimiter = '>';
9367 0 0       0 }
9368 0         0 else {
9369 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9370 0         0 if (not $octet{$char}) {
9371             $delimiter = $char;
9372             $end_delimiter = $char;
9373             last;
9374             }
9375             }
9376 0 100 100     0 }
9377 240         1080 }
9378              
9379             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9380 90         526 return join '', $ope, $delimiter, $string, $matched, $end_delimiter, $modifier;
9381             }
9382             else {
9383             return join '', $ope, $delimiter, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
9384 150 100       973 }
9385 1587         3814 }
9386              
9387             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9388 1587         5435 my $metachar = qr/[\@\\|[\]{^]/oxms;
9389              
9390             # split regexp
9391             my @char = $string =~ /\G((?>
9392             [^\x81-\x9F\xE0-\xFC\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
9393             \\x (?>[0-9A-Fa-f]{1,2}) |
9394             \\ (?>[0-7]{2,3}) |
9395             \\c [\x40-\x5F] |
9396             \\x\{ (?>[0-9A-Fa-f]+) \} |
9397             \\o\{ (?>[0-7]+) \} |
9398             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} |
9399             \\ $q_char |
9400             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
9401             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
9402             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
9403             [\$\@] $qq_variable |
9404             \$ (?>\s* [0-9]+) |
9405             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
9406             \$ \$ (?![\w\{]) |
9407             \$ (?>\s*) \$ (?>\s*) $qq_variable |
9408             \[\^ |
9409             \[\: (?>[a-z]+) :\] |
9410             \[\:\^ (?>[a-z]+) :\] |
9411             \(\? |
9412             $q_char
9413 1587 50       145207 ))/oxmsg;
9414 1587         6997  
  0         0  
9415 0 0       0 # choice again delimiter
    0          
    0          
    0          
9416 0         0 if ($delimiter =~ / [\@:] /oxms) {
9417 0         0 my %octet = map {$_ => 1} @char;
9418             if (not $octet{')'}) {
9419             $delimiter = '(';
9420 0         0 $end_delimiter = ')';
9421 0         0 }
9422             elsif (not $octet{'}'}) {
9423             $delimiter = '{';
9424 0         0 $end_delimiter = '}';
9425 0         0 }
9426             elsif (not $octet{']'}) {
9427             $delimiter = '[';
9428 0         0 $end_delimiter = ']';
9429 0         0 }
9430             elsif (not $octet{'>'}) {
9431             $delimiter = '<';
9432 0         0 $end_delimiter = '>';
9433 0 0       0 }
9434 0         0 else {
9435 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9436 0         0 if (not $octet{$char}) {
9437             $delimiter = $char;
9438             $end_delimiter = $char;
9439             last;
9440             }
9441             }
9442 0         0 }
9443 1587         2490 }
9444 1587         2096  
9445             my $left_e = 0;
9446             my $right_e = 0;
9447 1587 50 66     4205 for (my $i=0; $i <= $#char; $i++) {
    50 66        
    100          
    100          
    100          
    100          
9448 5437         28953  
9449             # "\L\u" --> "\u\L"
9450             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
9451             @char[$i,$i+1] = @char[$i+1,$i];
9452             }
9453 0         0  
9454             # "\U\l" --> "\l\U"
9455             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
9456             @char[$i,$i+1] = @char[$i+1,$i];
9457             }
9458 0         0  
9459             # octal escape sequence
9460             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
9461             $char[$i] = Esjis::octchr($1);
9462             }
9463 1         3  
9464             # hexadecimal escape sequence
9465             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
9466             $char[$i] = Esjis::hexchr($1);
9467             }
9468              
9469             # \b{...} --> b\{...}
9470             # \B{...} --> B\{...}
9471             # \N{CHARNAME} --> N\{CHARNAME}
9472 1         3 # \p{PROPERTY} --> p\{PROPERTY}
9473             # \P{PROPERTY} --> P\{PROPERTY}
9474             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} ) \z/oxms) {
9475             $char[$i] = $1 . '\\' . $2;
9476             }
9477 6         24  
9478             # \p, \P, \X --> p, P, X
9479             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
9480 4 100 100     27 $char[$i] = $1;
    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          
9481             }
9482              
9483             if (0) {
9484 5437         38743 }
9485 0         0  
9486             # escape last octet of multiple-octet
9487             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9488             $char[$i] = $1 . '\\' . $2;
9489             }
9490 77 50 33     359  
    50 33        
    50 33        
      33        
      66        
      33        
9491 6         183 # join separated multiple-octet
9492             elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
9493             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)) {
9494 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
9495             }
9496             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)) {
9497 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
9498             }
9499             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)) {
9500             $char[$i] .= join '', splice @char, $i+1, 1;
9501             }
9502             }
9503 0         0  
9504             # open character class [...]
9505             elsif ($char[$i] eq '[') {
9506             my $left = $i;
9507              
9508 586 100       886 # [] make die "Unmatched [] in regexp ...\n"
9509 586         1425 # (and so on)
9510              
9511             if ($char[$i+1] eq ']') {
9512 3         5 $i++;
9513 586 50       742 }
9514 2583         3881  
9515             while (1) {
9516 0 100       0 if (++$i > $#char) {
9517 2583         4050 die __FILE__, ": Unmatched [] in regexp\n";
9518             }
9519             if ($char[$i] eq ']') {
9520 586 100       726 my $right = $i;
9521 586         3063  
  90         228  
9522             # [...]
9523             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9524 270         504 splice @char, $left, $right-$left+1, sprintf(q{@{[Esjis::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9525             }
9526             else {
9527 496         2119 splice @char, $left, $right-$left+1, Esjis::charlist_qr(@char[$left+1..$right-1], $modifier);
9528 586         1096 }
9529              
9530             $i = $left;
9531             last;
9532             }
9533             }
9534             }
9535 586         1737  
9536             # open character class [^...]
9537             elsif ($char[$i] eq '[^') {
9538             my $left = $i;
9539              
9540 328 100       491 # [^] make die "Unmatched [] in regexp ...\n"
9541 328         709 # (and so on)
9542              
9543             if ($char[$i+1] eq ']') {
9544 5         8 $i++;
9545 328 50       386 }
9546 1447         2110  
9547             while (1) {
9548 0 100       0 if (++$i > $#char) {
9549 1447         2206 die __FILE__, ": Unmatched [] in regexp\n";
9550             }
9551             if ($char[$i] eq ']') {
9552 328 100       375 my $right = $i;
9553 328         1601  
  90         238  
9554             # [^...]
9555             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
9556 270         539 splice @char, $left, $right-$left+1, sprintf(q{@{[Esjis::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
9557             }
9558             else {
9559 238         919 splice @char, $left, $right-$left+1, Esjis::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9560 328         606 }
9561              
9562             $i = $left;
9563             last;
9564             }
9565             }
9566             }
9567 328         921  
9568             # rewrite character class or escape character
9569             elsif (my $char = character_class($char[$i],$modifier)) {
9570             $char[$i] = $char;
9571             }
9572 215 50       629  
9573 238         444 # /i modifier
9574             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Esjis::uc($char[$i]) ne Esjis::fc($char[$i]))) {
9575             if (CORE::length(Esjis::fc($char[$i])) == 1) {
9576 238         471 $char[$i] = '[' . Esjis::uc($char[$i]) . Esjis::fc($char[$i]) . ']';
9577             }
9578             else {
9579             $char[$i] = '(?:' . Esjis::uc($char[$i]) . '|' . Esjis::fc($char[$i]) . ')';
9580             }
9581             }
9582 0 50       0  
9583 1         5 # \u \l \U \L \F \Q \E
9584             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
9585             if ($right_e < $left_e) {
9586             $char[$i] = '\\' . $char[$i];
9587 0         0 }
9588 0         0 }
9589             elsif ($char[$i] eq '\u') {
9590             $char[$i] = '@{[Esjis::ucfirst qq<';
9591 0         0 $left_e++;
9592 0         0 }
9593             elsif ($char[$i] eq '\l') {
9594             $char[$i] = '@{[Esjis::lcfirst qq<';
9595 0         0 $left_e++;
9596 1         3 }
9597             elsif ($char[$i] eq '\U') {
9598             $char[$i] = '@{[Esjis::uc qq<';
9599 1         5 $left_e++;
9600 1         4 }
9601             elsif ($char[$i] eq '\L') {
9602             $char[$i] = '@{[Esjis::lc qq<';
9603 1         3 $left_e++;
9604 9         17 }
9605             elsif ($char[$i] eq '\F') {
9606             $char[$i] = '@{[Esjis::fc qq<';
9607 9         20 $left_e++;
9608 22         50 }
9609             elsif ($char[$i] eq '\Q') {
9610             $char[$i] = '@{[CORE::quotemeta qq<';
9611 22 50       63 $left_e++;
9612 33         86 }
9613 33         62 elsif ($char[$i] eq '\E') {
9614             if ($right_e < $left_e) {
9615             $char[$i] = '>]}';
9616 33         85 $right_e++;
9617             }
9618             else {
9619             $char[$i] = '';
9620 0         0 }
9621 0 0       0 }
9622 0         0 elsif ($char[$i] eq '\Q') {
9623             while (1) {
9624 0 0       0 if (++$i > $#char) {
9625 0         0 last;
9626             }
9627             if ($char[$i] eq '\E') {
9628             last;
9629             }
9630             }
9631             }
9632             elsif ($char[$i] eq '\E') {
9633             }
9634 0 0       0  
9635 0         0 # $0 --> $0
9636             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
9637             if ($ignorecase) {
9638             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9639 0 0       0 }
9640 0         0 }
9641             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
9642             if ($ignorecase) {
9643             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9644             }
9645             }
9646              
9647             # $$ --> $$
9648             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
9649             }
9650              
9651 0         0 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
9652 0 0       0 # $1, $2, $3 --> $1, $2, $3 otherwise
9653 0         0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
9654             $char[$i] = e_capture($1);
9655             if ($ignorecase) {
9656             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9657 0         0 }
9658 0 0       0 }
9659 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
9660             $char[$i] = e_capture($1);
9661             if ($ignorecase) {
9662             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9663             }
9664             }
9665 0         0  
9666 0 0       0 # $$foo[ ... ] --> $ $foo->[ ... ]
9667 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
9668             $char[$i] = e_capture($1.'->'.$2);
9669             if ($ignorecase) {
9670             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9671             }
9672             }
9673 0         0  
9674 0 0       0 # $$foo{ ... } --> $ $foo->{ ... }
9675 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
9676             $char[$i] = e_capture($1.'->'.$2);
9677             if ($ignorecase) {
9678             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9679             }
9680             }
9681 0         0  
9682 0 0       0 # $$foo
9683 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
9684             $char[$i] = e_capture($1);
9685             if ($ignorecase) {
9686             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9687             }
9688             }
9689 0 50       0  
9690 8         27 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Esjis::PREMATCH()
9691             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
9692             if ($ignorecase) {
9693 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::PREMATCH())]}';
9694             }
9695             else {
9696             $char[$i] = '@{[Esjis::PREMATCH()]}';
9697             }
9698             }
9699 8 50       30  
9700 8         23 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Esjis::MATCH()
9701             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
9702             if ($ignorecase) {
9703 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::MATCH())]}';
9704             }
9705             else {
9706             $char[$i] = '@{[Esjis::MATCH()]}';
9707             }
9708             }
9709 8 50       27  
9710 6         20 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Esjis::POSTMATCH()
9711             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
9712             if ($ignorecase) {
9713 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::POSTMATCH())]}';
9714             }
9715             else {
9716             $char[$i] = '@{[Esjis::POSTMATCH()]}';
9717             }
9718             }
9719 6 0       20  
9720 0         0 # ${ foo }
9721             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
9722             if ($ignorecase) {
9723             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9724             }
9725             }
9726 0         0  
9727 0 0       0 # ${ ... }
9728 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
9729             $char[$i] = e_capture($1);
9730             if ($ignorecase) {
9731             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9732             }
9733             }
9734 0         0  
9735 31 100       99 # $scalar or @array
9736 31         132 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
9737             $char[$i] = e_string($char[$i]);
9738             if ($ignorecase) {
9739             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
9740             }
9741             }
9742 4 100 66     15  
    50          
9743             # quote character before ? + * {
9744             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9745 188         1545 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
9746 0 0       0 }
9747 0         0 elsif (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9748             my $char = $char[$i-1];
9749             if ($char[$i] eq '{') {
9750 0         0 die __FILE__, qq{: "MULTIBYTE{n}" should be "(MULTIBYTE){n}" in m?? (and shift \$1,\$2,\$3,...) ($char){n}\n};
9751             }
9752             else {
9753             die __FILE__, qq{: "MULTIBYTE$char[$i]" should be "(MULTIBYTE)$char[$i]" in m?? (and shift \$1,\$2,\$3,...) ($char)$char[$i]\n};
9754 0         0 }
9755             }
9756             else {
9757             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9758             }
9759             }
9760 187         813 }
9761 1587 50       3120  
9762 1587 0 0     3920 # make regexp string
9763 0         0 $modifier =~ tr/i//d;
9764             if ($left_e > $right_e) {
9765             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9766 0         0 return join '', $ope, $delimiter, $anchor, @char, '>]}' x ($left_e - $right_e), $matched, $end_delimiter, $modifier;
9767             }
9768             else {
9769 0 100 100     0 return join '', $ope, $delimiter, $anchor, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
9770 1587         8477 }
9771             }
9772             if (($ope =~ /\A m? \z/oxms) and ($delimiter eq '?')) {
9773 94         730 return join '', $ope, $delimiter, $anchor, @char, $matched, $end_delimiter, $modifier;
9774             }
9775             else {
9776             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9777             }
9778             }
9779              
9780             #
9781 1493     540 0 13626 # double quote stuff
9782             #
9783             sub qq_stuff {
9784 540 100       956 my($delimiter,$end_delimiter,$stuff) = @_;
9785 540         1227  
9786             # scalar variable or array variable
9787             if ($stuff =~ /\A [\$\@] /oxms) {
9788             return $stuff;
9789 300         1235 }
  240         680  
9790 280         850  
9791 240 50       715 # quote by delimiter
9792 240 50       476 my %octet = map {$_ => 1} ($stuff =~ /\G ([\x00-\xFF]) /oxmsg);
9793 240 50       440 for my $char (qw( ! " $ % & * + - . / : = ? @ ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
9794 240         489 next if $char eq $delimiter;
9795             next if $char eq $end_delimiter;
9796             if (not $octet{$char}) {
9797 240         1085 return join '', 'qq', $char, $stuff, $char;
9798             }
9799             }
9800             return join '', 'qq', '<', $stuff, '>';
9801             }
9802              
9803             #
9804 0     163 0 0 # escape regexp (m'', qr'', and m''b, qr''b)
9805 163   100     901 #
9806             sub e_qr_q {
9807 163         533 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9808 163 50       378 $modifier ||= '';
9809 163         485  
9810 0         0 $modifier =~ tr/p//d;
9811 0 0       0 if ($modifier =~ /([adlu])/oxms) {
9812 0         0 my $line = 0;
9813 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9814             if ($filename ne __FILE__) {
9815             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9816 0         0 last;
9817             }
9818             }
9819 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
9820             }
9821              
9822 163 100       289 $slash = 'div';
    100          
9823 163         432  
9824 8         12 # literal null string pattern
9825 8         11 if ($string eq '') {
9826             $modifier =~ tr/bB//d;
9827             $modifier =~ tr/i//d;
9828             return join '', $ope, $delimiter, $end_delimiter, $modifier;
9829             }
9830 8         50  
9831             # with /b /B modifier
9832             elsif ($modifier =~ tr/bB//d) {
9833             return e_qr_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
9834             }
9835 89         230  
9836             # without /b /B modifier
9837             else {
9838             return e_qr_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
9839             }
9840             }
9841              
9842             #
9843 66     66 0 173 # escape regexp (m'', qr'')
9844             #
9845 66 100       186 sub e_qr_qt {
9846             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9847              
9848 66         198 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
9849              
9850             # split regexp
9851             my @char = $string =~ /\G((?>
9852             [^\x81-\x9F\xE0-\xFC\\\[\$\@\/] |
9853             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
9854             \[\^ |
9855             \[\: (?>[a-z]+) \:\] |
9856             \[\:\^ (?>[a-z]+) \:\] |
9857             [\$\@\/] |
9858             \\ (?:$q_char) |
9859             (?:$q_char)
9860 66         782 ))/oxmsg;
9861 66 100 100     248  
    50 100        
    50 66        
    50          
    50          
    100          
    50          
9862             # unescape character
9863             for (my $i=0; $i <= $#char; $i++) {
9864             if (0) {
9865 79         964 }
9866 0         0  
9867             # escape last octet of multiple-octet
9868             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
9869             $char[$i] = $1 . '\\' . $2;
9870             }
9871 2         13  
9872 0 0       0 # open character class [...]
9873 0         0 elsif ($char[$i] eq '[') {
9874             my $left = $i;
9875 0         0 if ($char[$i+1] eq ']') {
9876 0 0       0 $i++;
9877 0         0 }
9878             while (1) {
9879 0 0       0 if (++$i > $#char) {
9880 0         0 die __FILE__, ": Unmatched [] in regexp\n";
9881             }
9882             if ($char[$i] eq ']') {
9883 0         0 my $right = $i;
9884              
9885 0         0 # [...]
9886 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_qr(@char[$left+1..$right-1], $modifier);
9887              
9888             $i = $left;
9889             last;
9890             }
9891             }
9892             }
9893 0         0  
9894 0 0       0 # open character class [^...]
9895 0         0 elsif ($char[$i] eq '[^') {
9896             my $left = $i;
9897 0         0 if ($char[$i+1] eq ']') {
9898 0 0       0 $i++;
9899 0         0 }
9900             while (1) {
9901 0 0       0 if (++$i > $#char) {
9902 0         0 die __FILE__, ": Unmatched [] in regexp\n";
9903             }
9904             if ($char[$i] eq ']') {
9905 0         0 my $right = $i;
9906              
9907 0         0 # [^...]
9908 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_not_qr(@char[$left+1..$right-1], $modifier);
9909              
9910             $i = $left;
9911             last;
9912             }
9913             }
9914             }
9915 0         0  
9916             # escape $ @ / and \
9917             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9918             $char[$i] = '\\' . $char[$i];
9919             }
9920 0         0  
9921             # rewrite character class or escape character
9922             elsif (my $char = character_class($char[$i],$modifier)) {
9923             $char[$i] = $char;
9924             }
9925 0 50       0  
9926 16         44 # /i modifier
9927             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Esjis::uc($char[$i]) ne Esjis::fc($char[$i]))) {
9928             if (CORE::length(Esjis::fc($char[$i])) == 1) {
9929 16         39 $char[$i] = '[' . Esjis::uc($char[$i]) . Esjis::fc($char[$i]) . ']';
9930             }
9931             else {
9932             $char[$i] = '(?:' . Esjis::uc($char[$i]) . '|' . Esjis::fc($char[$i]) . ')';
9933             }
9934             }
9935 0 0       0  
9936             # quote character before ? + * {
9937             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
9938 0         0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
9939             }
9940             else {
9941             $char[$i-1] = '(?:' . $char[$i-1] . ')';
9942             }
9943 0         0 }
9944 66         167 }
9945              
9946 66         151 $delimiter = '/';
9947 66         123 $end_delimiter = '/';
9948              
9949             $modifier =~ tr/i//d;
9950             return join '', $ope, $delimiter, $anchor, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9951             }
9952              
9953             #
9954 66     89 0 532 # escape regexp (m''b, qr''b)
9955             #
9956             sub e_qr_qb {
9957 89         214 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9958              
9959             # split regexp
9960 89         382 my @char = $string =~ /\G ((?>[^\\]|\\\\|[\x00-\xFF])) /oxmsg;
9961 89 50       274  
    50          
9962             # unescape character
9963             for (my $i=0; $i <= $#char; $i++) {
9964             if (0) {
9965 199         682 }
9966              
9967             # remain \\
9968             elsif ($char[$i] eq '\\\\') {
9969             }
9970 0         0  
9971             # escape $ @ / and \
9972             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
9973             $char[$i] = '\\' . $char[$i];
9974 0         0 }
9975 89         151 }
9976 89         135  
9977             $delimiter = '/';
9978             $end_delimiter = '/';
9979             return join '', $ope, $delimiter, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
9980             }
9981              
9982             #
9983 89     195 0 614 # escape regexp (s/here//)
9984 195   100     590 #
9985             sub e_s1 {
9986 195         779 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
9987 195 50       355 $modifier ||= '';
9988 195         569  
9989 0         0 $modifier =~ tr/p//d;
9990 0 0       0 if ($modifier =~ /([adlu])/oxms) {
9991 0         0 my $line = 0;
9992 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
9993             if ($filename ne __FILE__) {
9994             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
9995 0         0 last;
9996             }
9997             }
9998 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
9999             }
10000              
10001 195 100       377 $slash = 'div';
    100          
10002 195         640  
10003 8         11 # literal null string pattern
10004 8         14 if ($string eq '') {
10005             $modifier =~ tr/bB//d;
10006             $modifier =~ tr/i//d;
10007             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10008             }
10009              
10010             # /b /B modifier
10011 8 50       60 elsif ($modifier =~ tr/bB//d) {
10012 44         113  
10013 0         0 # choice again delimiter
  0         0  
10014 0 0       0 if ($delimiter =~ / [\@:] /oxms) {
    0          
    0          
    0          
10015 0         0 my @char = $string =~ /\G ([\x00-\xFF]) /oxmsg;
10016 0         0 my %octet = map {$_ => 1} @char;
10017             if (not $octet{')'}) {
10018             $delimiter = '(';
10019 0         0 $end_delimiter = ')';
10020 0         0 }
10021             elsif (not $octet{'}'}) {
10022             $delimiter = '{';
10023 0         0 $end_delimiter = '}';
10024 0         0 }
10025             elsif (not $octet{']'}) {
10026             $delimiter = '[';
10027 0         0 $end_delimiter = ']';
10028 0         0 }
10029             elsif (not $octet{'>'}) {
10030             $delimiter = '<';
10031 0         0 $end_delimiter = '>';
10032 0 0       0 }
10033 0         0 else {
10034 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
10035 0         0 if (not $octet{$char}) {
10036             $delimiter = $char;
10037             $end_delimiter = $char;
10038             last;
10039             }
10040             }
10041 0         0 }
10042 44         59 }
10043 44         49  
10044             my $prematch = '';
10045             $prematch = q{(\G[\x00-\xFF]*?)};
10046 44 100       265 return join '', $ope, $delimiter, $prematch, '(?:', $string, ')', $matched, $end_delimiter, $modifier;
10047 143         427 }
10048              
10049             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10050 143         701 my $metachar = qr/[\@\\|[\]{^]/oxms;
10051              
10052             # split regexp
10053             my @char = $string =~ /\G((?>
10054             [^\x81-\x9F\xE0-\xFC\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
10055             \\ (?>[1-9][0-9]*) |
10056             \\g (?>\s*) (?>[1-9][0-9]*) |
10057             \\g (?>\s*) \{ (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
10058             \\g (?>\s*) \{ (?>\s*) - (?>\s*) (?>[1-9][0-9]*) (?>\s*) \} |
10059             \\x (?>[0-9A-Fa-f]{1,2}) |
10060             \\ (?>[0-7]{2,3}) |
10061             \\c [\x40-\x5F] |
10062             \\x\{ (?>[0-9A-Fa-f]+) \} |
10063             \\o\{ (?>[0-7]+) \} |
10064             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} |
10065             \\ $q_char |
10066             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10067             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10068             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10069             [\$\@] $qq_variable |
10070             \$ (?>\s* [0-9]+) |
10071             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10072             \$ \$ (?![\w\{]) |
10073             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10074             \[\^ |
10075             \[\: (?>[a-z]+) :\] |
10076             \[\:\^ (?>[a-z]+) :\] |
10077             \(\? |
10078             $q_char
10079 143 50       39269 ))/oxmsg;
10080 143         1263  
  0         0  
10081 0 0       0 # choice again delimiter
    0          
    0          
    0          
10082 0         0 if ($delimiter =~ / [\@:] /oxms) {
10083 0         0 my %octet = map {$_ => 1} @char;
10084             if (not $octet{')'}) {
10085             $delimiter = '(';
10086 0         0 $end_delimiter = ')';
10087 0         0 }
10088             elsif (not $octet{'}'}) {
10089             $delimiter = '{';
10090 0         0 $end_delimiter = '}';
10091 0         0 }
10092             elsif (not $octet{']'}) {
10093             $delimiter = '[';
10094 0         0 $end_delimiter = ']';
10095 0         0 }
10096             elsif (not $octet{'>'}) {
10097             $delimiter = '<';
10098 0         0 $end_delimiter = '>';
10099 0 0       0 }
10100 0         0 else {
10101 0         0 for my $char (qw( ! " $ % & * + - . / = ? ^ ` | ~ ), "\x00".."\x1F", "\x7F", "\xFF") {
10102 0         0 if (not $octet{$char}) {
10103             $delimiter = $char;
10104             $end_delimiter = $char;
10105             last;
10106             }
10107             }
10108             }
10109 0         0 }
  143         429  
10110              
10111 477         963 # count '('
10112 143         232 my $parens = grep { $_ eq '(' } @char;
10113 143         241  
10114             my $left_e = 0;
10115             my $right_e = 0;
10116 143 50 33     440 for (my $i=0; $i <= $#char; $i++) {
    50 33        
    100          
    100          
    50          
    50          
10117 398         2558  
10118             # "\L\u" --> "\u\L"
10119             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
10120             @char[$i,$i+1] = @char[$i+1,$i];
10121             }
10122 0         0  
10123             # "\U\l" --> "\l\U"
10124             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
10125             @char[$i,$i+1] = @char[$i+1,$i];
10126             }
10127 0         0  
10128             # octal escape sequence
10129             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
10130             $char[$i] = Esjis::octchr($1);
10131             }
10132 1         4  
10133             # hexadecimal escape sequence
10134             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
10135             $char[$i] = Esjis::hexchr($1);
10136             }
10137              
10138             # \b{...} --> b\{...}
10139             # \B{...} --> B\{...}
10140             # \N{CHARNAME} --> N\{CHARNAME}
10141 1         3 # \p{PROPERTY} --> p\{PROPERTY}
10142             # \P{PROPERTY} --> P\{PROPERTY}
10143             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} ) \z/oxms) {
10144             $char[$i] = $1 . '\\' . $2;
10145             }
10146 0         0  
10147             # \p, \P, \X --> p, P, X
10148             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
10149 0 100 100     0 $char[$i] = $1;
    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          
10150             }
10151              
10152             if (0) {
10153 398         5452 }
10154 0         0  
10155             # escape last octet of multiple-octet
10156             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10157             $char[$i] = $1 . '\\' . $2;
10158             }
10159 23 0 0     126  
    0 0        
    0 0        
      0        
      0        
      0        
10160 0         0 # join separated multiple-octet
10161             elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
10162             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)) {
10163 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
10164             }
10165             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)) {
10166 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
10167             }
10168             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)) {
10169             $char[$i] .= join '', splice @char, $i+1, 1;
10170             }
10171             }
10172 0         0  
10173 20 50       55 # open character class [...]
10174 20         84 elsif ($char[$i] eq '[') {
10175             my $left = $i;
10176 0         0 if ($char[$i+1] eq ']') {
10177 20 50       38 $i++;
10178 79         154 }
10179             while (1) {
10180 0 100       0 if (++$i > $#char) {
10181 79         244 die __FILE__, ": Unmatched [] in regexp\n";
10182             }
10183             if ($char[$i] eq ']') {
10184 20 50       50 my $right = $i;
10185 20         183  
  0         0  
10186             # [...]
10187             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10188 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Esjis::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10189             }
10190             else {
10191 20         113 splice @char, $left, $right-$left+1, Esjis::charlist_qr(@char[$left+1..$right-1], $modifier);
10192 20         44 }
10193              
10194             $i = $left;
10195             last;
10196             }
10197             }
10198             }
10199 20         84  
10200 0 0       0 # open character class [^...]
10201 0         0 elsif ($char[$i] eq '[^') {
10202             my $left = $i;
10203 0         0 if ($char[$i+1] eq ']') {
10204 0 0       0 $i++;
10205 0         0 }
10206             while (1) {
10207 0 0       0 if (++$i > $#char) {
10208 0         0 die __FILE__, ": Unmatched [] in regexp\n";
10209             }
10210             if ($char[$i] eq ']') {
10211 0 0       0 my $right = $i;
10212 0         0  
  0         0  
10213             # [^...]
10214             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
10215 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Esjis::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
10216             }
10217             else {
10218 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10219 0         0 }
10220              
10221             $i = $left;
10222             last;
10223             }
10224             }
10225             }
10226 0         0  
10227             # rewrite character class or escape character
10228             elsif (my $char = character_class($char[$i],$modifier)) {
10229             $char[$i] = $char;
10230             }
10231 11 50       27  
10232 11         22 # /i modifier
10233             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Esjis::uc($char[$i]) ne Esjis::fc($char[$i]))) {
10234             if (CORE::length(Esjis::fc($char[$i])) == 1) {
10235 11         28 $char[$i] = '[' . Esjis::uc($char[$i]) . Esjis::fc($char[$i]) . ']';
10236             }
10237             else {
10238             $char[$i] = '(?:' . Esjis::uc($char[$i]) . '|' . Esjis::fc($char[$i]) . ')';
10239             }
10240             }
10241 0 50       0  
10242 8         27 # \u \l \U \L \F \Q \E
10243             elsif ($char[$i] =~ /\A [<>] \z/oxms) {
10244             if ($right_e < $left_e) {
10245             $char[$i] = '\\' . $char[$i];
10246 0         0 }
10247 0         0 }
10248             elsif ($char[$i] eq '\u') {
10249             $char[$i] = '@{[Esjis::ucfirst qq<';
10250 0         0 $left_e++;
10251 0         0 }
10252             elsif ($char[$i] eq '\l') {
10253             $char[$i] = '@{[Esjis::lcfirst qq<';
10254 0         0 $left_e++;
10255 0         0 }
10256             elsif ($char[$i] eq '\U') {
10257             $char[$i] = '@{[Esjis::uc qq<';
10258 0         0 $left_e++;
10259 0         0 }
10260             elsif ($char[$i] eq '\L') {
10261             $char[$i] = '@{[Esjis::lc qq<';
10262 0         0 $left_e++;
10263 0         0 }
10264             elsif ($char[$i] eq '\F') {
10265             $char[$i] = '@{[Esjis::fc qq<';
10266 0         0 $left_e++;
10267 7         14 }
10268             elsif ($char[$i] eq '\Q') {
10269             $char[$i] = '@{[CORE::quotemeta qq<';
10270 7 50       19 $left_e++;
10271 7         19 }
10272 7         15 elsif ($char[$i] eq '\E') {
10273             if ($right_e < $left_e) {
10274             $char[$i] = '>]}';
10275 7         18 $right_e++;
10276             }
10277             else {
10278             $char[$i] = '';
10279 0         0 }
10280 0 0       0 }
10281 0         0 elsif ($char[$i] eq '\Q') {
10282             while (1) {
10283 0 0       0 if (++$i > $#char) {
10284 0         0 last;
10285             }
10286             if ($char[$i] eq '\E') {
10287             last;
10288             }
10289             }
10290             }
10291             elsif ($char[$i] eq '\E') {
10292             }
10293              
10294             # \0 --> \0
10295             elsif ($char[$i] =~ /\A \\ (?>\s*) 0 \z/oxms) {
10296             }
10297              
10298             # \g{N}, \g{-N}
10299              
10300             # P.108 Using Simple Patterns
10301             # in Chapter 7: In the World of Regular Expressions
10302             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
10303              
10304             # P.221 Capturing
10305             # in Chapter 5: Pattern Matching
10306             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10307              
10308             # \g{-1}, \g{-2}, \g{-3} --> \g{-1}, \g{-2}, \g{-3}
10309             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) - (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10310             }
10311 0 0       0  
10312 0         0 # \g{1}, \g{2}, \g{3} --> \g{2}, \g{3}, \g{4} (only when multibyte anchoring is enable)
10313             elsif ($char[$i] =~ /\A \\g (?>\s*) \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10314             if ($1 <= $parens) {
10315             $char[$i] = '\\g{' . ($1 + 1) . '}';
10316             }
10317             }
10318 0 0       0  
10319 0         0 # \g1, \g2, \g3 --> \g2, \g3, \g4 (only when multibyte anchoring is enable)
10320             elsif ($char[$i] =~ /\A \\g (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
10321             if ($1 <= $parens) {
10322             $char[$i] = '\\g' . ($1 + 1);
10323             }
10324             }
10325 0 0       0  
10326 0         0 # \1, \2, \3 --> \2, \3, \4 (only when multibyte anchoring is enable)
10327             elsif ($char[$i] =~ /\A \\ (?>\s*) ((?>[1-9][0-9]*)) \z/oxms) {
10328             if ($1 <= $parens) {
10329             $char[$i] = '\\' . ($1 + 1);
10330             }
10331             }
10332 0 0       0  
10333 0         0 # $0 --> $0
10334             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
10335             if ($ignorecase) {
10336             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10337 0 0       0 }
10338 0         0 }
10339             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
10340             if ($ignorecase) {
10341             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10342             }
10343             }
10344              
10345             # $$ --> $$
10346             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
10347             }
10348              
10349 0         0 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
10350 0 0       0 # $1, $2, $3 --> $1, $2, $3 otherwise
10351 0         0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
10352             $char[$i] = e_capture($1);
10353             if ($ignorecase) {
10354             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10355 0         0 }
10356 0 0       0 }
10357 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
10358             $char[$i] = e_capture($1);
10359             if ($ignorecase) {
10360             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10361             }
10362             }
10363 0         0  
10364 0 0       0 # $$foo[ ... ] --> $ $foo->[ ... ]
10365 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
10366             $char[$i] = e_capture($1.'->'.$2);
10367             if ($ignorecase) {
10368             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10369             }
10370             }
10371 0         0  
10372 0 0       0 # $$foo{ ... } --> $ $foo->{ ... }
10373 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
10374             $char[$i] = e_capture($1.'->'.$2);
10375             if ($ignorecase) {
10376             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10377             }
10378             }
10379 0         0  
10380 0 0       0 # $$foo
10381 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
10382             $char[$i] = e_capture($1);
10383             if ($ignorecase) {
10384             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10385             }
10386             }
10387 0 50       0  
10388 4         16 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Esjis::PREMATCH()
10389             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
10390             if ($ignorecase) {
10391 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::PREMATCH())]}';
10392             }
10393             else {
10394             $char[$i] = '@{[Esjis::PREMATCH()]}';
10395             }
10396             }
10397 4 50       19  
10398 4         16 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Esjis::MATCH()
10399             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
10400             if ($ignorecase) {
10401 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::MATCH())]}';
10402             }
10403             else {
10404             $char[$i] = '@{[Esjis::MATCH()]}';
10405             }
10406             }
10407 4 50       17  
10408 3         12 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Esjis::POSTMATCH()
10409             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
10410             if ($ignorecase) {
10411 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::POSTMATCH())]}';
10412             }
10413             else {
10414             $char[$i] = '@{[Esjis::POSTMATCH()]}';
10415             }
10416             }
10417 3 0       13  
10418 0         0 # ${ foo }
10419             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
10420             if ($ignorecase) {
10421             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10422             }
10423             }
10424 0         0  
10425 0 0       0 # ${ ... }
10426 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
10427             $char[$i] = e_capture($1);
10428             if ($ignorecase) {
10429             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10430             }
10431             }
10432 0         0  
10433 13 50       44 # $scalar or @array
10434 13         68 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
10435             $char[$i] = e_string($char[$i]);
10436             if ($ignorecase) {
10437             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
10438             }
10439             }
10440 0 50       0  
10441             # quote character before ? + * {
10442             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10443 23         135 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
10444             }
10445             else {
10446             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10447             }
10448             }
10449 23         132 }
10450 143         337  
10451 143         364 # make regexp string
10452 143 50       253 my $prematch = '';
10453 143         377 $prematch = "($anchor)";
10454             $modifier =~ tr/i//d;
10455 0         0 if ($left_e > $right_e) {
10456             return join '', $ope, $delimiter, $prematch, '(?:', @char, '>]}' x ($left_e - $right_e), ')', $matched, $end_delimiter, $modifier;
10457             }
10458             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10459             }
10460              
10461             #
10462 143     96 0 1688 # escape regexp (s'here'' or s'here''b)
10463 96   100     220 #
10464             sub e_s1_q {
10465 96         243 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10466 96 50       132 $modifier ||= '';
10467 96         190  
10468 0         0 $modifier =~ tr/p//d;
10469 0 0       0 if ($modifier =~ /([adlu])/oxms) {
10470 0         0 my $line = 0;
10471 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10472             if ($filename ne __FILE__) {
10473             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10474 0         0 last;
10475             }
10476             }
10477 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
10478             }
10479              
10480 96 100       139 $slash = 'div';
    100          
10481 96         210  
10482 8         14 # literal null string pattern
10483 8         12 if ($string eq '') {
10484             $modifier =~ tr/bB//d;
10485             $modifier =~ tr/i//d;
10486             return join '', $ope, $delimiter, $end_delimiter, $modifier;
10487             }
10488 8         68  
10489             # with /b /B modifier
10490             elsif ($modifier =~ tr/bB//d) {
10491             return e_s1_qb($ope,$delimiter,$end_delimiter,$string,$modifier);
10492             }
10493 44         85  
10494             # without /b /B modifier
10495             else {
10496             return e_s1_qt($ope,$delimiter,$end_delimiter,$string,$modifier);
10497             }
10498             }
10499              
10500             #
10501 44     44 0 97 # escape regexp (s'here'')
10502             #
10503 44 100       97 sub e_s1_qt {
10504             my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10505              
10506 44         83 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10507              
10508             # split regexp
10509             my @char = $string =~ /\G((?>
10510             [^\x81-\x9F\xE0-\xFC\\\[\$\@\/] |
10511             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
10512             \[\^ |
10513             \[\: (?>[a-z]+) \:\] |
10514             \[\:\^ (?>[a-z]+) \:\] |
10515             [\$\@\/] |
10516             \\ (?:$q_char) |
10517             (?:$q_char)
10518 44         513 ))/oxmsg;
10519 44 50 100     122  
    50 100        
    50 66        
    50          
    100          
    100          
    50          
10520             # unescape character
10521             for (my $i=0; $i <= $#char; $i++) {
10522             if (0) {
10523 62         565 }
10524 0         0  
10525             # escape last octet of multiple-octet
10526             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10527             $char[$i] = $1 . '\\' . $2;
10528             }
10529 0         0  
10530 0 0       0 # open character class [...]
10531 0         0 elsif ($char[$i] eq '[') {
10532             my $left = $i;
10533 0         0 if ($char[$i+1] eq ']') {
10534 0 0       0 $i++;
10535 0         0 }
10536             while (1) {
10537 0 0       0 if (++$i > $#char) {
10538 0         0 die __FILE__, ": Unmatched [] in regexp\n";
10539             }
10540             if ($char[$i] eq ']') {
10541 0         0 my $right = $i;
10542              
10543 0         0 # [...]
10544 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_qr(@char[$left+1..$right-1], $modifier);
10545              
10546             $i = $left;
10547             last;
10548             }
10549             }
10550             }
10551 0         0  
10552 0 0       0 # open character class [^...]
10553 0         0 elsif ($char[$i] eq '[^') {
10554             my $left = $i;
10555 0         0 if ($char[$i+1] eq ']') {
10556 0 0       0 $i++;
10557 0         0 }
10558             while (1) {
10559 0 0       0 if (++$i > $#char) {
10560 0         0 die __FILE__, ": Unmatched [] in regexp\n";
10561             }
10562             if ($char[$i] eq ']') {
10563 0         0 my $right = $i;
10564              
10565 0         0 # [^...]
10566 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_not_qr(@char[$left+1..$right-1], $modifier);
10567              
10568             $i = $left;
10569             last;
10570             }
10571             }
10572             }
10573 0         0  
10574             # escape $ @ / and \
10575             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10576             $char[$i] = '\\' . $char[$i];
10577             }
10578 0         0  
10579             # rewrite character class or escape character
10580             elsif (my $char = character_class($char[$i],$modifier)) {
10581             $char[$i] = $char;
10582             }
10583 6 50       15  
10584 8         22 # /i modifier
10585             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Esjis::uc($char[$i]) ne Esjis::fc($char[$i]))) {
10586             if (CORE::length(Esjis::fc($char[$i])) == 1) {
10587 8         19 $char[$i] = '[' . Esjis::uc($char[$i]) . Esjis::fc($char[$i]) . ']';
10588             }
10589             else {
10590             $char[$i] = '(?:' . Esjis::uc($char[$i]) . '|' . Esjis::fc($char[$i]) . ')';
10591             }
10592             }
10593 0 0       0  
10594             # quote character before ? + * {
10595             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
10596 0         0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
10597             }
10598             else {
10599             $char[$i-1] = '(?:' . $char[$i-1] . ')';
10600             }
10601 0         0 }
10602 44         85 }
10603 44         68  
10604 44         50 $modifier =~ tr/i//d;
10605 44         57 $delimiter = '/';
10606 44         74 $end_delimiter = '/';
10607             my $prematch = '';
10608             $prematch = "($anchor)";
10609             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10610             }
10611              
10612             #
10613 44     44 0 314 # escape regexp (s'here''b)
10614             #
10615             sub e_s1_qb {
10616 44         102 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10617              
10618             # split regexp
10619 44         163 my @char = $string =~ /\G (?>[^\\]|\\\\|[\x00-\xFF]) /oxmsg;
10620 44 50       104  
    50          
10621             # unescape character
10622             for (my $i=0; $i <= $#char; $i++) {
10623             if (0) {
10624 98         294 }
10625              
10626             # remain \\
10627             elsif ($char[$i] eq '\\\\') {
10628             }
10629 0         0  
10630             # escape $ @ / and \
10631             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10632             $char[$i] = '\\' . $char[$i];
10633 0         0 }
10634 44         62 }
10635 44         51  
10636 44         56 $delimiter = '/';
10637 44         51 $end_delimiter = '/';
10638             my $prematch = '';
10639             $prematch = q{(\G[\x00-\xFF]*?)};
10640             return join '', $ope, $delimiter, $prematch, '(?:', @char, ')', $matched, $end_delimiter, $modifier;
10641             }
10642              
10643             #
10644 44     91 0 297 # escape regexp (s''here')
10645             #
10646 91         168 sub e_s2_q {
10647             my($ope,$delimiter,$end_delimiter,$string) = @_;
10648 91         117  
10649 91         358 $slash = 'div';
10650 91 50 66     216  
    50 33        
    100          
    100          
10651             my @char = $string =~ / \G (?>[^\x81-\x9F\xE0-\xFC\\]|\\\\|$q_char) /oxmsg;
10652             for (my $i=0; $i <= $#char; $i++) {
10653             if (0) {
10654 9         104 }
10655 0         0  
10656             # escape last octet of multiple-octet
10657             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) (\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
10658 0         0 $char[$i] = $1 . '\\' . $2;
10659             }
10660             elsif (defined($char[$i+1]) and ($char[$i+1] eq '\\') and ($char[$i] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10661             $char[$i] = $1 . '\\' . $2;
10662             }
10663              
10664             # not escape \\
10665             elsif ($char[$i] =~ /\A \\\\ \z/oxms) {
10666             }
10667 0         0  
10668             # escape $ @ / and \
10669             elsif ($char[$i] =~ /\A [\$\@\/\\] \z/oxms) {
10670 5 50 66     21 $char[$i] = '\\' . $char[$i];
10671 91         209 }
10672             }
10673             if (defined($char[-1]) and ($char[-1] =~ /\A ([\x80-\xFF].*) (\\) \z/xms)) {
10674 0         0 $char[-1] = $1 . '\\' . $2;
10675             }
10676              
10677             return join '', $ope, $delimiter, @char, $end_delimiter;
10678             }
10679              
10680             #
10681 91     291 0 267 # escape regexp (s/here/and here/modifier)
10682 291   100     2248 #
10683             sub e_sub {
10684 291         1180 my($variable,$delimiter1,$pattern,$end_delimiter1,$delimiter2,$replacement,$end_delimiter2,$modifier) = @_;
10685 291 50       557 $modifier ||= '';
10686 291         950  
10687 0         0 $modifier =~ tr/p//d;
10688 0 0       0 if ($modifier =~ /([adlu])/oxms) {
10689 0         0 my $line = 0;
10690 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10691             if ($filename ne __FILE__) {
10692             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10693 0         0 last;
10694             }
10695             }
10696 0 100       0 die qq{Unsupported modifier "$1" used at line $line.\n};
10697 291         866 }
10698 37         55  
10699             if ($variable eq '') {
10700             $variable = '$_';
10701 37         54 $bind_operator = ' =~ ';
10702             }
10703              
10704             $slash = 'div';
10705              
10706             # P.128 Start of match (or end of previous match): \G
10707             # P.130 Advanced Use of \G with Perl
10708             # in Chapter 3: Overview of Regular Expression Features and Flavors
10709             # P.312 Iterative Matching: Scalar Context, with /g
10710             # in Chapter 7: Perl
10711             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
10712              
10713             # P.181 Where You Left Off: The \G Assertion
10714             # in Chapter 5: Pattern Matching
10715             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
10716              
10717             # P.220 Where You Left Off: The \G Assertion
10718 291         525 # in Chapter 5: Pattern Matching
10719 291         536 # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
10720              
10721 291         504 my $e_modifier = $modifier =~ tr/e//d;
10722 291 50       437 my $r_modifier = $modifier =~ tr/r//d;
10723 291         868  
10724 0         0 my $my = '';
10725 0         0 if ($variable =~ s/\A \( (?>\s*) ( (?>(?: local \b | my \b | our \b | state \b )?) .+ ) \) \z/$1/oxms) {
10726             $my = $variable;
10727             $variable =~ s/ (?: local \b | my \b | our \b | state \b ) (?>\s*) //oxms;
10728 0         0 $variable =~ s/ = .+ \z//oxms;
10729 291         689 }
10730              
10731             (my $variable_basename = $variable) =~ s/ [\[\{].* \z//oxms;
10732 291         584 $variable_basename =~ s/ \s+ \z//oxms;
10733 291 100       424  
10734 291         640 # quote replacement string
10735 17         42 my $e_replacement = '';
10736             if ($e_modifier >= 1) {
10737             $e_replacement = e_qq('', '', '', $replacement);
10738 17 100       28 $e_modifier--;
10739 274         547 }
10740             else {
10741             if ($delimiter2 eq "'") {
10742 91         260 $e_replacement = e_s2_q('qq', '/', '/', $replacement);
10743             }
10744             else {
10745             $e_replacement = e_qq ('qq', $delimiter2, $end_delimiter2, $replacement);
10746 183         511 }
10747             }
10748              
10749 291 100       529 my $sub = '';
10750 291 100       610  
    50          
10751             # with /r
10752             if ($r_modifier) {
10753             if (0) {
10754 8         18 }
10755 0 50       0  
10756             # s///gr with multibyte anchoring
10757             elsif ($modifier =~ /g/oxms) {
10758             $sub = sprintf(
10759             # 1 2 3 4 5
10760             q,
10761              
10762             $variable, # 1
10763             ($delimiter1 eq "'") ? # 2
10764             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10765             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10766             $s_matched, # 3
10767             $e_replacement, # 4
10768             '$Esjis::re_r=CORE::eval $Esjis::re_r; ' x $e_modifier, # 5
10769             );
10770             }
10771 4 0       14  
10772             # s///gr without multibyte anchoring
10773             elsif ($modifier =~ /g/oxms) {
10774             $sub = sprintf(
10775             # 1 2 3 4 5
10776             q,
10777              
10778             $variable, # 1
10779             ($delimiter1 eq "'") ? # 2
10780             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10781             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10782             $s_matched, # 3
10783             $e_replacement, # 4
10784             '$Esjis::re_r=CORE::eval $Esjis::re_r; ' x $e_modifier, # 5
10785             );
10786             }
10787              
10788 0         0 # s///r
10789 4         6 else {
10790              
10791 4 50       4 my $prematch = q{$`};
10792             $prematch = q{${1}};
10793              
10794             $sub = sprintf(
10795             # 1 2 3 4 5 6 7
10796             q<(%s =~ %s) ? CORE::eval{%s local $^W=0; local $Esjis::re_r=%s; %s"%s$Esjis::re_r$'" } : %s>,
10797              
10798             $variable, # 1
10799             ($delimiter1 eq "'") ? # 2
10800             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10801             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10802             $s_matched, # 3
10803             $e_replacement, # 4
10804             '$Esjis::re_r=CORE::eval $Esjis::re_r; ' x $e_modifier, # 5
10805             $prematch, # 6
10806             $variable, # 7
10807             );
10808 4 50       11 }
10809 8         22  
10810             # $var !~ s///r doesn't make sense
10811             if ($bind_operator =~ / !~ /oxms) {
10812             $sub = q{die("$0: Using !~ with s///r doesn't make sense"), } . $sub;
10813             }
10814             }
10815 0 100       0  
    50          
10816             # without /r
10817             else {
10818             if (0) {
10819 283         827 }
10820 0 100       0  
    100          
10821             # s///g with multibyte anchoring
10822             elsif ($modifier =~ /g/oxms) {
10823             $sub = sprintf(
10824             # 1 2 3 4 5 6 7 8 9 10
10825             q,
10826              
10827             $variable, # 1
10828             ($delimiter1 eq "'") ? # 2
10829             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10830             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10831             $s_matched, # 3
10832             $e_replacement, # 4
10833             '$Esjis::re_r=CORE::eval $Esjis::re_r; ' x $e_modifier, # 5
10834             $variable, # 6
10835             $variable, # 7
10836             $variable, # 8
10837             $variable, # 9
10838              
10839             # Binary "!~" is just like "=~" except the return value is negated in the logical sense.
10840             # It returns false if the match succeeds, and true if it fails.
10841             # (and so on)
10842              
10843             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 10
10844             );
10845             }
10846 36 0       218  
    0          
10847             # s///g without multibyte anchoring
10848             elsif ($modifier =~ /g/oxms) {
10849             $sub = sprintf(
10850             # 1 2 3 4 5 6 7 8
10851             q,
10852              
10853             $variable, # 1
10854             ($delimiter1 eq "'") ? # 2
10855             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10856             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10857             $s_matched, # 3
10858             $e_replacement, # 4
10859             '$Esjis::re_r=CORE::eval $Esjis::re_r; ' x $e_modifier, # 5
10860             $variable, # 6
10861             $variable, # 7
10862             ($bind_operator =~ / !~ /oxms) ? '!' : '', # 8
10863             );
10864             }
10865              
10866 0         0 # s///
10867 247         365 else {
10868              
10869 247 100       345 my $prematch = q{$`};
    100          
10870             $prematch = q{${1}};
10871              
10872             $sub = sprintf(
10873              
10874             ($bind_operator =~ / =~ /oxms) ?
10875              
10876             # 1 2 3 4 5 6 7 8
10877             q<(%s%s%s) ? CORE::eval{%s local $^W=0; local $Esjis::re_r=%s; %s%s="%s$Esjis::re_r$'"; 1 } : undef> :
10878              
10879             # 1 2 3 4 5 6 7 8
10880             q<(%s%s%s) ? 1 : CORE::eval{%s local $^W=0; local $Esjis::re_r=%s; %s%s="%s$Esjis::re_r$'"; undef }>,
10881              
10882             $variable, # 1
10883             $bind_operator, # 2
10884             ($delimiter1 eq "'") ? # 3
10885             e_s1_q('m', $delimiter1, $end_delimiter1, $pattern, $modifier) : # :
10886             e_s1 ('m', $delimiter1, $end_delimiter1, $pattern, $modifier), # :
10887             $s_matched, # 4
10888             $e_replacement, # 5
10889             '$Esjis::re_r=CORE::eval $Esjis::re_r; ' x $e_modifier, # 6
10890             $variable, # 7
10891             $prematch, # 8
10892             );
10893             }
10894 247 50       1248 }
10895 291         807  
10896             # (my $foo = $bar) =~ s/// --> (my $foo = $bar, CORE::eval { ... })[1]
10897             if ($my ne '') {
10898             $sub = "($my, $sub)[1]";
10899 0         0 }
10900 291         432  
10901             # clear s/// variable
10902 291         371 $sub_variable = '';
10903             $bind_operator = '';
10904              
10905             return $sub;
10906             }
10907              
10908             #
10909 291     0 0 2226 # escape chdir (qq//, "")
10910             #
10911 0 0       0 sub e_chdir {
10912 0 0       0 my($ope,$delimiter,$end_delimiter,$string) = @_;
10913 0 0       0  
10914 0         0 if ($^W) {
10915 0         0 if (Esjis::_MSWin32_5Cended_path($string)) {
10916             if ($] !~ /^5\.005/oxms) {
10917             warn <
10918             @{[__FILE__]}: Can't chdir to '$string'
10919              
10920             chdir does not work with chr(0x5C) at end of path
10921             http://bugs.activestate.com/show_bug.cgi?id=81839
10922             END
10923             }
10924 0         0 }
10925             }
10926              
10927             return e_qq($ope,$delimiter,$end_delimiter,$string);
10928             }
10929              
10930             #
10931 0     2 0 0 # escape chdir (q//, '')
10932             #
10933 2 50       7 sub e_chdir_q {
10934 2 0       10 my($ope,$delimiter,$end_delimiter,$string) = @_;
10935 0 0       0  
10936 0         0 if ($^W) {
10937 0         0 if (Esjis::_MSWin32_5Cended_path($string)) {
10938             if ($] !~ /^5\.005/oxms) {
10939             warn <
10940             @{[__FILE__]}: Can't chdir to '$string'
10941              
10942             chdir does not work with chr(0x5C) at end of path
10943             http://bugs.activestate.com/show_bug.cgi?id=81839
10944             END
10945             }
10946 0         0 }
10947             }
10948              
10949             return e_q($ope,$delimiter,$end_delimiter,$string);
10950             }
10951              
10952             #
10953 2     273 0 7 # escape regexp of split qr//
10954 273   100     1412 #
10955             sub e_split {
10956 273         1069 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
10957 273 50       572 $modifier ||= '';
10958 273         780  
10959 0         0 $modifier =~ tr/p//d;
10960 0 0       0 if ($modifier =~ /([adlu])/oxms) {
10961 0         0 my $line = 0;
10962 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
10963             if ($filename ne __FILE__) {
10964             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
10965 0         0 last;
10966             }
10967             }
10968 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
10969             }
10970              
10971 273 100       472 $slash = 'div';
10972 273         701  
10973             # /b /B modifier
10974             if ($modifier =~ tr/bB//d) {
10975 84 100       450 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
10976 189         668 }
10977              
10978             my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
10979 189         707 my $metachar = qr/[\@\\|[\]{^]/oxms;
10980              
10981             # split regexp
10982             my @char = $string =~ /\G((?>
10983             [^\x81-\x9F\xE0-\xFC\\\$\@\[\(]|[\x81-\x9F\xE0-\xFC][\x00-\xFF] |
10984             \\x (?>[0-9A-Fa-f]{1,2}) |
10985             \\ (?>[0-7]{2,3}) |
10986             \\c [\x40-\x5F] |
10987             \\x\{ (?>[0-9A-Fa-f]+) \} |
10988             \\o\{ (?>[0-7]+) \} |
10989             \\[bBNpP]\{ (?>[^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} |
10990             \\ $q_char |
10991             \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} |
10992             \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} |
10993             \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} |
10994             [\$\@] $qq_variable |
10995             \$ (?>\s* [0-9]+) |
10996             \$ (?>\s*) \{ (?>\s* [0-9]+ \s*) \} |
10997             \$ \$ (?![\w\{]) |
10998             \$ (?>\s*) \$ (?>\s*) $qq_variable |
10999             \[\^ |
11000             \[\: (?>[a-z]+) :\] |
11001             \[\:\^ (?>[a-z]+) :\] |
11002             \(\? |
11003 189         18050 $q_char
11004 189         626 ))/oxmsg;
11005 189         281  
11006             my $left_e = 0;
11007             my $right_e = 0;
11008 189 50 33     563 for (my $i=0; $i <= $#char; $i++) {
    50 33        
    100          
    100          
    50          
    50          
11009 372         2393  
11010             # "\L\u" --> "\u\L"
11011             if (($char[$i] eq '\L') and ($char[$i+1] eq '\u')) {
11012             @char[$i,$i+1] = @char[$i+1,$i];
11013             }
11014 0         0  
11015             # "\U\l" --> "\l\U"
11016             elsif (($char[$i] eq '\U') and ($char[$i+1] eq '\l')) {
11017             @char[$i,$i+1] = @char[$i+1,$i];
11018             }
11019 0         0  
11020             # octal escape sequence
11021             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
11022             $char[$i] = Esjis::octchr($1);
11023             }
11024 1         4  
11025             # hexadecimal escape sequence
11026             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
11027             $char[$i] = Esjis::hexchr($1);
11028             }
11029              
11030             # \b{...} --> b\{...}
11031             # \B{...} --> B\{...}
11032             # \N{CHARNAME} --> N\{CHARNAME}
11033 1         4 # \p{PROPERTY} --> p\{PROPERTY}
11034             # \P{PROPERTY} --> P\{PROPERTY}
11035             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\x9F\xE0-\xFC0-9\}][^\x81-\x9F\xE0-\xFC\}]*) \} ) \z/oxms) {
11036             $char[$i] = $1 . '\\' . $2;
11037             }
11038 0         0  
11039             # \p, \P, \X --> p, P, X
11040             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
11041 0 50 100     0 $char[$i] = $1;
    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          
11042             }
11043              
11044             if (0) {
11045 372         3902 }
11046 0         0  
11047             # escape last octet of multiple-octet
11048             elsif ($char[$i] =~ /\A \\? ([\x80-\xFF].*) ($metachar|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11049             $char[$i] = $1 . '\\' . $2;
11050             }
11051 0 0 0     0  
    0 0        
    0 0        
      0        
      0        
      0        
11052 0         0 # join separated multiple-octet
11053             elsif ($char[$i] =~ /\A (?: \\ [0-7]{2,3} | \\x [0-9A-Fa-f]{1,2}) \z/oxms) {
11054             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)) {
11055 0         0 $char[$i] .= join '', splice @char, $i+1, 3;
11056             }
11057             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)) {
11058 0         0 $char[$i] .= join '', splice @char, $i+1, 2;
11059             }
11060             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)) {
11061             $char[$i] .= join '', splice @char, $i+1, 1;
11062             }
11063             }
11064 0         0  
11065 3 50       7 # open character class [...]
11066 3         10 elsif ($char[$i] eq '[') {
11067             my $left = $i;
11068 0         0 if ($char[$i+1] eq ']') {
11069 3 50       5 $i++;
11070 7         14 }
11071             while (1) {
11072 0 100       0 if (++$i > $#char) {
11073 7         17 die __FILE__, ": Unmatched [] in regexp\n";
11074             }
11075             if ($char[$i] eq ']') {
11076 3 50       6 my $right = $i;
11077 3         20  
  0         0  
11078             # [...]
11079             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
11080 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Esjis::charlist_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
11081             }
11082             else {
11083 3         15 splice @char, $left, $right-$left+1, Esjis::charlist_qr(@char[$left+1..$right-1], $modifier);
11084 3         14 }
11085              
11086             $i = $left;
11087             last;
11088             }
11089             }
11090             }
11091 3         13  
11092 1 50       3 # open character class [^...]
11093 1         5 elsif ($char[$i] eq '[^') {
11094             my $left = $i;
11095 0         0 if ($char[$i+1] eq ']') {
11096 1 50       2 $i++;
11097 2         6 }
11098             while (1) {
11099 0 100       0 if (++$i > $#char) {
11100 2         5 die __FILE__, ": Unmatched [] in regexp\n";
11101             }
11102             if ($char[$i] eq ']') {
11103 1 50       2 my $right = $i;
11104 1         12  
  0         0  
11105             # [^...]
11106             if (grep(/\A [\$\@]/oxms,@char[$left+1..$right-1]) >= 1) {
11107 0         0 splice @char, $left, $right-$left+1, sprintf(q{@{[Esjis::charlist_not_qr(%s,'%s')]}}, join(',', map {qq_stuff($delimiter,$end_delimiter,$_)} @char[$left+1..$right-1]), $modifier);
11108             }
11109             else {
11110 1         7 splice @char, $left, $right-$left+1, Esjis::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11111 1         3 }
11112              
11113             $i = $left;
11114             last;
11115             }
11116             }
11117             }
11118 1         4  
11119             # rewrite character class or escape character
11120             elsif (my $char = character_class($char[$i],$modifier)) {
11121             $char[$i] = $char;
11122             }
11123              
11124             # P.794 29.2.161. split
11125             # in Chapter 29: Functions
11126             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11127              
11128             # P.951 split
11129             # in Chapter 27: Functions
11130             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11131              
11132             # said "The //m modifier is assumed when you split on the pattern /^/",
11133             # but perl5.008 is not so. Therefore, this software adds //m.
11134             # (and so on)
11135 5         15  
11136             # split(m/^/) --> split(m/^/m)
11137             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11138             $modifier .= 'm';
11139             }
11140 11 50       48  
11141 18         44 # /i modifier
11142             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Esjis::uc($char[$i]) ne Esjis::fc($char[$i]))) {
11143             if (CORE::length(Esjis::fc($char[$i])) == 1) {
11144 18         51 $char[$i] = '[' . Esjis::uc($char[$i]) . Esjis::fc($char[$i]) . ']';
11145             }
11146             else {
11147             $char[$i] = '(?:' . Esjis::uc($char[$i]) . '|' . Esjis::fc($char[$i]) . ')';
11148             }
11149             }
11150 0 50       0  
11151 2         32 # \u \l \U \L \F \Q \E
11152             elsif ($char[$i] =~ /\A ([<>]) \z/oxms) {
11153             if ($right_e < $left_e) {
11154             $char[$i] = '\\' . $char[$i];
11155 0         0 }
11156 0         0 }
11157             elsif ($char[$i] eq '\u') {
11158             $char[$i] = '@{[Esjis::ucfirst qq<';
11159 0         0 $left_e++;
11160 0         0 }
11161             elsif ($char[$i] eq '\l') {
11162             $char[$i] = '@{[Esjis::lcfirst qq<';
11163 0         0 $left_e++;
11164 0         0 }
11165             elsif ($char[$i] eq '\U') {
11166             $char[$i] = '@{[Esjis::uc qq<';
11167 0         0 $left_e++;
11168 0         0 }
11169             elsif ($char[$i] eq '\L') {
11170             $char[$i] = '@{[Esjis::lc qq<';
11171 0         0 $left_e++;
11172 0         0 }
11173             elsif ($char[$i] eq '\F') {
11174             $char[$i] = '@{[Esjis::fc qq<';
11175 0         0 $left_e++;
11176 0         0 }
11177             elsif ($char[$i] eq '\Q') {
11178             $char[$i] = '@{[CORE::quotemeta qq<';
11179 0 0       0 $left_e++;
11180 0         0 }
11181 0         0 elsif ($char[$i] eq '\E') {
11182             if ($right_e < $left_e) {
11183             $char[$i] = '>]}';
11184 0         0 $right_e++;
11185             }
11186             else {
11187             $char[$i] = '';
11188 0         0 }
11189 0 0       0 }
11190 0         0 elsif ($char[$i] eq '\Q') {
11191             while (1) {
11192 0 0       0 if (++$i > $#char) {
11193 0         0 last;
11194             }
11195             if ($char[$i] eq '\E') {
11196             last;
11197             }
11198             }
11199             }
11200             elsif ($char[$i] eq '\E') {
11201             }
11202 0 0       0  
11203 0         0 # $0 --> $0
11204             elsif ($char[$i] =~ /\A \$ 0 \z/oxms) {
11205             if ($ignorecase) {
11206             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11207 0 0       0 }
11208 0         0 }
11209             elsif ($char[$i] =~ /\A \$ \{ (?>\s*) 0 (?>\s*) \} \z/oxms) {
11210             if ($ignorecase) {
11211             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11212             }
11213             }
11214              
11215             # $$ --> $$
11216             elsif ($char[$i] =~ /\A \$\$ \z/oxms) {
11217             }
11218              
11219 0         0 # $1, $2, $3 --> $2, $3, $4 after s/// with multibyte anchoring
11220 0 0       0 # $1, $2, $3 --> $1, $2, $3 otherwise
11221 0         0 elsif ($char[$i] =~ /\A \$ ((?>[1-9][0-9]*)) \z/oxms) {
11222             $char[$i] = e_capture($1);
11223             if ($ignorecase) {
11224             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11225 0         0 }
11226 0 0       0 }
11227 0         0 elsif ($char[$i] =~ /\A \$ \{ (?>\s*) ((?>[1-9][0-9]*)) (?>\s*) \} \z/oxms) {
11228             $char[$i] = e_capture($1);
11229             if ($ignorecase) {
11230             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11231             }
11232             }
11233 0         0  
11234 0 0       0 # $$foo[ ... ] --> $ $foo->[ ... ]
11235 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \[ (?:$qq_bracket)*? \] ) \z/oxms) {
11236             $char[$i] = e_capture($1.'->'.$2);
11237             if ($ignorecase) {
11238             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11239             }
11240             }
11241 0         0  
11242 0 0       0 # $$foo{ ... } --> $ $foo->{ ... }
11243 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) ( \{ (?:$qq_brace)*? \} ) \z/oxms) {
11244             $char[$i] = e_capture($1.'->'.$2);
11245             if ($ignorecase) {
11246             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11247             }
11248             }
11249 0         0  
11250 0 0       0 # $$foo
11251 0         0 elsif ($char[$i] =~ /\A \$ ((?> \$ [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* )) \z/oxms) {
11252             $char[$i] = e_capture($1);
11253             if ($ignorecase) {
11254             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11255             }
11256             }
11257 0 50       0  
11258 12         49 # $`, ${`}, $PREMATCH, ${PREMATCH}, ${^PREMATCH} --> Esjis::PREMATCH()
11259             elsif ($char[$i] =~ /\A ( \$` | \$\{`\} | \$ (?>\s*) PREMATCH | \$ (?>\s*) \{ (?>\s*) PREMATCH (?>\s*) \} | \$ (?>\s*) \{\^PREMATCH\} ) \z/oxmsgc) {
11260             if ($ignorecase) {
11261 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::PREMATCH())]}';
11262             }
11263             else {
11264             $char[$i] = '@{[Esjis::PREMATCH()]}';
11265             }
11266             }
11267 12 50       70  
11268 12         38 # $&, ${&}, $MATCH, ${MATCH}, ${^MATCH} --> Esjis::MATCH()
11269             elsif ($char[$i] =~ /\A ( \$& | \$\{&\} | \$ (?>\s*) MATCH | \$ (?>\s*) \{ (?>\s*) MATCH (?>\s*) \} | \$ (?>\s*) \{\^MATCH\} ) \z/oxmsgc) {
11270             if ($ignorecase) {
11271 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::MATCH())]}';
11272             }
11273             else {
11274             $char[$i] = '@{[Esjis::MATCH()]}';
11275             }
11276             }
11277 12 50       61  
11278 9         26 # $POSTMATCH, ${POSTMATCH}, ${^POSTMATCH} --> Esjis::POSTMATCH()
11279             elsif ($char[$i] =~ /\A ( \$ (?>\s*) POSTMATCH | \$ (?>\s*) \{ (?>\s*) POSTMATCH (?>\s*) \} | \$ (?>\s*) \{\^POSTMATCH\} ) \z/oxmsgc) {
11280             if ($ignorecase) {
11281 0         0 $char[$i] = '@{[Esjis::ignorecase(Esjis::POSTMATCH())]}';
11282             }
11283             else {
11284             $char[$i] = '@{[Esjis::POSTMATCH()]}';
11285             }
11286             }
11287 9 0       43  
11288 0         0 # ${ foo }
11289             elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ((?> \s* [A-Za-z_][A-Za-z0-9_]*(?: ::[A-Za-z_][A-Za-z0-9_]*)* \s* )) \} \z/oxms) {
11290             if ($ignorecase) {
11291             $char[$i] = '@{[Esjis::ignorecase(' . $1 . ')]}';
11292             }
11293             }
11294 0         0  
11295 0 0       0 # ${ ... }
11296 0         0 elsif ($char[$i] =~ /\A \$ (?>\s*) \{ ( .+ ) \} \z/oxms) {
11297             $char[$i] = e_capture($1);
11298             if ($ignorecase) {
11299             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11300             }
11301             }
11302 0         0  
11303 3 50       9 # $scalar or @array
11304 3         15 elsif ($char[$i] =~ /\A [\$\@].+ /oxms) {
11305             $char[$i] = e_string($char[$i]);
11306             if ($ignorecase) {
11307             $char[$i] = '@{[Esjis::ignorecase(' . $char[$i] . ')]}';
11308             }
11309             }
11310 0 100       0  
11311             # quote character before ? + * {
11312             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11313 7         41 if ($char[$i-1] =~ /\A (?:[\x00-\xFF]|\\[0-7]{2,3}|\\x[0-9-A-Fa-f]{1,2}) \z/oxms) {
11314             }
11315             else {
11316             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11317             }
11318             }
11319 4         21 }
11320 189 50       440  
11321 189         433 # make regexp string
11322             $modifier =~ tr/i//d;
11323 0         0 if ($left_e > $right_e) {
11324             return join '', 'Esjis::split', $ope, $delimiter, @char, '>]}' x ($left_e - $right_e), $end_delimiter, $modifier;
11325             }
11326             return join '', 'Esjis::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11327             }
11328              
11329             #
11330 189     112 0 1730 # escape regexp of split qr''
11331 112   100     498 #
11332             sub e_split_q {
11333 112         322 my($ope,$delimiter,$end_delimiter,$string,$modifier) = @_;
11334 112 50       204 $modifier ||= '';
11335 112         260  
11336 0         0 $modifier =~ tr/p//d;
11337 0 0       0 if ($modifier =~ /([adlu])/oxms) {
11338 0         0 my $line = 0;
11339 0         0 for (my $i=0; my($package,$filename,$use_line,$subroutine) = caller($i); $i++) {
11340             if ($filename ne __FILE__) {
11341             $line = $use_line + (CORE::substr($_,0,pos($_)) =~ tr/\n//) + 1;
11342 0         0 last;
11343             }
11344             }
11345 0         0 die qq{Unsupported modifier "$1" used at line $line.\n};
11346             }
11347              
11348 112 100       167 $slash = 'div';
11349 112         222  
11350             # /b /B modifier
11351             if ($modifier =~ tr/bB//d) {
11352 56 100       267 return join '', 'split', $ope, $delimiter, $string, $end_delimiter, $modifier;
11353             }
11354              
11355 56         124 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
11356              
11357             # split regexp
11358             my @char = $string =~ /\G((?>
11359             [^\x81-\x9F\xE0-\xFC\\\[] |
11360             [\x81-\x9F\xE0-\xFC][\x00-\xFF] |
11361             \[\^ |
11362             \[\: (?>[a-z]+) \:\] |
11363             \[\:\^ (?>[a-z]+) \:\] |
11364             \\ (?:$q_char) |
11365             (?:$q_char)
11366 56         296 ))/oxmsg;
11367 56 50 33     146  
    50 100        
    50 66        
    50 33        
    50          
    100          
    50          
11368             # unescape character
11369             for (my $i=0; $i <= $#char; $i++) {
11370             if (0) {
11371 56         437 }
11372 0         0  
11373             # escape last octet of multiple-octet
11374             elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ([\\|\[\{\^]|\Q$delimiter\E|\Q$end_delimiter\E) \z/xms) {
11375             $char[$i] = $1 . '\\' . $2;
11376             }
11377 0         0  
11378 0 0       0 # open character class [...]
11379 0         0 elsif ($char[$i] eq '[') {
11380             my $left = $i;
11381 0         0 if ($char[$i+1] eq ']') {
11382 0 0       0 $i++;
11383 0         0 }
11384             while (1) {
11385 0 0       0 if (++$i > $#char) {
11386 0         0 die __FILE__, ": Unmatched [] in regexp\n";
11387             }
11388             if ($char[$i] eq ']') {
11389 0         0 my $right = $i;
11390              
11391 0         0 # [...]
11392 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_qr(@char[$left+1..$right-1], $modifier);
11393              
11394             $i = $left;
11395             last;
11396             }
11397             }
11398             }
11399 0         0  
11400 0 0       0 # open character class [^...]
11401 0         0 elsif ($char[$i] eq '[^') {
11402             my $left = $i;
11403 0         0 if ($char[$i+1] eq ']') {
11404 0 0       0 $i++;
11405 0         0 }
11406             while (1) {
11407 0 0       0 if (++$i > $#char) {
11408 0         0 die __FILE__, ": Unmatched [] in regexp\n";
11409             }
11410             if ($char[$i] eq ']') {
11411 0         0 my $right = $i;
11412              
11413 0         0 # [^...]
11414 0         0 splice @char, $left, $right-$left+1, Esjis::charlist_not_qr(@char[$left+1..$right-1], $modifier);
11415              
11416             $i = $left;
11417             last;
11418             }
11419             }
11420             }
11421 0         0  
11422             # rewrite character class or escape character
11423             elsif (my $char = character_class($char[$i],$modifier)) {
11424             $char[$i] = $char;
11425             }
11426 0         0  
11427             # split(m/^/) --> split(m/^/m)
11428             elsif (($char[$i] eq '^') and ($modifier !~ /m/oxms)) {
11429             $modifier .= 'm';
11430             }
11431 0 50       0  
11432 12         33 # /i modifier
11433             elsif ($ignorecase and ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) and (Esjis::uc($char[$i]) ne Esjis::fc($char[$i]))) {
11434             if (CORE::length(Esjis::fc($char[$i])) == 1) {
11435 12         26 $char[$i] = '[' . Esjis::uc($char[$i]) . Esjis::fc($char[$i]) . ']';
11436             }
11437             else {
11438             $char[$i] = '(?:' . Esjis::uc($char[$i]) . '|' . Esjis::fc($char[$i]) . ')';
11439             }
11440             }
11441 0 0       0  
11442             # quote character before ? + * {
11443             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
11444 0         0 if ($char[$i-1] =~ /\A [\x00-\xFF] \z/oxms) {
11445             }
11446             else {
11447             $char[$i-1] = '(?:' . $char[$i-1] . ')';
11448             }
11449 0         0 }
11450 56         115 }
11451              
11452             $modifier =~ tr/i//d;
11453             return join '', 'Esjis::split', $ope, $delimiter, @char, $end_delimiter, $modifier;
11454             }
11455              
11456             #
11457 56     0 0 301 # escape use without import
11458             #
11459 0           sub e_use_noimport {
11460             my($module) = @_;
11461 0            
11462 0           my $expr = _pathof($module);
11463              
11464 0 0         my $fh = gensym();
11465 0           for my $realfilename (_realfilename($expr)) {
11466 0            
11467 0 0         if (Esjis::_open_r($fh, $realfilename)) {
11468             local $/ = undef; # slurp mode
11469 0 0         my $script = <$fh>;
11470 0           close($fh) or die "Can't close file: $realfilename: $!";
11471              
11472 0           if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
11473             return qq;
11474             }
11475             last;
11476 0           }
11477             }
11478              
11479             return qq;
11480             }
11481              
11482             #
11483 0     0 0   # escape no without unimport
11484             #
11485 0           sub e_no_nounimport {
11486             my($module) = @_;
11487 0            
11488 0           my $expr = _pathof($module);
11489              
11490 0 0         my $fh = gensym();
11491 0           for my $realfilename (_realfilename($expr)) {
11492 0            
11493 0 0         if (Esjis::_open_r($fh, $realfilename)) {
11494             local $/ = undef; # slurp mode
11495 0 0         my $script = <$fh>;
11496 0           close($fh) or die "Can't close file: $realfilename: $!";
11497              
11498 0           if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
11499             return qq;
11500             }
11501             last;
11502 0           }
11503             }
11504              
11505             return qq;
11506             }
11507              
11508             #
11509 0     0 0   # escape use with import no parameter
11510             #
11511 0           sub e_use_noparam {
11512             my($module) = @_;
11513 0            
11514 0           my $expr = _pathof($module);
11515              
11516 0 0         my $fh = gensym();
11517 0           for my $realfilename (_realfilename($expr)) {
11518 0            
11519 0 0         if (Esjis::_open_r($fh, $realfilename)) {
11520             local $/ = undef; # slurp mode
11521 0 0         my $script = <$fh>;
11522             close($fh) or die "Can't close file: $realfilename: $!";
11523              
11524             if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
11525              
11526             # P.326 UNIVERSAL: The Ultimate Ancestor Class
11527             # in Chapter 12: Objects
11528             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
11529              
11530             # P.435 UNIVERSAL: The Ultimate Ancestor Class
11531             # in Chapter 12: Objects
11532             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
11533 0            
11534             # (and so on)
11535 0            
11536             return qq[BEGIN { Esjis::require '$expr'; $module->import() if $module->can('import'); }];
11537             }
11538             last;
11539 0           }
11540             }
11541              
11542             return qq;
11543             }
11544              
11545             #
11546 0     0 0   # escape no with unimport no parameter
11547             #
11548 0           sub e_no_noparam {
11549             my($module) = @_;
11550 0            
11551 0           my $expr = _pathof($module);
11552              
11553 0 0         my $fh = gensym();
11554 0           for my $realfilename (_realfilename($expr)) {
11555 0            
11556 0 0         if (Esjis::_open_r($fh, $realfilename)) {
11557             local $/ = undef; # slurp mode
11558 0 0         my $script = <$fh>;
11559 0           close($fh) or die "Can't close file: $realfilename: $!";
11560              
11561 0           if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
11562             return qq[BEGIN { Esjis::require '$expr'; $module->unimport() if $module->can('unimport'); }];
11563             }
11564             last;
11565 0           }
11566             }
11567              
11568             return qq;
11569             }
11570              
11571             #
11572 0     0 0   # escape use with import parameters
11573             #
11574 0           sub e_use {
11575             my($module,$list) = @_;
11576 0            
11577 0           my $expr = _pathof($module);
11578              
11579 0 0         my $fh = gensym();
11580 0           for my $realfilename (_realfilename($expr)) {
11581 0            
11582 0 0         if (Esjis::_open_r($fh, $realfilename)) {
11583             local $/ = undef; # slurp mode
11584 0 0         my $script = <$fh>;
11585 0           close($fh) or die "Can't close file: $realfilename: $!";
11586              
11587 0           if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
11588             return qq[BEGIN { Esjis::require '$expr'; $module->import($list) if $module->can('import'); }];
11589             }
11590             last;
11591 0           }
11592             }
11593              
11594             return qq;
11595             }
11596              
11597             #
11598 0     0 0   # escape no with unimport parameters
11599             #
11600 0           sub e_no {
11601             my($module,$list) = @_;
11602 0            
11603 0           my $expr = _pathof($module);
11604              
11605 0 0         my $fh = gensym();
11606 0           for my $realfilename (_realfilename($expr)) {
11607 0            
11608 0 0         if (Esjis::_open_r($fh, $realfilename)) {
11609             local $/ = undef; # slurp mode
11610 0 0         my $script = <$fh>;
11611 0           close($fh) or die "Can't close file: $realfilename: $!";
11612              
11613 0           if ($script =~ /^ (?>\s*) use (?>\s+) Sjis (?>\s*) ([^\x81-\x9F\xE0-\xFC;]*) ; (?>\s*) \n? $/oxms) {
11614             return qq[BEGIN { Esjis::require '$expr'; $module->unimport($list) if $module->can('unimport'); }];
11615             }
11616             last;
11617 0           }
11618             }
11619              
11620             return qq;
11621             }
11622              
11623             #
11624 0     0     # file path of module
11625             #
11626 0 0         sub _pathof {
11627 0           my($expr) = @_;
11628              
11629             if ($^O eq 'MacOS') {
11630 0           $expr =~ s#::#:#g;
11631             }
11632 0 0         else {
11633             $expr =~ s#::#/#g;
11634 0           }
11635             $expr .= '.pm' if $expr !~ / \.pm \z/oxmsi;
11636              
11637             return $expr;
11638             }
11639              
11640             #
11641 0     0     # real file name of module
11642             #
11643 0 0         sub _realfilename {
11644 0           my($expr) = @_;
  0            
11645              
11646             if ($^O eq 'MacOS') {
11647 0           return map {"$_$expr"} @INC;
  0            
11648             }
11649             else {
11650             return map {"$_/$expr"} @INC;
11651             }
11652             }
11653              
11654             #
11655 0     0 0   # instead of Carp::carp
11656 0           #
11657             sub carp {
11658             my($package,$filename,$line) = caller(1);
11659             print STDERR "@_ at $filename line $line.\n";
11660             }
11661              
11662             #
11663 0     0 0   # instead of Carp::croak
11664 0           #
11665 0           sub croak {
11666             my($package,$filename,$line) = caller(1);
11667             print STDERR "@_ at $filename line $line.\n";
11668             die "\n";
11669             }
11670              
11671             #
11672 0     0 0   # instead of Carp::cluck
11673 0           #
11674 0           sub cluck {
11675 0           my $i = 0;
11676 0           my @cluck = ();
11677             while (my($package,$filename,$line,$subroutine) = caller($i)) {
11678 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
11679 0           $i++;
11680 0           }
11681             print STDERR CORE::reverse @cluck;
11682             print STDERR "\n";
11683             print STDERR @_;
11684             }
11685              
11686             #
11687 0     0 0   # instead of Carp::confess
11688 0           #
11689 0           sub confess {
11690 0           my $i = 0;
11691 0           my @confess = ();
11692             while (my($package,$filename,$line,$subroutine) = caller($i)) {
11693 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
11694 0           $i++;
11695 0           }
11696 0           print STDERR CORE::reverse @confess;
11697             print STDERR "\n";
11698             print STDERR @_;
11699             die "\n";
11700             }
11701              
11702             1;
11703              
11704             __END__