File Coverage

blib/lib/Egbk.pm
Criterion Covered Total %
statement 1213 4194 28.9
branch 1266 4236 29.8
condition 162 496 32.6
subroutine 71 196 36.2
pod 8 148 5.4
total 2720 9270 29.3


line stmt bran cond sub pod time code
1             package Egbk;
2 391     391   9577 use strict;
  391         2214  
  391         19159  
3 391 50   391   9437 BEGIN { $INC{'warnings.pm'} = '' if $] < 5.006 } use warnings;
  391     391   4818  
  391         2150  
  391         15863  
4             ######################################################################
5             #
6             # Egbk - Run-time routines for GBK.pm
7             #
8             # http://search.cpan.org/dist/Char-GBK/
9             #
10             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2019 INABA Hitoshi
11             ######################################################################
12              
13 391     391   7723 use 5.00503; # Galapagos Consensus 1998 for primetools
  391         1195  
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   5525 use vars qw($VERSION);
  391         2316  
  391         55169  
29             $VERSION = '1.22';
30             $VERSION = $VERSION;
31              
32             BEGIN {
33 391 50   391   7529 if ($^X =~ / jperl /oxmsi) {
34 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)\n";
35             }
36 391         620 if (CORE::ord('A') == 193) {
37             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).\n";
38             }
39 391         55228 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   26204 CORE::eval q{
  391     391   3730  
  391     126   2247  
  391         50011  
  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       147837 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       2813 if (ref $name) {
    50          
    50          
    50          
    50          
    50          
    50          
81 1158         4797 return $name;
82             }
83             elsif (Egbk::index($name,'::') >= 0) {
84 0         0 return $name;
85             }
86             elsif (Egbk::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         8899 return (caller)[0] . '::' . $name;
113             }
114             }
115              
116             sub qualify_to_ref ($;$) {
117 0 50   1158 0 0 if (defined $_[1]) {
118 391     391   4486 no strict qw(refs);
  391         742  
  391         28318  
119 1158         3421 return \*{ qualify $_[0], $_[1] };
  0         0  
120             }
121             else {
122 391     391   2399 no strict qw(refs);
  391     0   692  
  391         69636  
123 0         0 return \*{ qualify $_[0], (caller)[0] };
  1158         1749  
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-\xFE][\x00-\xFF]|[\x00-\xFF]};
154 391     391   4092 use vars qw($qq_char); $qq_char = qr/\\c[\x40-\x5F]|\\?(?:$your_char)/oxms;
  391         2218  
  391         32181  
155 391     391   3572 use vars qw($q_char); $q_char = qr/$your_char/oxms;
  391         2241  
  391         635659  
156              
157             #
158             # GBK character range per length
159             #
160             my %range_tr = ();
161              
162             #
163             # GBK 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 Egbk \z/oxms) {
179             %range_tr = (
180             1 => [ [0x00..0x80],
181             [0xFF..0xFF],
182             ],
183             2 => [ [0x81..0xFE],[0x40..0x7E],
184             [0x81..0xFE],[0x80..0xFE],
185             ],
186             );
187             }
188              
189             else {
190             croak "Don't know my package name '@{[__PACKAGE__]}'";
191             }
192              
193             #
194             # @ARGV wildcard globbing
195             #
196             sub import {
197              
198 1158 50   5   5987 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
199 5         87 my @argv = ();
200 0         0 for (@ARGV) {
201              
202             # has space
203 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
204 0 0       0 if (my @glob = Egbk::glob(qq{"$_"})) {
205 0         0 push @argv, @glob;
206             }
207             else {
208 0         0 push @argv, $_;
209             }
210             }
211              
212             # has wildcard metachar
213             elsif (/\A (?:$q_char)*? [*?] /oxms) {
214 0 0       0 if (my @glob = Egbk::glob($_)) {
215 0         0 push @argv, @glob;
216             }
217             else {
218 0         0 push @argv, $_;
219             }
220             }
221              
222             # no wildcard globbing
223             else {
224 0         0 push @argv, $_;
225             }
226             }
227 0         0 @ARGV = @argv;
228             }
229              
230 0         0 *Char::ord = \&GBK::ord;
231 5         27 *Char::ord_ = \&GBK::ord_;
232 5         15 *Char::reverse = \&GBK::reverse;
233 5         11 *Char::getc = \&GBK::getc;
234 5         9 *Char::length = \&GBK::length;
235 5         10 *Char::substr = \&GBK::substr;
236 5         127 *Char::index = \&GBK::index;
237 5         11 *Char::rindex = \&GBK::rindex;
238 5         10 *Char::eval = \&GBK::eval;
239 5         18 *Char::escape = \&GBK::escape;
240 5         10 *Char::escape_token = \&GBK::escape_token;
241 5         9 *Char::escape_script = \&GBK::escape_script;
242             }
243              
244             # P.230 Care with Prototypes
245             # in Chapter 6: Subroutines
246             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
247             #
248             # If you aren't careful, you can get yourself into trouble with prototypes.
249             # But if you are careful, you can do a lot of neat things with them. This is
250             # all very powerful, of course, and should only be used in moderation to make
251             # the world a better place.
252              
253             # P.332 Care with Prototypes
254             # in Chapter 7: Subroutines
255             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
256             #
257             # If you aren't careful, you can get yourself into trouble with prototypes.
258             # But if you are careful, you can do a lot of neat things with them. This is
259             # all very powerful, of course, and should only be used in moderation to make
260             # the world a better place.
261              
262             #
263             # Prototypes of subroutines
264             #
265       0     sub unimport {}
266             sub Egbk::split(;$$$);
267             sub Egbk::tr($$$$;$);
268             sub Egbk::chop(@);
269             sub Egbk::index($$;$);
270             sub Egbk::rindex($$;$);
271             sub Egbk::lcfirst(@);
272             sub Egbk::lcfirst_();
273             sub Egbk::lc(@);
274             sub Egbk::lc_();
275             sub Egbk::ucfirst(@);
276             sub Egbk::ucfirst_();
277             sub Egbk::uc(@);
278             sub Egbk::uc_();
279             sub Egbk::fc(@);
280             sub Egbk::fc_();
281             sub Egbk::ignorecase;
282             sub Egbk::classic_character_class;
283             sub Egbk::capture;
284             sub Egbk::chr(;$);
285             sub Egbk::chr_();
286             sub Egbk::filetest;
287             sub Egbk::r(;*@);
288             sub Egbk::w(;*@);
289             sub Egbk::x(;*@);
290             sub Egbk::o(;*@);
291             sub Egbk::R(;*@);
292             sub Egbk::W(;*@);
293             sub Egbk::X(;*@);
294             sub Egbk::O(;*@);
295             sub Egbk::e(;*@);
296             sub Egbk::z(;*@);
297             sub Egbk::s(;*@);
298             sub Egbk::f(;*@);
299             sub Egbk::d(;*@);
300             sub Egbk::l(;*@);
301             sub Egbk::p(;*@);
302             sub Egbk::S(;*@);
303             sub Egbk::b(;*@);
304             sub Egbk::c(;*@);
305             sub Egbk::u(;*@);
306             sub Egbk::g(;*@);
307             sub Egbk::k(;*@);
308             sub Egbk::T(;*@);
309             sub Egbk::B(;*@);
310             sub Egbk::M(;*@);
311             sub Egbk::A(;*@);
312             sub Egbk::C(;*@);
313             sub Egbk::filetest_;
314             sub Egbk::r_();
315             sub Egbk::w_();
316             sub Egbk::x_();
317             sub Egbk::o_();
318             sub Egbk::R_();
319             sub Egbk::W_();
320             sub Egbk::X_();
321             sub Egbk::O_();
322             sub Egbk::e_();
323             sub Egbk::z_();
324             sub Egbk::s_();
325             sub Egbk::f_();
326             sub Egbk::d_();
327             sub Egbk::l_();
328             sub Egbk::p_();
329             sub Egbk::S_();
330             sub Egbk::b_();
331             sub Egbk::c_();
332             sub Egbk::u_();
333             sub Egbk::g_();
334             sub Egbk::k_();
335             sub Egbk::T_();
336             sub Egbk::B_();
337             sub Egbk::M_();
338             sub Egbk::A_();
339             sub Egbk::C_();
340             sub Egbk::glob($);
341             sub Egbk::glob_();
342             sub Egbk::lstat(*);
343             sub Egbk::lstat_();
344             sub Egbk::opendir(*$);
345             sub Egbk::stat(*);
346             sub Egbk::stat_();
347             sub Egbk::unlink(@);
348             sub Egbk::chdir(;$);
349             sub Egbk::do($);
350             sub Egbk::require(;$);
351             sub Egbk::telldir(*);
352              
353             sub GBK::ord(;$);
354             sub GBK::ord_();
355             sub GBK::reverse(@);
356             sub GBK::getc(;*@);
357             sub GBK::length(;$);
358             sub GBK::substr($$;$$);
359             sub GBK::index($$;$);
360             sub GBK::rindex($$;$);
361             sub GBK::escape(;$);
362              
363             #
364             # Regexp work
365             #
366 391         43286 use vars qw(
367             $re_a
368             $re_t
369             $re_n
370             $re_r
371 391     391   5898 );
  391         872  
372              
373             #
374             # Character class
375             #
376 391         100349 use vars qw(
377             $dot
378             $dot_s
379             $eD
380             $eS
381             $eW
382             $eH
383             $eV
384             $eR
385             $eN
386             $not_alnum
387             $not_alpha
388             $not_ascii
389             $not_blank
390             $not_cntrl
391             $not_digit
392             $not_graph
393             $not_lower
394             $not_lower_i
395             $not_print
396             $not_punct
397             $not_space
398             $not_upper
399             $not_upper_i
400             $not_word
401             $not_xdigit
402             $eb
403             $eB
404 391     391   4032 );
  391         2322  
405              
406 391         4202618 use vars qw(
407             $anchor
408             $matched
409 391     391   3740 );
  391         6498  
410             ${Egbk::anchor} = qr{\G(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?}oxms;
411             my $q_char_SADAHIRO_Tomoyuki_2002_01_17 = '';
412              
413             # Quantifiers
414             # {n,m} --- Match at least n but not more than m times
415             #
416             # n and m are limited to non-negative integral values less than a
417             # preset limit defined when perl is built. This is usually 32766 on
418             # the most common platforms.
419             #
420             # The following code is an attempt to solve the above limitations
421             # in a multi-byte anchoring.
422              
423             # avoid "Segmentation fault" and "Error: Parse exception"
424              
425             # perl5101delta
426             # http://perldoc.perl.org/perl5101delta.html
427             # In 5.10.0, the * quantifier in patterns was sometimes treated as {0,32767}
428             # [RT #60034, #60464]. For example, this match would fail:
429             # ("ab" x 32768) =~ /^(ab)*$/
430              
431             # SEE ALSO
432             #
433             # Complex regular subexpression recursion limit
434             # http://www.perlmonks.org/?node_id=810857
435             #
436             # regexp iteration limits
437             # http://www.nntp.perl.org/group/perl.perl5.porters/2009/02/msg144065.html
438             #
439             # latest Perl won't match certain regexes more than 32768 characters long
440             # http://stackoverflow.com/questions/26226630/latest-perl-wont-match-certain-regexes-more-than-32768-characters-long
441             #
442             # Break through the limitations of regular expressions of Perl
443             # http://d.hatena.ne.jp/gfx/20110212/1297512479
444              
445             if (($] >= 5.010001) or
446             # ActivePerl 5.6 or later (include 5.10.0)
447             (defined($ActivePerl::VERSION) and ($ActivePerl::VERSION > 800)) or
448             (($^O eq 'MSWin32') and ($] =~ /\A 5\.006/oxms))
449             ) {
450             my $sbcs = ''; # Single Byte Character Set
451             for my $range (@{ $range_tr{1} }) {
452             $sbcs .= sprintf('\\x%02X-\\x%02X', $range->[0], $range->[-1]);
453             }
454              
455             if (0) {
456             }
457              
458             # other encoding
459             else {
460             ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17} = qr{.*?[$sbcs](?:[^$sbcs][^$sbcs])*?}oxms;
461             # ******* octets not in multiple octet char (always char boundary)
462             # **************** 2 octet chars
463             }
464              
465             ${Egbk::anchor_SADAHIRO_Tomoyuki_2002_01_17} =
466             qr{\G(?(?=.{0,32766}\z)(?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?|(?(?=[$sbcs]+\z).*?|(?:${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17})))}oxms;
467             # qr{
468             # \G # (1), (2)
469             # (? # (3)
470             # (?=.{0,32766}\z) # (4)
471             # (?:[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])*?| # (5)
472             # (?(?=[$sbcs]+\z) # (6)
473             # .*?| #(7)
474             # (?:${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17}) # (8)
475             # ))}oxms;
476              
477             # avoid: Complex regular subexpression recursion limit (32766) exceeded at here.
478             local $^W = 0;
479             local $SIG{__WARN__} = sub {};
480              
481             if (((('A' x 32768).'B') !~ / ${Egbk::anchor} B /oxms) and
482             ((('A' x 32768).'B') =~ / ${Egbk::anchor_SADAHIRO_Tomoyuki_2002_01_17} B /oxms)
483             ) {
484             ${Egbk::anchor} = ${Egbk::anchor_SADAHIRO_Tomoyuki_2002_01_17};
485             }
486             else {
487             undef ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17};
488             }
489             }
490              
491             # (1)
492             # P.128 Start of match (or end of previous match): \G
493             # P.130 Advanced Use of \G with Perl
494             # in Chapter3: Over view of Regular Expression Features and Flavors
495             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
496              
497             # (2)
498             # P.255 Use leading anchors
499             # P.256 Expose ^ and \G at the front of expressions
500             # in Chapter6: Crafting an Efficient Expression
501             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
502              
503             # (3)
504             # P.138 Conditional: (? if then| else)
505             # in Chapter3: Over view of Regular Expression Features and Flavors
506             # of ISBN 0-596-00289-0 Mastering Regular Expressions, Second edition
507              
508             # (4)
509             # perlre
510             # http://perldoc.perl.org/perlre.html
511             # The "*" quantifier is equivalent to {0,} , the "+" quantifier to {1,} ,
512             # and the "?" quantifier to {0,1}, ., n, and m are limited to non-negative
513             # integral values less than a preset limit defined when perl is built.
514             # This is usually 32766 on the most common platforms. The actual limit
515             # can be seen in the error message generated by code such as this:
516             # $_ **= $_ , / {$_} / for 2 .. 42;
517              
518             # (5)
519             # P.1023 Multiple-Byte Anchoring
520             # in Appendix W Perl Code Examples
521             # of ISBN 1-56592-224-7 CJKV Information Processing
522              
523             # (6)
524             # if string has only SBCS (Single Byte Character Set)
525              
526             # (7)
527             # then .*? (isn't limited to 32766)
528              
529             # (8)
530             # else GBK::Regexp::Const (SADAHIRO Tomoyuki)
531             # http://homepage1.nifty.com/nomenclator/perl/shiftjis.htm#long
532             # http://search.cpan.org/~sadahiro/GBK-Regexp/
533             # $PadA = ' (?:\A| [\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
534             # $PadG = '\G(?: |[\x00-\xFF]*?[\x00-\x80\xA0-\xDF])(?:[\x81-\xFE]{2})*?';
535             # $PadGA = '\G(?:\A|(?:[\x81-\xFE]{2})+?|[\x00-\xFF]*?[\x00-\x80\xA0-\xDF] (?:[\x81-\xFE]{2})*?)';
536              
537             ${Egbk::dot} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
538             ${Egbk::dot_s} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])};
539             ${Egbk::eD} = qr{(?>[^\x81-\xFE0-9]|[\x81-\xFE][\x00-\xFF])};
540              
541             # Vertical tabs are now whitespace
542             # \s in a regex now matches a vertical tab in all circumstances.
543             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
544             # ${Egbk::eS} = qr{(?>[^\x81-\xFE\x09\x0A \x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
545             # ${Egbk::eS} = qr{(?>[^\x81-\xFE\x09\x0A\x0B\x0C\x0D\x20]|[\x81-\xFE][\x00-\xFF])};
546             ${Egbk::eS} = qr{(?>[^\x81-\xFE\s]|[\x81-\xFE][\x00-\xFF])};
547              
548             ${Egbk::eW} = qr{(?>[^\x81-\xFE0-9A-Z_a-z]|[\x81-\xFE][\x00-\xFF])};
549             ${Egbk::eH} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
550             ${Egbk::eV} = qr{(?>[^\x81-\xFE\x0A\x0B\x0C\x0D]|[\x81-\xFE][\x00-\xFF])};
551             ${Egbk::eR} = qr{(?>\x0D\x0A|[\x0A\x0D])};
552             ${Egbk::eN} = qr{(?>[^\x81-\xFE\x0A]|[\x81-\xFE][\x00-\xFF])};
553             ${Egbk::not_alnum} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
554             ${Egbk::not_alpha} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
555             ${Egbk::not_ascii} = qr{(?>[^\x81-\xFE\x00-\x7F]|[\x81-\xFE][\x00-\xFF])};
556             ${Egbk::not_blank} = qr{(?>[^\x81-\xFE\x09\x20]|[\x81-\xFE][\x00-\xFF])};
557             ${Egbk::not_cntrl} = qr{(?>[^\x81-\xFE\x00-\x1F\x7F]|[\x81-\xFE][\x00-\xFF])};
558             ${Egbk::not_digit} = qr{(?>[^\x81-\xFE\x30-\x39]|[\x81-\xFE][\x00-\xFF])};
559             ${Egbk::not_graph} = qr{(?>[^\x81-\xFE\x21-\x7F]|[\x81-\xFE][\x00-\xFF])};
560             ${Egbk::not_lower} = qr{(?>[^\x81-\xFE\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
561             ${Egbk::not_lower_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
562             # ${Egbk::not_lower_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
563             ${Egbk::not_print} = qr{(?>[^\x81-\xFE\x20-\x7F]|[\x81-\xFE][\x00-\xFF])};
564             ${Egbk::not_punct} = qr{(?>[^\x81-\xFE\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]|[\x81-\xFE][\x00-\xFF])};
565             ${Egbk::not_space} = qr{(?>[^\x81-\xFE\s\x0B]|[\x81-\xFE][\x00-\xFF])};
566             ${Egbk::not_upper} = qr{(?>[^\x81-\xFE\x41-\x5A]|[\x81-\xFE][\x00-\xFF])};
567             ${Egbk::not_upper_i} = qr{(?>[^\x81-\xFE\x41-\x5A\x61-\x7A]|[\x81-\xFE][\x00-\xFF])}; # Perl 5.16 compatible
568             # ${Egbk::not_upper_i} = qr{(?>[^\x81-\xFE]|[\x81-\xFE][\x00-\xFF])}; # older Perl compatible
569             ${Egbk::not_word} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x5A\x5F\x61-\x7A]|[\x81-\xFE][\x00-\xFF])};
570             ${Egbk::not_xdigit} = qr{(?>[^\x81-\xFE\x30-\x39\x41-\x46\x61-\x66]|[\x81-\xFE][\x00-\xFF])};
571             ${Egbk::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))};
572             ${Egbk::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]))};
573              
574             # avoid: Name "Egbk::foo" used only once: possible typo at here.
575             ${Egbk::dot} = ${Egbk::dot};
576             ${Egbk::dot_s} = ${Egbk::dot_s};
577             ${Egbk::eD} = ${Egbk::eD};
578             ${Egbk::eS} = ${Egbk::eS};
579             ${Egbk::eW} = ${Egbk::eW};
580             ${Egbk::eH} = ${Egbk::eH};
581             ${Egbk::eV} = ${Egbk::eV};
582             ${Egbk::eR} = ${Egbk::eR};
583             ${Egbk::eN} = ${Egbk::eN};
584             ${Egbk::not_alnum} = ${Egbk::not_alnum};
585             ${Egbk::not_alpha} = ${Egbk::not_alpha};
586             ${Egbk::not_ascii} = ${Egbk::not_ascii};
587             ${Egbk::not_blank} = ${Egbk::not_blank};
588             ${Egbk::not_cntrl} = ${Egbk::not_cntrl};
589             ${Egbk::not_digit} = ${Egbk::not_digit};
590             ${Egbk::not_graph} = ${Egbk::not_graph};
591             ${Egbk::not_lower} = ${Egbk::not_lower};
592             ${Egbk::not_lower_i} = ${Egbk::not_lower_i};
593             ${Egbk::not_print} = ${Egbk::not_print};
594             ${Egbk::not_punct} = ${Egbk::not_punct};
595             ${Egbk::not_space} = ${Egbk::not_space};
596             ${Egbk::not_upper} = ${Egbk::not_upper};
597             ${Egbk::not_upper_i} = ${Egbk::not_upper_i};
598             ${Egbk::not_word} = ${Egbk::not_word};
599             ${Egbk::not_xdigit} = ${Egbk::not_xdigit};
600             ${Egbk::eb} = ${Egbk::eb};
601             ${Egbk::eB} = ${Egbk::eB};
602              
603             #
604             # GBK split
605             #
606             sub Egbk::split(;$$$) {
607              
608             # P.794 29.2.161. split
609             # in Chapter 29: Functions
610             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
611              
612             # P.951 split
613             # in Chapter 27: Functions
614             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
615              
616 5     0 0 11765 my $pattern = $_[0];
617 0         0 my $string = $_[1];
618 0         0 my $limit = $_[2];
619              
620             # if $pattern is also omitted or is the literal space, " "
621 0 0       0 if (not defined $pattern) {
622 0         0 $pattern = ' ';
623             }
624              
625             # if $string is omitted, the function splits the $_ string
626 0 0       0 if (not defined $string) {
627 0 0       0 if (defined $_) {
628 0         0 $string = $_;
629             }
630             else {
631 0         0 $string = '';
632             }
633             }
634              
635 0         0 my @split = ();
636              
637             # when string is empty
638 0 0       0 if ($string eq '') {
    0          
639              
640             # resulting list value in list context
641 0 0       0 if (wantarray) {
642 0         0 return @split;
643             }
644              
645             # count of substrings in scalar context
646             else {
647 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
648 0         0 @_ = @split;
649 0         0 return scalar @_;
650             }
651             }
652              
653             # split's first argument is more consistently interpreted
654             #
655             # After some changes earlier in v5.17, split's behavior has been simplified:
656             # if the PATTERN argument evaluates to a string containing one space, it is
657             # treated the way that a literal string containing one space once was.
658             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
659              
660             # if $pattern is also omitted or is the literal space, " ", the function splits
661             # on whitespace, /\s+/, after skipping any leading whitespace
662             # (and so on)
663              
664             elsif ($pattern eq ' ') {
665 0 0       0 if (not defined $limit) {
666 0         0 return CORE::split(' ', $string);
667             }
668             else {
669 0         0 return CORE::split(' ', $string, $limit);
670             }
671             }
672              
673 0         0 local $q_char = $q_char;
674 0 0       0 if (CORE::length($string) > 32766) {
675 0 0       0 if ($string =~ /\A [\x00-\x7F]+ \z/oxms) {
    0          
676 0         0 $q_char = qr{.}s;
677             }
678             elsif (defined ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17}) {
679 0         0 $q_char = ${Egbk::q_char_SADAHIRO_Tomoyuki_2002_01_17};
680             }
681             }
682              
683             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
684 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
685              
686             # a pattern capable of matching either the null string or something longer than the
687             # null string will split the value of $string into separate characters wherever it
688             # matches the null string between characters
689             # (and so on)
690              
691 0 0       0 if ('' =~ / \A $pattern \z /xms) {
692 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
693 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
694              
695             # P.1024 Appendix W.10 Multibyte Processing
696             # of ISBN 1-56592-224-7 CJKV Information Processing
697             # (and so on)
698              
699             # the //m modifier is assumed when you split on the pattern /^/
700             # (and so on)
701              
702 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
703             # V
704 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
705              
706             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
707             # is included in the resulting list, interspersed with the fields that are ordinarily returned
708             # (and so on)
709              
710 0         0 local $@;
711 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
712 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
713 0         0 push @split, CORE::eval('$' . $digit);
714             }
715             }
716             }
717              
718             else {
719 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
720              
721 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
722             # V
723 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
724 0         0 local $@;
725 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
726 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
727 0         0 push @split, CORE::eval('$' . $digit);
728             }
729             }
730             }
731             }
732              
733             elsif ($limit > 0) {
734 0 0       0 if ('' =~ / \A $pattern \z /xms) {
735 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
736 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
737              
738 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
739             # V
740 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
741 0         0 local $@;
742 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
743 0         0 push @split, CORE::eval('$' . $digit);
744             }
745             }
746             }
747             }
748             else {
749 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
750 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
751              
752 0         0 eval q{ no warnings }; # avoid: Complex regular subexpression recursion limit (32766) exceeded at ...
753             # V
754 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
755 0         0 local $@;
756 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
757 0         0 push @split, CORE::eval('$' . $digit);
758             }
759             }
760             }
761             }
762             }
763              
764 0 0       0 if (CORE::length($string) > 0) {
765 0         0 push @split, $string;
766             }
767              
768             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
769 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
770 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
771 0         0 pop @split;
772             }
773             }
774              
775             # resulting list value in list context
776 0 0       0 if (wantarray) {
777 0         0 return @split;
778             }
779              
780             # count of substrings in scalar context
781             else {
782 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
783 0         0 @_ = @split;
784 0         0 return scalar @_;
785             }
786             }
787              
788             #
789             # get last subexpression offsets
790             #
791             sub _last_subexpression_offsets {
792 0     0   0 my $pattern = $_[0];
793              
794             # remove comment
795 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
796              
797 0         0 my $modifier = '';
798 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
799 0         0 $modifier = $1;
800 0         0 $modifier =~ s/-[A-Za-z]*//;
801             }
802              
803             # with /x modifier
804 0         0 my @char = ();
805 0 0       0 if ($modifier =~ /x/oxms) {
806 0         0 @char = $pattern =~ /\G((?>
807             [^\x81-\xFE\\\#\[\(]|[\x81-\xFE][\x00-\xFF] |
808             \\ $q_char |
809             \# (?>[^\n]*) $ |
810             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
811             \(\? |
812             $q_char
813             ))/oxmsg;
814             }
815              
816             # without /x modifier
817             else {
818 0         0 @char = $pattern =~ /\G((?>
819             [^\x81-\xFE\\\[\(]|[\x81-\xFE][\x00-\xFF] |
820             \\ $q_char |
821             \[ (?>(?:[^\x81-\xFE\\\]]|[\x81-\xFE][\x00-\xFF]|\\\\|\\\]|$q_char)+) \] |
822             \(\? |
823             $q_char
824             ))/oxmsg;
825             }
826              
827 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
828             }
829              
830             #
831             # GBK transliteration (tr///)
832             #
833             sub Egbk::tr($$$$;$) {
834              
835 0     0 0 0 my $bind_operator = $_[1];
836 0         0 my $searchlist = $_[2];
837 0         0 my $replacementlist = $_[3];
838 0   0     0 my $modifier = $_[4] || '';
839              
840 0 0       0 if ($modifier =~ /r/oxms) {
841 0 0       0 if ($bind_operator =~ / !~ /oxms) {
842 0         0 croak "Using !~ with tr///r doesn't make sense";
843             }
844             }
845              
846 0         0 my @char = $_[0] =~ /\G (?>$q_char) /oxmsg;
847 0         0 my @searchlist = _charlist_tr($searchlist);
848 0         0 my @replacementlist = _charlist_tr($replacementlist);
849              
850 0         0 my %tr = ();
851 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
852 0 0       0 if (not exists $tr{$searchlist[$i]}) {
853 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
854 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
855             }
856             elsif ($modifier =~ /d/oxms) {
857 0         0 $tr{$searchlist[$i]} = '';
858             }
859             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
860 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
861             }
862             else {
863 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
864             }
865             }
866             }
867              
868 0         0 my $tr = 0;
869 0         0 my $replaced = '';
870 0 0       0 if ($modifier =~ /c/oxms) {
871 0         0 while (defined(my $char = shift @char)) {
872 0 0       0 if (not exists $tr{$char}) {
873 0 0       0 if (defined $replacementlist[-1]) {
874 0         0 $replaced .= $replacementlist[-1];
875             }
876 0         0 $tr++;
877 0 0       0 if ($modifier =~ /s/oxms) {
878 0   0     0 while (@char and (not exists $tr{$char[0]})) {
879 0         0 shift @char;
880 0         0 $tr++;
881             }
882             }
883             }
884             else {
885 0         0 $replaced .= $char;
886             }
887             }
888             }
889             else {
890 0         0 while (defined(my $char = shift @char)) {
891 0 0       0 if (exists $tr{$char}) {
892 0         0 $replaced .= $tr{$char};
893 0         0 $tr++;
894 0 0       0 if ($modifier =~ /s/oxms) {
895 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
896 0         0 shift @char;
897 0         0 $tr++;
898             }
899             }
900             }
901             else {
902 0         0 $replaced .= $char;
903             }
904             }
905             }
906              
907 0 0       0 if ($modifier =~ /r/oxms) {
908 0         0 return $replaced;
909             }
910             else {
911 0         0 $_[0] = $replaced;
912 0 0       0 if ($bind_operator =~ / !~ /oxms) {
913 0         0 return not $tr;
914             }
915             else {
916 0         0 return $tr;
917             }
918             }
919             }
920              
921             #
922             # GBK chop
923             #
924             sub Egbk::chop(@) {
925              
926 0     0 0 0 my $chop;
927 0 0       0 if (@_ == 0) {
928 0         0 my @char = /\G (?>$q_char) /oxmsg;
929 0         0 $chop = pop @char;
930 0         0 $_ = join '', @char;
931             }
932             else {
933 0         0 for (@_) {
934 0         0 my @char = /\G (?>$q_char) /oxmsg;
935 0         0 $chop = pop @char;
936 0         0 $_ = join '', @char;
937             }
938             }
939 0         0 return $chop;
940             }
941              
942             #
943             # GBK index by octet
944             #
945             sub Egbk::index($$;$) {
946              
947 0     2316 1 0 my($str,$substr,$position) = @_;
948 2316   50     4658 $position ||= 0;
949 2316         8557 my $pos = 0;
950              
951 2316         2643 while ($pos < CORE::length($str)) {
952 2316 50       4748 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
953 40318 0       62187 if ($pos >= $position) {
954 0         0 return $pos;
955             }
956             }
957 0 50       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
958 40318         91159 $pos += CORE::length($1);
959             }
960             else {
961 40318         65397 $pos += 1;
962             }
963             }
964 0         0 return -1;
965             }
966              
967             #
968             # GBK reverse index
969             #
970             sub Egbk::rindex($$;$) {
971              
972 2316     0 0 12504 my($str,$substr,$position) = @_;
973 0   0     0 $position ||= CORE::length($str) - 1;
974 0         0 my $pos = 0;
975 0         0 my $rindex = -1;
976              
977 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
978 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
979 0         0 $rindex = $pos;
980             }
981 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
982 0         0 $pos += CORE::length($1);
983             }
984             else {
985 0         0 $pos += 1;
986             }
987             }
988 0         0 return $rindex;
989             }
990              
991             #
992             # GBK lower case first with parameter
993             #
994             sub Egbk::lcfirst(@) {
995 0 0   0 0 0 if (@_) {
996 0         0 my $s = shift @_;
997 0 0 0     0 if (@_ and wantarray) {
998 0         0 return Egbk::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
999             }
1000             else {
1001 0         0 return Egbk::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1002             }
1003             }
1004             else {
1005 0         0 return Egbk::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1006             }
1007             }
1008              
1009             #
1010             # GBK lower case first without parameter
1011             #
1012             sub Egbk::lcfirst_() {
1013 0     0 0 0 return Egbk::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1014             }
1015              
1016             #
1017             # GBK lower case with parameter
1018             #
1019             sub Egbk::lc(@) {
1020 0 0   0 0 0 if (@_) {
1021 0         0 my $s = shift @_;
1022 0 0 0     0 if (@_ and wantarray) {
1023 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1024             }
1025             else {
1026 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
1027             }
1028             }
1029             else {
1030 0         0 return Egbk::lc_();
1031             }
1032             }
1033              
1034             #
1035             # GBK lower case without parameter
1036             #
1037             sub Egbk::lc_() {
1038 0     0 0 0 my $s = $_;
1039 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1040             }
1041              
1042             #
1043             # GBK upper case first with parameter
1044             #
1045             sub Egbk::ucfirst(@) {
1046 0 0   0 0 0 if (@_) {
1047 0         0 my $s = shift @_;
1048 0 0 0     0 if (@_ and wantarray) {
1049 0         0 return Egbk::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
1050             }
1051             else {
1052 0         0 return Egbk::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
1053             }
1054             }
1055             else {
1056 0         0 return Egbk::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1057             }
1058             }
1059              
1060             #
1061             # GBK upper case first without parameter
1062             #
1063             sub Egbk::ucfirst_() {
1064 0     0 0 0 return Egbk::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
1065             }
1066              
1067             #
1068             # GBK upper case with parameter
1069             #
1070             sub Egbk::uc(@) {
1071 0 50   2968 0 0 if (@_) {
1072 2968         4634 my $s = shift @_;
1073 2968 50 33     3935 if (@_ and wantarray) {
1074 2968 0       5607 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1075             }
1076             else {
1077 0 100       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  2968         8663  
1078             }
1079             }
1080             else {
1081 2968         10692 return Egbk::uc_();
1082             }
1083             }
1084              
1085             #
1086             # GBK upper case without parameter
1087             #
1088             sub Egbk::uc_() {
1089 0     0 0 0 my $s = $_;
1090 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1091             }
1092              
1093             #
1094             # GBK fold case with parameter
1095             #
1096             sub Egbk::fc(@) {
1097 0 50   3271 0 0 if (@_) {
1098 3271         4705 my $s = shift @_;
1099 3271 50 33     4052 if (@_ and wantarray) {
1100 3271 0       5805 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
1101             }
1102             else {
1103 0 100       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  3271         8513  
1104             }
1105             }
1106             else {
1107 3271         12687 return Egbk::fc_();
1108             }
1109             }
1110              
1111             #
1112             # GBK fold case without parameter
1113             #
1114             sub Egbk::fc_() {
1115 0     0 0 0 my $s = $_;
1116 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
1117             }
1118              
1119             #
1120             # GBK regexp capture
1121             #
1122             {
1123             # 10.3. Creating Persistent Private Variables
1124             # in Chapter 10. Subroutines
1125             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
1126              
1127             my $last_s_matched = 0;
1128              
1129             sub Egbk::capture {
1130 0 0 0 0 1 0 if ($last_s_matched and ($_[0] =~ /\A (?>[1-9][0-9]*) \z/oxms)) {
1131 0         0 return $_[0] + 1;
1132             }
1133 0         0 return $_[0];
1134             }
1135              
1136             # GBK mark last regexp matched
1137             sub Egbk::matched() {
1138 0     0 0 0 $last_s_matched = 0;
1139             }
1140              
1141             # GBK mark last s/// matched
1142             sub Egbk::s_matched() {
1143 0     0 0 0 $last_s_matched = 1;
1144             }
1145              
1146             # P.854 31.17. use re
1147             # in Chapter 31. Pragmatic Modules
1148             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1149              
1150             # P.1026 re
1151             # in Chapter 29. Pragmatic Modules
1152             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1153              
1154             $Egbk::matched = qr/(?{Egbk::matched})/;
1155             }
1156              
1157             #
1158             # GBK regexp ignore case modifier
1159             #
1160             sub Egbk::ignorecase {
1161              
1162 0     0 0 0 my @string = @_;
1163 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
1164              
1165             # ignore case of $scalar or @array
1166 0         0 for my $string (@string) {
1167              
1168             # split regexp
1169 0         0 my @char = $string =~ /\G (?>\[\^|\\$q_char|$q_char) /oxmsg;
1170              
1171             # unescape character
1172 0         0 for (my $i=0; $i <= $#char; $i++) {
1173 0 0       0 next if not defined $char[$i];
1174              
1175             # open character class [...]
1176 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
1177 0         0 my $left = $i;
1178              
1179             # [] make die "unmatched [] in regexp ...\n"
1180              
1181 0 0       0 if ($char[$i+1] eq ']') {
1182 0         0 $i++;
1183             }
1184              
1185 0         0 while (1) {
1186 0 0       0 if (++$i > $#char) {
1187 0         0 croak "Unmatched [] in regexp";
1188             }
1189 0 0       0 if ($char[$i] eq ']') {
1190 0         0 my $right = $i;
1191 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
1192              
1193             # escape character
1194 0         0 for my $char (@charlist) {
1195 0 0       0 if (0) {
    0          
1196             }
1197              
1198             # do not use quotemeta here
1199 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1200 0         0 $char = $1 . '\\' . $2;
1201             }
1202             elsif ($char =~ /\A [.|)] \z/oxms) {
1203 0         0 $char = '\\' . $char;
1204             }
1205             }
1206              
1207             # [...]
1208 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
1209              
1210 0         0 $i = $left;
1211 0         0 last;
1212             }
1213             }
1214             }
1215              
1216             # open character class [^...]
1217             elsif ($char[$i] eq '[^') {
1218 0         0 my $left = $i;
1219              
1220             # [^] make die "unmatched [] in regexp ...\n"
1221              
1222 0 0       0 if ($char[$i+1] eq ']') {
1223 0         0 $i++;
1224             }
1225              
1226 0         0 while (1) {
1227 0 0       0 if (++$i > $#char) {
1228 0         0 croak "Unmatched [] in regexp";
1229             }
1230 0 0       0 if ($char[$i] eq ']') {
1231 0         0 my $right = $i;
1232 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
1233              
1234             # escape character
1235 0         0 for my $char (@charlist) {
1236 0 0       0 if (0) {
    0          
1237             }
1238              
1239             # do not use quotemeta here
1240 0         0 elsif ($char =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1241 0         0 $char = $1 . '\\' . $2;
1242             }
1243             elsif ($char =~ /\A [.|)] \z/oxms) {
1244 0         0 $char = '\\' . $char;
1245             }
1246             }
1247              
1248             # [^...]
1249 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
1250              
1251 0         0 $i = $left;
1252 0         0 last;
1253             }
1254             }
1255             }
1256              
1257             # rewrite classic character class or escape character
1258             elsif (my $char = classic_character_class($char[$i])) {
1259 0         0 $char[$i] = $char;
1260             }
1261              
1262             # with /i modifier
1263             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1264 0         0 my $uc = Egbk::uc($char[$i]);
1265 0         0 my $fc = Egbk::fc($char[$i]);
1266 0 0       0 if ($uc ne $fc) {
1267 0 0       0 if (CORE::length($fc) == 1) {
1268 0         0 $char[$i] = '[' . $uc . $fc . ']';
1269             }
1270             else {
1271 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
1272             }
1273             }
1274             }
1275             }
1276              
1277             # characterize
1278 0         0 for (my $i=0; $i <= $#char; $i++) {
1279 0 0       0 next if not defined $char[$i];
1280              
1281 0 0 0     0 if (0) {
    0          
1282             }
1283              
1284             # escape last octet of multiple-octet
1285 0         0 elsif ($char[$i] =~ /\A ([\x80-\xFF].*) ($metachar) \z/oxms) {
1286 0         0 $char[$i] = $1 . '\\' . $2;
1287             }
1288              
1289             # quote character before ? + * {
1290             elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1291 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1292 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1293             }
1294             }
1295             }
1296              
1297 0         0 $string = join '', @char;
1298             }
1299              
1300             # make regexp string
1301 0         0 return @string;
1302             }
1303              
1304             #
1305             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1306             #
1307             sub Egbk::classic_character_class {
1308 0     5319 0 0 my($char) = @_;
1309              
1310             return {
1311             '\D' => '${Egbk::eD}',
1312             '\S' => '${Egbk::eS}',
1313             '\W' => '${Egbk::eW}',
1314             '\d' => '[0-9]',
1315              
1316             # Before Perl 5.6, \s only matched the five whitespace characters
1317             # tab, newline, form-feed, carriage return, and the space character
1318             # itself, which, taken together, is the character class [\t\n\f\r ].
1319              
1320             # Vertical tabs are now whitespace
1321             # \s in a regex now matches a vertical tab in all circumstances.
1322             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1323             # \t \n \v \f \r space
1324             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1325             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1326             '\s' => '\s',
1327              
1328             '\w' => '[0-9A-Z_a-z]',
1329             '\C' => '[\x00-\xFF]',
1330             '\X' => 'X',
1331              
1332             # \h \v \H \V
1333              
1334             # P.114 Character Class Shortcuts
1335             # in Chapter 7: In the World of Regular Expressions
1336             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1337              
1338             # P.357 13.2.3 Whitespace
1339             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1340             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1341             #
1342             # 0x00009 CHARACTER TABULATION h s
1343             # 0x0000a LINE FEED (LF) vs
1344             # 0x0000b LINE TABULATION v
1345             # 0x0000c FORM FEED (FF) vs
1346             # 0x0000d CARRIAGE RETURN (CR) vs
1347             # 0x00020 SPACE h s
1348              
1349             # P.196 Table 5-9. Alphanumeric regex metasymbols
1350             # in Chapter 5. Pattern Matching
1351             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1352              
1353             # (and so on)
1354              
1355             '\H' => '${Egbk::eH}',
1356             '\V' => '${Egbk::eV}',
1357             '\h' => '[\x09\x20]',
1358             '\v' => '[\x0A\x0B\x0C\x0D]',
1359             '\R' => '${Egbk::eR}',
1360              
1361             # \N
1362             #
1363             # http://perldoc.perl.org/perlre.html
1364             # Character Classes and other Special Escapes
1365             # Any character but \n (experimental). Not affected by /s modifier
1366              
1367             '\N' => '${Egbk::eN}',
1368              
1369             # \b \B
1370              
1371             # P.180 Boundaries: The \b and \B Assertions
1372             # in Chapter 5: Pattern Matching
1373             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1374              
1375             # P.219 Boundaries: The \b and \B Assertions
1376             # in Chapter 5: Pattern Matching
1377             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1378              
1379             # \b really means (?:(?<=\w)(?!\w)|(?
1380             # or (?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))
1381             '\b' => '${Egbk::eb}',
1382              
1383             # \B really means (?:(?<=\w)(?=\w)|(?
1384             # or (?:(?<=\w)(?=\w)|(?<=\W)(?=\W))
1385             '\B' => '${Egbk::eB}',
1386              
1387 5319   100     7067 }->{$char} || '';
1388             }
1389              
1390             #
1391             # prepare GBK characters per length
1392             #
1393              
1394             # 1 octet characters
1395             my @chars1 = ();
1396             sub chars1 {
1397 5319 0   0 0 190955 if (@chars1) {
1398 0         0 return @chars1;
1399             }
1400 0 0       0 if (exists $range_tr{1}) {
1401 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1402 0         0 while (my @range = splice(@ranges,0,1)) {
1403 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1404 0         0 push @chars1, pack 'C', $oct0;
1405             }
1406             }
1407             }
1408 0         0 return @chars1;
1409             }
1410              
1411             # 2 octets characters
1412             my @chars2 = ();
1413             sub chars2 {
1414 0 0   0 0 0 if (@chars2) {
1415 0         0 return @chars2;
1416             }
1417 0 0       0 if (exists $range_tr{2}) {
1418 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1419 0         0 while (my @range = splice(@ranges,0,2)) {
1420 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1421 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1422 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1423             }
1424             }
1425             }
1426             }
1427 0         0 return @chars2;
1428             }
1429              
1430             # 3 octets characters
1431             my @chars3 = ();
1432             sub chars3 {
1433 0 0   0 0 0 if (@chars3) {
1434 0         0 return @chars3;
1435             }
1436 0 0       0 if (exists $range_tr{3}) {
1437 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1438 0         0 while (my @range = splice(@ranges,0,3)) {
1439 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1440 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1441 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1442 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1443             }
1444             }
1445             }
1446             }
1447             }
1448 0         0 return @chars3;
1449             }
1450              
1451             # 4 octets characters
1452             my @chars4 = ();
1453             sub chars4 {
1454 0 0   0 0 0 if (@chars4) {
1455 0         0 return @chars4;
1456             }
1457 0 0       0 if (exists $range_tr{4}) {
1458 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1459 0         0 while (my @range = splice(@ranges,0,4)) {
1460 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1461 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1462 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1463 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1464 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1465             }
1466             }
1467             }
1468             }
1469             }
1470             }
1471 0         0 return @chars4;
1472             }
1473              
1474             #
1475             # GBK open character list for tr
1476             #
1477             sub _charlist_tr {
1478              
1479 0     0   0 local $_ = shift @_;
1480              
1481             # unescape character
1482 0         0 my @char = ();
1483 0         0 while (not /\G \z/oxmsgc) {
1484 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1485 0         0 push @char, '\-';
1486             }
1487             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1488 0         0 push @char, CORE::chr(oct $1);
1489             }
1490             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1491 0         0 push @char, CORE::chr(hex $1);
1492             }
1493             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1494 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1495             }
1496             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1497             push @char, {
1498             '\0' => "\0",
1499             '\n' => "\n",
1500             '\r' => "\r",
1501             '\t' => "\t",
1502             '\f' => "\f",
1503             '\b' => "\x08", # \b means backspace in character class
1504             '\a' => "\a",
1505             '\e' => "\e",
1506 0         0 }->{$1};
1507             }
1508             elsif (/\G \\ ($q_char) /oxmsgc) {
1509 0         0 push @char, $1;
1510             }
1511             elsif (/\G ($q_char) /oxmsgc) {
1512 0         0 push @char, $1;
1513             }
1514             }
1515              
1516             # join separated multiple-octet
1517 0         0 @char = join('',@char) =~ /\G (?>\\-|$q_char) /oxmsg;
1518              
1519             # unescape '-'
1520 0         0 my @i = ();
1521 0         0 for my $i (0 .. $#char) {
1522 0 0       0 if ($char[$i] eq '\-') {
    0          
1523 0         0 $char[$i] = '-';
1524             }
1525             elsif ($char[$i] eq '-') {
1526 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1527 0         0 push @i, $i;
1528             }
1529             }
1530             }
1531              
1532             # open character list (reverse for splice)
1533 0         0 for my $i (CORE::reverse @i) {
1534 0         0 my @range = ();
1535              
1536             # range error
1537 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1538 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1539             }
1540              
1541             # range of multiple-octet code
1542 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1543 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1544 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1545             }
1546             elsif (CORE::length($char[$i+1]) == 2) {
1547 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1548 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1549             }
1550             elsif (CORE::length($char[$i+1]) == 3) {
1551 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1552 0         0 push @range, chars2();
1553 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1554             }
1555             elsif (CORE::length($char[$i+1]) == 4) {
1556 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1557 0         0 push @range, chars2();
1558 0         0 push @range, chars3();
1559 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1560             }
1561             else {
1562 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1563             }
1564             }
1565             elsif (CORE::length($char[$i-1]) == 2) {
1566 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1567 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1568             }
1569             elsif (CORE::length($char[$i+1]) == 3) {
1570 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1571 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1572             }
1573             elsif (CORE::length($char[$i+1]) == 4) {
1574 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1575 0         0 push @range, chars3();
1576 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1577             }
1578             else {
1579 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1580             }
1581             }
1582             elsif (CORE::length($char[$i-1]) == 3) {
1583 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1584 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1585             }
1586             elsif (CORE::length($char[$i+1]) == 4) {
1587 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1588 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1589             }
1590             else {
1591 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1592             }
1593             }
1594             elsif (CORE::length($char[$i-1]) == 4) {
1595 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1596 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1597             }
1598             else {
1599 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1600             }
1601             }
1602             else {
1603 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1604             }
1605              
1606 0         0 splice @char, $i-1, 3, @range;
1607             }
1608              
1609 0         0 return @char;
1610             }
1611              
1612             #
1613             # GBK open character class
1614             #
1615             sub _cc {
1616 0 50   604   0 if (scalar(@_) == 0) {
    100          
    50          
1617 604         1328 die __FILE__, ": subroutine cc got no parameter.\n";
1618             }
1619             elsif (scalar(@_) == 1) {
1620 0         0 return sprintf('\x%02X',$_[0]);
1621             }
1622             elsif (scalar(@_) == 2) {
1623 302 50       1090 if ($_[0] > $_[1]) {
    50          
    50          
1624 302         835 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).\n";
1625             }
1626             elsif ($_[0] == $_[1]) {
1627 0         0 return sprintf('\x%02X',$_[0]);
1628             }
1629             elsif (($_[0]+1) == $_[1]) {
1630 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1631             }
1632             else {
1633 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1634             }
1635             }
1636             else {
1637 302         1691 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).\n";
  0         0  
1638             }
1639             }
1640              
1641             #
1642             # GBK octet range
1643             #
1644             sub _octets {
1645 0     668   0 my $length = shift @_;
1646              
1647 668 100       1162 if ($length == 1) {
    50          
    0          
    0          
1648 668         1564 my($a1) = unpack 'C', $_[0];
1649 406         1148 my($z1) = unpack 'C', $_[1];
1650              
1651 406 50       740 if ($a1 > $z1) {
1652 406         826 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1653             }
1654              
1655 0 100       0 if ($a1 == $z1) {
    50          
1656 406         1053 return sprintf('\x%02X',$a1);
1657             }
1658             elsif (($a1+1) == $z1) {
1659 20         90 return sprintf('\x%02X\x%02X',$a1,$z1);
1660             }
1661             else {
1662 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1663             }
1664             }
1665             elsif ($length == 2) {
1666 386         2557 my($a1,$a2) = unpack 'CC', $_[0];
1667 262         662 my($z1,$z2) = unpack 'CC', $_[1];
1668 262         515 my($A1,$A2) = unpack 'CC', $_[2];
1669 262         460 my($Z1,$Z2) = unpack 'CC', $_[3];
1670              
1671 262 100       450 if ($a1 == $z1) {
    50          
1672             return (
1673             # 11111111 222222222222
1674             # A A Z
1675 262         474 _cc($a1) . _cc($a2,$z2), # a2-z2
1676             );
1677             }
1678             elsif (($a1+1) == $z1) {
1679             return (
1680             # 11111111111 222222222222
1681             # A Z A Z
1682 222         401 _cc($a1) . _cc($a2,$Z2), # a2-
1683             _cc( $z1) . _cc($A2,$z2), # -z2
1684             );
1685             }
1686             else {
1687             return (
1688             # 1111111111111111 222222222222
1689             # A Z A Z
1690 40         74 _cc($a1) . _cc($a2,$Z2), # a2-
1691             _cc($a1+1,$z1-1) . _cc($A2,$Z2), # -
1692             _cc( $z1) . _cc($A2,$z2), # -z2
1693             );
1694             }
1695             }
1696             elsif ($length == 3) {
1697 0         0 my($a1,$a2,$a3) = unpack 'CCC', $_[0];
1698 0         0 my($z1,$z2,$z3) = unpack 'CCC', $_[1];
1699 0         0 my($A1,$A2,$A3) = unpack 'CCC', $_[2];
1700 0         0 my($Z1,$Z2,$Z3) = unpack 'CCC', $_[3];
1701              
1702 0 0       0 if ($a1 == $z1) {
    0          
1703 0 0       0 if ($a2 == $z2) {
    0          
1704             return (
1705             # 11111111 22222222 333333333333
1706             # A A A Z
1707 0         0 _cc($a1) . _cc($a2) . _cc($a3,$z3), # a3-z3
1708             );
1709             }
1710             elsif (($a2+1) == $z2) {
1711             return (
1712             # 11111111 22222222222 333333333333
1713             # A A Z A Z
1714 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1715             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1716             );
1717             }
1718             else {
1719             return (
1720             # 11111111 2222222222222222 333333333333
1721             # A A Z A Z
1722 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1723             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3), # -
1724             _cc($a1) . _cc( $z2) . _cc($A3,$z3), # -z3
1725             );
1726             }
1727             }
1728             elsif (($a1+1) == $z1) {
1729             return (
1730             # 11111111111 22222222222222 333333333333
1731             # A Z A Z A Z
1732 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1733             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1734             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1735             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1736             );
1737             }
1738             else {
1739             return (
1740             # 1111111111111111 22222222222222 333333333333
1741             # A Z A Z A Z
1742 0         0 _cc($a1) . _cc($a2) . _cc($a3,$Z3), # a3-
1743             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3), # -
1744             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3), # -
1745             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3), # -
1746             _cc( $z1) . _cc( $z2) . _cc($A3,$z3), # -z3
1747             );
1748             }
1749             }
1750             elsif ($length == 4) {
1751 0         0 my($a1,$a2,$a3,$a4) = unpack 'CCCC', $_[0];
1752 0         0 my($z1,$z2,$z3,$z4) = unpack 'CCCC', $_[1];
1753 0         0 my($A1,$A2,$A3,$A4) = unpack 'CCCC', $_[0];
1754 0         0 my($Z1,$Z2,$Z3,$Z4) = unpack 'CCCC', $_[1];
1755              
1756 0 0       0 if ($a1 == $z1) {
    0          
1757 0 0       0 if ($a2 == $z2) {
    0          
1758 0 0       0 if ($a3 == $z3) {
    0          
1759             return (
1760             # 11111111 22222222 33333333 444444444444
1761             # A A A A Z
1762 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$z4), # a4-z4
1763             );
1764             }
1765             elsif (($a3+1) == $z3) {
1766             return (
1767             # 11111111 22222222 33333333333 444444444444
1768             # A A A Z A Z
1769 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1770             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1771             );
1772             }
1773             else {
1774             return (
1775             # 11111111 22222222 3333333333333333 444444444444
1776             # A A A Z A Z
1777 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1778             _cc($a1) . _cc($a2) . _cc($a3+1,$z3-1) . _cc($A4,$Z4), # -
1779             _cc($a1) . _cc($a2) . _cc( $z3) . _cc($A4,$z4), # -z4
1780             );
1781             }
1782             }
1783             elsif (($a2+1) == $z2) {
1784             return (
1785             # 11111111 22222222222 33333333333333 444444444444
1786             # A A Z A Z A Z
1787 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1788             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1789             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1790             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1791             );
1792             }
1793             else {
1794             return (
1795             # 11111111 2222222222222222 33333333333333 444444444444
1796             # A A Z A Z A Z
1797 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1798             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1799             _cc($a1) . _cc($a2+1,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1800             _cc($a1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1801             _cc($a1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1802             );
1803             }
1804             }
1805             elsif (($a1+1) == $z1) {
1806             return (
1807             # 11111111111 22222222222222 33333333333333 444444444444
1808             # A Z A Z A Z A Z
1809 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1810             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1811             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1812             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1813             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1814             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1815             );
1816             }
1817             else {
1818             return (
1819             # 1111111111111111 22222222222222 33333333333333 444444444444
1820             # A Z A Z A Z A Z
1821 0         0 _cc($a1) . _cc($a2) . _cc($a3) . _cc($a4,$Z4), # a4-
1822             _cc($a1) . _cc($a2) . _cc($a3+1,$Z3) . _cc($A4,$Z4), # -
1823             _cc($a1) . _cc($a2+1,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1824             _cc($a1+1,$z1-1) . _cc($A2,$Z2) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1825             _cc( $z1) . _cc($A2,$z2-1) . _cc($A3,$Z3) . _cc($A4,$Z4), # -
1826             _cc( $z1) . _cc( $z2) . _cc($A3,$z3-1) . _cc($A4,$Z4), # -
1827             _cc( $z1) . _cc( $z2) . _cc( $z3) . _cc($A4,$z4), # -z4
1828             );
1829             }
1830             }
1831             else {
1832 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).\n";
1833             }
1834             }
1835              
1836             #
1837             # GBK range regexp
1838             #
1839             sub _range_regexp {
1840 0     517   0 my($length,$first,$last) = @_;
1841              
1842 517         1133 my @range_regexp = ();
1843 517 50       756 if (not exists $range_tr{$length}) {
1844 517         1327 return @range_regexp;
1845             }
1846              
1847 0         0 my @ranges = @{ $range_tr{$length} };
  517         875  
1848 517         1276 while (my @range = splice(@ranges,0,$length)) {
1849 517         1539 my $min = '';
1850 1034         1529 my $max = '';
1851 1034         1223 for (my $i=0; $i < $length; $i++) {
1852 1034         2050 $min .= pack 'C', $range[$i][0];
1853 1296         3033 $max .= pack 'C', $range[$i][-1];
1854             }
1855              
1856             # min___max
1857             # FIRST_____________LAST
1858             # (nothing)
1859              
1860 1296 50 66     2806 if ($max lt $first) {
    100 100        
    50 33        
    100 100        
    100 66        
    100 66        
    50 66        
1861             }
1862              
1863             # **********
1864             # min_________max
1865             # FIRST_____________LAST
1866             # **********
1867              
1868             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1869 1034         9230 push @range_regexp, _octets($length,$first,$max,$min,$max);
1870             }
1871              
1872             # **********************
1873             # min________________max
1874             # FIRST_____________LAST
1875             # **********************
1876              
1877             elsif (($min eq $first) and ($max eq $last)) {
1878 20         78 push @range_regexp, _octets($length,$first,$last,$min,$max);
1879             }
1880              
1881             # *********
1882             # min___max
1883             # FIRST_____________LAST
1884             # *********
1885              
1886             elsif (($first le $min) and ($max le $last)) {
1887 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1888             }
1889              
1890             # **********************
1891             # min__________________________max
1892             # FIRST_____________LAST
1893             # **********************
1894              
1895             elsif (($min le $first) and ($last le $max)) {
1896 20         39 push @range_regexp, _octets($length,$first,$last,$min,$max);
1897             }
1898              
1899             # *********
1900             # min________max
1901             # FIRST_____________LAST
1902             # *********
1903              
1904             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1905 588         1461 push @range_regexp, _octets($length,$min,$last,$min,$max);
1906             }
1907              
1908             # min___max
1909             # FIRST_____________LAST
1910             # (nothing)
1911              
1912             elsif ($last lt $min) {
1913             }
1914              
1915             else {
1916 40         95 die __FILE__, ": subroutine _range_regexp panic.\n";
1917             }
1918             }
1919              
1920 0         0 return @range_regexp;
1921             }
1922              
1923             #
1924             # GBK open character list for qr and not qr
1925             #
1926             sub _charlist {
1927              
1928 517     758   1220 my $modifier = pop @_;
1929 758         1180 my @char = @_;
1930              
1931 758 100       1834 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1932              
1933             # unescape character
1934 758         1821 for (my $i=0; $i <= $#char; $i++) {
1935              
1936             # escape - to ...
1937 758 100 100     2300 if ($char[$i] eq '-') {
    50          
    50          
    50          
    50          
    50          
    100          
    50          
    100          
    100          
    100          
    100          
1938 2648 100 100     18817 if ((0 < $i) and ($i < $#char)) {
1939 522         1905 $char[$i] = '...';
1940             }
1941             }
1942              
1943             # octal escape sequence
1944             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1945 497         1105 $char[$i] = octchr($1);
1946             }
1947              
1948             # hexadecimal escape sequence
1949             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1950 0         0 $char[$i] = hexchr($1);
1951             }
1952              
1953             # \b{...} --> b\{...}
1954             # \B{...} --> B\{...}
1955             # \N{CHARNAME} --> N\{CHARNAME}
1956             # \p{PROPERTY} --> p\{PROPERTY}
1957             # \P{PROPERTY} --> P\{PROPERTY}
1958             elsif ($char[$i] =~ /\A \\ ([bBNpP]) ( \{ ([^\x81-\xFE0-9\}][^\x81-\xFE\}]*) \} ) \z/oxms) {
1959 0         0 $char[$i] = $1 . '\\' . $2;
1960             }
1961              
1962             # \p, \P, \X --> p, P, X
1963             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1964 0         0 $char[$i] = $1;
1965             }
1966              
1967             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1968 0         0 $char[$i] = CORE::chr oct $1;
1969             }
1970             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1971 0         0 $char[$i] = CORE::chr hex $1;
1972             }
1973             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1974 206         1013 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1975             }
1976             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1977             $char[$i] = {
1978             '\0' => "\0",
1979             '\n' => "\n",
1980             '\r' => "\r",
1981             '\t' => "\t",
1982             '\f' => "\f",
1983             '\b' => "\x08", # \b means backspace in character class
1984             '\a' => "\a",
1985             '\e' => "\e",
1986             '\d' => '[0-9]',
1987              
1988             # Vertical tabs are now whitespace
1989             # \s in a regex now matches a vertical tab in all circumstances.
1990             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1991             # \t \n \v \f \r space
1992             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1993             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1994             '\s' => '\s',
1995              
1996             '\w' => '[0-9A-Z_a-z]',
1997             '\D' => '${Egbk::eD}',
1998             '\S' => '${Egbk::eS}',
1999             '\W' => '${Egbk::eW}',
2000              
2001             '\H' => '${Egbk::eH}',
2002             '\V' => '${Egbk::eV}',
2003             '\h' => '[\x09\x20]',
2004             '\v' => '[\x0A\x0B\x0C\x0D]',
2005             '\R' => '${Egbk::eR}',
2006              
2007 0         0 }->{$1};
2008             }
2009              
2010             # POSIX-style character classes
2011             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
2012             $char[$i] = {
2013              
2014             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
2015             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
2016             '[:^lower:]' => '${Egbk::not_lower_i}',
2017             '[:^upper:]' => '${Egbk::not_upper_i}',
2018              
2019 33         572 }->{$1};
2020             }
2021             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
2022             $char[$i] = {
2023              
2024             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
2025             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
2026             '[:ascii:]' => '[\x00-\x7F]',
2027             '[:blank:]' => '[\x09\x20]',
2028             '[:cntrl:]' => '[\x00-\x1F\x7F]',
2029             '[:digit:]' => '[\x30-\x39]',
2030             '[:graph:]' => '[\x21-\x7F]',
2031             '[:lower:]' => '[\x61-\x7A]',
2032             '[:print:]' => '[\x20-\x7F]',
2033             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
2034              
2035             # P.174 POSIX-Style Character Classes
2036             # in Chapter 5: Pattern Matching
2037             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2038              
2039             # P.311 11.2.4 Character Classes and other Special Escapes
2040             # in Chapter 11: perlre: Perl regular expressions
2041             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2042              
2043             # P.210 POSIX-Style Character Classes
2044             # in Chapter 5: Pattern Matching
2045             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2046              
2047             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
2048              
2049             '[:upper:]' => '[\x41-\x5A]',
2050             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
2051             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
2052             '[:^alnum:]' => '${Egbk::not_alnum}',
2053             '[:^alpha:]' => '${Egbk::not_alpha}',
2054             '[:^ascii:]' => '${Egbk::not_ascii}',
2055             '[:^blank:]' => '${Egbk::not_blank}',
2056             '[:^cntrl:]' => '${Egbk::not_cntrl}',
2057             '[:^digit:]' => '${Egbk::not_digit}',
2058             '[:^graph:]' => '${Egbk::not_graph}',
2059             '[:^lower:]' => '${Egbk::not_lower}',
2060             '[:^print:]' => '${Egbk::not_print}',
2061             '[:^punct:]' => '${Egbk::not_punct}',
2062             '[:^space:]' => '${Egbk::not_space}',
2063             '[:^upper:]' => '${Egbk::not_upper}',
2064             '[:^word:]' => '${Egbk::not_word}',
2065             '[:^xdigit:]' => '${Egbk::not_xdigit}',
2066              
2067 8         79 }->{$1};
2068             }
2069             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
2070 70         1819 $char[$i] = $1;
2071             }
2072             }
2073              
2074             # open character list
2075 7         31 my @singleoctet = ();
2076 758         1410 my @multipleoctet = ();
2077 758         1073 for (my $i=0; $i <= $#char; ) {
2078              
2079             # escaped -
2080 758 100 100     1675 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    100          
    100          
    50          
    50          
    100          
2081 2151         9961 $i += 1;
2082 497         702 next;
2083             }
2084              
2085             # make range regexp
2086             elsif ($char[$i] eq '...') {
2087              
2088             # range error
2089 497 50       1009 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    100          
2090 497         1845 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2091             }
2092             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
2093 0 50       0 if ($char[$i-1] gt $char[$i+1]) {
2094 477         1155 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
2095             }
2096             }
2097              
2098             # make range regexp per length
2099 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
2100 497         1432 my @regexp = ();
2101              
2102             # is first and last
2103 517 100 100     815 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    100 33        
    50          
    50          
2104 517         1996 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
2105             }
2106              
2107             # is first
2108             elsif ($length == CORE::length($char[$i-1])) {
2109 477         1335 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
2110             }
2111              
2112             # is inside in first and last
2113             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
2114 20         112 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
2115             }
2116              
2117             # is last
2118             elsif ($length == CORE::length($char[$i+1])) {
2119 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
2120             }
2121              
2122             else {
2123 20         60 die __FILE__, ": subroutine make_regexp panic.\n";
2124             }
2125              
2126 0 100       0 if ($length == 1) {
2127 517         1130 push @singleoctet, @regexp;
2128             }
2129             else {
2130 386         1103 push @multipleoctet, @regexp;
2131             }
2132             }
2133              
2134 131         350 $i += 2;
2135             }
2136              
2137             # with /i modifier
2138             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
2139 497 100       1690 if ($modifier =~ /i/oxms) {
2140 764         1218 my $uc = Egbk::uc($char[$i]);
2141 192         371 my $fc = Egbk::fc($char[$i]);
2142 192 50       388 if ($uc ne $fc) {
2143 192 50       369 if (CORE::length($fc) == 1) {
2144 192         314 push @singleoctet, $uc, $fc;
2145             }
2146             else {
2147 192         447 push @singleoctet, $uc;
2148 0         0 push @multipleoctet, $fc;
2149             }
2150             }
2151             else {
2152 0         0 push @singleoctet, $char[$i];
2153             }
2154             }
2155             else {
2156 0         0 push @singleoctet, $char[$i];
2157             }
2158 572         861 $i += 1;
2159             }
2160              
2161             # single character of single octet code
2162             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
2163 764         1370 push @singleoctet, "\t", "\x20";
2164 0         0 $i += 1;
2165             }
2166             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
2167 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
2168 0         0 $i += 1;
2169             }
2170             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
2171 0         0 push @singleoctet, $char[$i];
2172 2         7 $i += 1;
2173             }
2174              
2175             # single character of multiple-octet code
2176             else {
2177 2         5 push @multipleoctet, $char[$i];
2178 391         773 $i += 1;
2179             }
2180             }
2181              
2182             # quote metachar
2183 391         775 for (@singleoctet) {
2184 758 50       1663 if ($_ eq '...') {
    100          
    100          
    100          
    100          
2185 1364         5892 $_ = '-';
2186             }
2187             elsif (/\A \n \z/oxms) {
2188 0         0 $_ = '\n';
2189             }
2190             elsif (/\A \r \z/oxms) {
2191 8         17 $_ = '\r';
2192             }
2193             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
2194 8         19 $_ = sprintf('\x%02X', CORE::ord $1);
2195             }
2196             elsif (/\A [\x00-\xFF] \z/oxms) {
2197 1         6 $_ = quotemeta $_;
2198             }
2199             }
2200 939         1432 for (@multipleoctet) {
2201 758 100       1409 if (/\A ([\x80-\xFF].*) ([\x00-\xFF]) \z/oxms) {
2202 693         2003 $_ = $1 . quotemeta $2;
2203             }
2204             }
2205              
2206             # return character list
2207 307         841 return \@singleoctet, \@multipleoctet;
2208             }
2209              
2210             #
2211             # GBK octal escape sequence
2212             #
2213             sub octchr {
2214 758     5 0 2737 my($octdigit) = @_;
2215              
2216 5         13 my @binary = ();
2217 5         9 for my $octal (split(//,$octdigit)) {
2218             push @binary, {
2219             '0' => '000',
2220             '1' => '001',
2221             '2' => '010',
2222             '3' => '011',
2223             '4' => '100',
2224             '5' => '101',
2225             '6' => '110',
2226             '7' => '111',
2227 5         23 }->{$octal};
2228             }
2229 50         174 my $binary = join '', @binary;
2230              
2231             my $octchr = {
2232             # 1234567
2233             1 => pack('B*', "0000000$binary"),
2234             2 => pack('B*', "000000$binary"),
2235             3 => pack('B*', "00000$binary"),
2236             4 => pack('B*', "0000$binary"),
2237             5 => pack('B*', "000$binary"),
2238             6 => pack('B*', "00$binary"),
2239             7 => pack('B*', "0$binary"),
2240             0 => pack('B*', "$binary"),
2241              
2242 5         15 }->{CORE::length($binary) % 8};
2243              
2244 5         67 return $octchr;
2245             }
2246              
2247             #
2248             # GBK hexadecimal escape sequence
2249             #
2250             sub hexchr {
2251 5     5 0 21 my($hexdigit) = @_;
2252              
2253             my $hexchr = {
2254             1 => pack('H*', "0$hexdigit"),
2255             0 => pack('H*', "$hexdigit"),
2256              
2257 5         16 }->{CORE::length($_[0]) % 2};
2258              
2259 5         50 return $hexchr;
2260             }
2261              
2262             #
2263             # GBK open character list for qr
2264             #
2265             sub charlist_qr {
2266              
2267 5     519 0 31 my $modifier = pop @_;
2268 519         1179 my @char = @_;
2269              
2270 519         1419 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2271 519         1557 my @singleoctet = @$singleoctet;
2272 519         1164 my @multipleoctet = @$multipleoctet;
2273              
2274             # return character list
2275 519 100       886 if (scalar(@singleoctet) >= 1) {
2276              
2277             # with /i modifier
2278 519 100       1370 if ($modifier =~ m/i/oxms) {
2279 384         852 my %singleoctet_ignorecase = ();
2280 107         178 for (@singleoctet) {
2281 107   100     192 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2282 272         1032 for my $ord (hex($1) .. hex($2)) {
2283 80         328 my $char = CORE::chr($ord);
2284 1046         1574 my $uc = Egbk::uc($char);
2285 1046         1596 my $fc = Egbk::fc($char);
2286 1046 100       1718 if ($uc eq $fc) {
2287 1046         1775 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2288             }
2289             else {
2290 457 50       1225 if (CORE::length($fc) == 1) {
2291 589         882 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2292 589         1383 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2293             }
2294             else {
2295 589         1651 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2296 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2297             }
2298             }
2299             }
2300             }
2301 0 100       0 if ($_ ne '') {
2302 272         506 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2303             }
2304             }
2305 192         539 my $i = 0;
2306 107         234 my @singleoctet_ignorecase = ();
2307 107         180 for my $ord (0 .. 255) {
2308 107 100       241 if (exists $singleoctet_ignorecase{$ord}) {
2309 27392         36615 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1683  
2310             }
2311             else {
2312 1577         2831 $i++;
2313             }
2314             }
2315 25815         29555 @singleoctet = ();
2316 107         193 for my $range (@singleoctet_ignorecase) {
2317 107 100       283 if (ref $range) {
2318 11412 100       20700 if (scalar(@{$range}) == 1) {
  214 50       260  
2319 214         376 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         10  
2320             }
2321 5         71 elsif (scalar(@{$range}) == 2) {
2322 209         339 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2323             }
2324             else {
2325 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         271  
  209         301  
2326             }
2327             }
2328             }
2329             }
2330              
2331 209         1131 my $not_anchor = '';
2332 384         623 $not_anchor = '(?![\x81-\xFE])';
2333              
2334 384         514 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
2335             }
2336 384 100       1035 if (scalar(@multipleoctet) >= 2) {
2337 519         1150 return '(?:' . join('|', @multipleoctet) . ')';
2338             }
2339             else {
2340 131         923 return $multipleoctet[0];
2341             }
2342             }
2343              
2344             #
2345             # GBK open character list for not qr
2346             #
2347             sub charlist_not_qr {
2348              
2349 388     239 0 1784 my $modifier = pop @_;
2350 239         523 my @char = @_;
2351              
2352 239         626 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
2353 239         601 my @singleoctet = @$singleoctet;
2354 239         531 my @multipleoctet = @$multipleoctet;
2355              
2356             # with /i modifier
2357 239 100       401 if ($modifier =~ m/i/oxms) {
2358 239         707 my %singleoctet_ignorecase = ();
2359 128         231 for (@singleoctet) {
2360 128   100     196 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
2361 272         1003 for my $ord (hex($1) .. hex($2)) {
2362 80         321 my $char = CORE::chr($ord);
2363 1046         1521 my $uc = Egbk::uc($char);
2364 1046         1491 my $fc = Egbk::fc($char);
2365 1046 100       1649 if ($uc eq $fc) {
2366 1046         1671 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
2367             }
2368             else {
2369 457 50       1133 if (CORE::length($fc) == 1) {
2370 589         801 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2371 589         1525 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
2372             }
2373             else {
2374 589         1564 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
2375 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
2376             }
2377             }
2378             }
2379             }
2380 0 100       0 if ($_ ne '') {
2381 272         532 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
2382             }
2383             }
2384 192         567 my $i = 0;
2385 128         177 my @singleoctet_ignorecase = ();
2386 128         261 for my $ord (0 .. 255) {
2387 128 100       238 if (exists $singleoctet_ignorecase{$ord}) {
2388 32768         43231 push @{$singleoctet_ignorecase[$i]}, $ord;
  1577         1594  
2389             }
2390             else {
2391 1577         2690 $i++;
2392             }
2393             }
2394 31191         35090 @singleoctet = ();
2395 128         211 for my $range (@singleoctet_ignorecase) {
2396 128 100       325 if (ref $range) {
2397 11412 100       19687 if (scalar(@{$range}) == 1) {
  214 50       236  
2398 214         375 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  5         6  
2399             }
2400 5         58 elsif (scalar(@{$range}) == 2) {
2401 209         294 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
2402             }
2403             else {
2404 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  209         267  
  209         279  
2405             }
2406             }
2407             }
2408             }
2409              
2410             # return character list
2411 209 100       1021 if (scalar(@multipleoctet) >= 1) {
2412 239 100       575 if (scalar(@singleoctet) >= 1) {
2413              
2414             # any character other than multiple-octet and single octet character class
2415 114         274 return '(?!' . join('|', @multipleoctet) . ')(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2416             }
2417             else {
2418              
2419             # any character other than multiple-octet character class
2420 70         545 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
2421             }
2422             }
2423             else {
2424 44 50       319 if (scalar(@singleoctet) >= 1) {
2425              
2426             # any character other than single octet character class
2427 125         245 return '(?:[^\x81-\xFE' . join('', @singleoctet) . ']|[\x81-\xFE][\x00-\xFF])';
2428             }
2429             else {
2430              
2431             # any character
2432 125         801 return "(?:$your_char)";
2433             }
2434             }
2435             }
2436              
2437             #
2438             # open file in read mode
2439             #
2440             sub _open_r {
2441 0     772   0 my(undef,$file) = @_;
2442 391     391   4332 use Fcntl qw(O_RDONLY);
  391         2400  
  391         64792  
2443 772         2231 return CORE::sysopen($_[0], $file, &O_RDONLY);
2444             }
2445              
2446             #
2447             # open file in append mode
2448             #
2449             sub _open_a {
2450 772     386   32145 my(undef,$file) = @_;
2451 391     391   6196 use Fcntl qw(O_WRONLY O_APPEND O_CREAT);
  391         773  
  391         5579821  
2452 386         1287 return CORE::sysopen($_[0], $file, &O_WRONLY|&O_APPEND|&O_CREAT);
2453             }
2454              
2455             #
2456             # safe system
2457             #
2458             sub _systemx {
2459              
2460             # P.707 29.2.33. exec
2461             # in Chapter 29: Functions
2462             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2463             #
2464             # Be aware that in older releases of Perl, exec (and system) did not flush
2465             # your output buffer, so you needed to enable command buffering by setting $|
2466             # on one or more filehandles to avoid lost output in the case of exec, or
2467             # misordererd output in the case of system. This situation was largely remedied
2468             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2469              
2470             # P.855 exec
2471             # in Chapter 27: Functions
2472             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2473             #
2474             # In very old release of Perl (before v5.6), exec (and system) did not flush
2475             # your output buffer, so you needed to enable command buffering by setting $|
2476             # on one or more filehandles to avoid lost output with exec or misordered
2477             # output with system.
2478              
2479 386     386   50022 $| = 1;
2480              
2481             # P.565 23.1.2. Cleaning Up Your Environment
2482             # in Chapter 23: Security
2483             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2484              
2485             # P.656 Cleaning Up Your Environment
2486             # in Chapter 20: Security
2487             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2488              
2489             # local $ENV{'PATH'} = '.';
2490 386         1805 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2491              
2492             # P.707 29.2.33. exec
2493             # in Chapter 29: Functions
2494             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2495             #
2496             # As we mentioned earlier, exec treats a discrete list of arguments as an
2497             # indication that it should bypass shell processing. However, there is one
2498             # place where you might still get tripped up. The exec call (and system, too)
2499             # will not distinguish between a single scalar argument and an array containing
2500             # only one element.
2501             #
2502             # @args = ("echo surprise"); # just one element in list
2503             # exec @args # still subject to shell escapes
2504             # or die "exec: $!"; # because @args == 1
2505             #
2506             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2507             # first argument as the pathname, which forces the rest of the arguments to be
2508             # interpreted as a list, even if there is only one of them:
2509             #
2510             # exec { $args[0] } @args # safe even with one-argument list
2511             # or die "can't exec @args: $!";
2512              
2513             # P.855 exec
2514             # in Chapter 27: Functions
2515             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2516             #
2517             # As we mentioned earlier, exec treats a discrete list of arguments as a
2518             # directive to bypass shell processing. However, there is one place where
2519             # you might still get tripped up. The exec call (and system, too) cannot
2520             # distinguish between a single scalar argument and an array containing
2521             # only one element.
2522             #
2523             # @args = ("echo surprise"); # just one element in list
2524             # exec @args # still subject to shell escapes
2525             # || die "exec: $!"; # because @args == 1
2526             #
2527             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2528             # argument as the pathname, which forces the rest of the arguments to be
2529             # interpreted as a list, even if there is only one of them:
2530             #
2531             # exec { $args[0] } @args # safe even with one-argument list
2532             # || die "can't exec @args: $!";
2533              
2534 386         3937 return CORE::system { $_[0] } @_; # safe even with one-argument list
  386         1093  
2535             }
2536              
2537             #
2538             # GBK order to character (with parameter)
2539             #
2540             sub Egbk::chr(;$) {
2541              
2542 386 0   0 0 40704360 my $c = @_ ? $_[0] : $_;
2543              
2544 0 0       0 if ($c == 0x00) {
2545 0         0 return "\x00";
2546             }
2547             else {
2548 0         0 my @chr = ();
2549 0         0 while ($c > 0) {
2550 0         0 unshift @chr, ($c % 0x100);
2551 0         0 $c = int($c / 0x100);
2552             }
2553 0         0 return pack 'C*', @chr;
2554             }
2555             }
2556              
2557             #
2558             # GBK order to character (without parameter)
2559             #
2560             sub Egbk::chr_() {
2561              
2562 0     0 0 0 my $c = $_;
2563              
2564 0 0       0 if ($c == 0x00) {
2565 0         0 return "\x00";
2566             }
2567             else {
2568 0         0 my @chr = ();
2569 0         0 while ($c > 0) {
2570 0         0 unshift @chr, ($c % 0x100);
2571 0         0 $c = int($c / 0x100);
2572             }
2573 0         0 return pack 'C*', @chr;
2574             }
2575             }
2576              
2577             #
2578             # GBK stacked file test expr
2579             #
2580             sub Egbk::filetest {
2581              
2582 0     0 0 0 my $file = pop @_;
2583 0         0 my $filetest = substr(pop @_, 1);
2584              
2585 0 0       0 unless (CORE::eval qq{Egbk::$filetest(\$file)}) {
2586 0         0 return '';
2587             }
2588 0         0 for my $filetest (CORE::reverse @_) {
2589 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
2590 0         0 return '';
2591             }
2592             }
2593 0         0 return 1;
2594             }
2595              
2596             #
2597             # GBK file test -r expr
2598             #
2599             sub Egbk::r(;*@) {
2600              
2601 0 0   0 0 0 local $_ = shift if @_;
2602 0 0 0     0 croak 'Too many arguments for -r (Egbk::r)' if @_ and not wantarray;
2603              
2604 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2605 0 0       0 return wantarray ? (-r _,@_) : -r _;
2606             }
2607              
2608             # P.908 32.39. Symbol
2609             # in Chapter 32: Standard Modules
2610             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2611              
2612             # P.326 Prototypes
2613             # in Chapter 7: Subroutines
2614             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2615              
2616             # (and so on)
2617              
2618             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2619 0 0       0 return wantarray ? (-r $fh,@_) : -r $fh;
2620             }
2621             elsif (-e $_) {
2622 0 0       0 return wantarray ? (-r _,@_) : -r _;
2623             }
2624             elsif (_MSWin32_5Cended_path($_)) {
2625 0 0       0 if (-d "$_/.") {
2626 0 0       0 return wantarray ? (-r _,@_) : -r _;
2627             }
2628             else {
2629              
2630             # Even if ${^WIN32_SLOPPY_STAT} is set to a true value, Egbk::*()
2631             # on Windows opens the file for the path which has 5c at end.
2632             # (and so on)
2633              
2634 0         0 my $fh = gensym();
2635 0 0       0 if (_open_r($fh, $_)) {
2636 0         0 my $r = -r $fh;
2637 0 0       0 close($fh) or die "Can't close file: $_: $!";
2638 0 0       0 return wantarray ? ($r,@_) : $r;
2639             }
2640             }
2641             }
2642 0 0       0 return wantarray ? (undef,@_) : undef;
2643             }
2644              
2645             #
2646             # GBK file test -w expr
2647             #
2648             sub Egbk::w(;*@) {
2649              
2650 0 0   0 0 0 local $_ = shift if @_;
2651 0 0 0     0 croak 'Too many arguments for -w (Egbk::w)' if @_ and not wantarray;
2652              
2653 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2654 0 0       0 return wantarray ? (-w _,@_) : -w _;
2655             }
2656             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2657 0 0       0 return wantarray ? (-w $fh,@_) : -w $fh;
2658             }
2659             elsif (-e $_) {
2660 0 0       0 return wantarray ? (-w _,@_) : -w _;
2661             }
2662             elsif (_MSWin32_5Cended_path($_)) {
2663 0 0       0 if (-d "$_/.") {
2664 0 0       0 return wantarray ? (-w _,@_) : -w _;
2665             }
2666             else {
2667 0         0 my $fh = gensym();
2668 0 0       0 if (_open_a($fh, $_)) {
2669 0         0 my $w = -w $fh;
2670 0 0       0 close($fh) or die "Can't close file: $_: $!";
2671 0 0       0 return wantarray ? ($w,@_) : $w;
2672             }
2673             }
2674             }
2675 0 0       0 return wantarray ? (undef,@_) : undef;
2676             }
2677              
2678             #
2679             # GBK file test -x expr
2680             #
2681             sub Egbk::x(;*@) {
2682              
2683 0 0   0 0 0 local $_ = shift if @_;
2684 0 0 0     0 croak 'Too many arguments for -x (Egbk::x)' if @_ and not wantarray;
2685              
2686 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2687 0 0       0 return wantarray ? (-x _,@_) : -x _;
2688             }
2689             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2690 0 0       0 return wantarray ? (-x $fh,@_) : -x $fh;
2691             }
2692             elsif (-e $_) {
2693 0 0       0 return wantarray ? (-x _,@_) : -x _;
2694             }
2695             elsif (_MSWin32_5Cended_path($_)) {
2696 0 0       0 if (-d "$_/.") {
2697 0 0       0 return wantarray ? (-x _,@_) : -x _;
2698             }
2699             else {
2700 0         0 my $fh = gensym();
2701 0 0       0 if (_open_r($fh, $_)) {
2702 0         0 my $dummy_for_underline_cache = -x $fh;
2703 0 0       0 close($fh) or die "Can't close file: $_: $!";
2704             }
2705              
2706             # filename is not .COM .EXE .BAT .CMD
2707 0 0       0 return wantarray ? ('',@_) : '';
2708             }
2709             }
2710 0 0       0 return wantarray ? (undef,@_) : undef;
2711             }
2712              
2713             #
2714             # GBK file test -o expr
2715             #
2716             sub Egbk::o(;*@) {
2717              
2718 0 0   0 0 0 local $_ = shift if @_;
2719 0 0 0     0 croak 'Too many arguments for -o (Egbk::o)' if @_ and not wantarray;
2720              
2721 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2722 0 0       0 return wantarray ? (-o _,@_) : -o _;
2723             }
2724             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2725 0 0       0 return wantarray ? (-o $fh,@_) : -o $fh;
2726             }
2727             elsif (-e $_) {
2728 0 0       0 return wantarray ? (-o _,@_) : -o _;
2729             }
2730             elsif (_MSWin32_5Cended_path($_)) {
2731 0 0       0 if (-d "$_/.") {
2732 0 0       0 return wantarray ? (-o _,@_) : -o _;
2733             }
2734             else {
2735 0         0 my $fh = gensym();
2736 0 0       0 if (_open_r($fh, $_)) {
2737 0         0 my $o = -o $fh;
2738 0 0       0 close($fh) or die "Can't close file: $_: $!";
2739 0 0       0 return wantarray ? ($o,@_) : $o;
2740             }
2741             }
2742             }
2743 0 0       0 return wantarray ? (undef,@_) : undef;
2744             }
2745              
2746             #
2747             # GBK file test -R expr
2748             #
2749             sub Egbk::R(;*@) {
2750              
2751 0 0   0 0 0 local $_ = shift if @_;
2752 0 0 0     0 croak 'Too many arguments for -R (Egbk::R)' if @_ and not wantarray;
2753              
2754 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2755 0 0       0 return wantarray ? (-R _,@_) : -R _;
2756             }
2757             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2758 0 0       0 return wantarray ? (-R $fh,@_) : -R $fh;
2759             }
2760             elsif (-e $_) {
2761 0 0       0 return wantarray ? (-R _,@_) : -R _;
2762             }
2763             elsif (_MSWin32_5Cended_path($_)) {
2764 0 0       0 if (-d "$_/.") {
2765 0 0       0 return wantarray ? (-R _,@_) : -R _;
2766             }
2767             else {
2768 0         0 my $fh = gensym();
2769 0 0       0 if (_open_r($fh, $_)) {
2770 0         0 my $R = -R $fh;
2771 0 0       0 close($fh) or die "Can't close file: $_: $!";
2772 0 0       0 return wantarray ? ($R,@_) : $R;
2773             }
2774             }
2775             }
2776 0 0       0 return wantarray ? (undef,@_) : undef;
2777             }
2778              
2779             #
2780             # GBK file test -W expr
2781             #
2782             sub Egbk::W(;*@) {
2783              
2784 0 0   0 0 0 local $_ = shift if @_;
2785 0 0 0     0 croak 'Too many arguments for -W (Egbk::W)' if @_ and not wantarray;
2786              
2787 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2788 0 0       0 return wantarray ? (-W _,@_) : -W _;
2789             }
2790             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2791 0 0       0 return wantarray ? (-W $fh,@_) : -W $fh;
2792             }
2793             elsif (-e $_) {
2794 0 0       0 return wantarray ? (-W _,@_) : -W _;
2795             }
2796             elsif (_MSWin32_5Cended_path($_)) {
2797 0 0       0 if (-d "$_/.") {
2798 0 0       0 return wantarray ? (-W _,@_) : -W _;
2799             }
2800             else {
2801 0         0 my $fh = gensym();
2802 0 0       0 if (_open_a($fh, $_)) {
2803 0         0 my $W = -W $fh;
2804 0 0       0 close($fh) or die "Can't close file: $_: $!";
2805 0 0       0 return wantarray ? ($W,@_) : $W;
2806             }
2807             }
2808             }
2809 0 0       0 return wantarray ? (undef,@_) : undef;
2810             }
2811              
2812             #
2813             # GBK file test -X expr
2814             #
2815             sub Egbk::X(;*@) {
2816              
2817 0 0   0 1 0 local $_ = shift if @_;
2818 0 0 0     0 croak 'Too many arguments for -X (Egbk::X)' if @_ and not wantarray;
2819              
2820 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2821 0 0       0 return wantarray ? (-X _,@_) : -X _;
2822             }
2823             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2824 0 0       0 return wantarray ? (-X $fh,@_) : -X $fh;
2825             }
2826             elsif (-e $_) {
2827 0 0       0 return wantarray ? (-X _,@_) : -X _;
2828             }
2829             elsif (_MSWin32_5Cended_path($_)) {
2830 0 0       0 if (-d "$_/.") {
2831 0 0       0 return wantarray ? (-X _,@_) : -X _;
2832             }
2833             else {
2834 0         0 my $fh = gensym();
2835 0 0       0 if (_open_r($fh, $_)) {
2836 0         0 my $dummy_for_underline_cache = -X $fh;
2837 0 0       0 close($fh) or die "Can't close file: $_: $!";
2838             }
2839              
2840             # filename is not .COM .EXE .BAT .CMD
2841 0 0       0 return wantarray ? ('',@_) : '';
2842             }
2843             }
2844 0 0       0 return wantarray ? (undef,@_) : undef;
2845             }
2846              
2847             #
2848             # GBK file test -O expr
2849             #
2850             sub Egbk::O(;*@) {
2851              
2852 0 0   0 0 0 local $_ = shift if @_;
2853 0 0 0     0 croak 'Too many arguments for -O (Egbk::O)' if @_ and not wantarray;
2854              
2855 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2856 0 0       0 return wantarray ? (-O _,@_) : -O _;
2857             }
2858             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2859 0 0       0 return wantarray ? (-O $fh,@_) : -O $fh;
2860             }
2861             elsif (-e $_) {
2862 0 0       0 return wantarray ? (-O _,@_) : -O _;
2863             }
2864             elsif (_MSWin32_5Cended_path($_)) {
2865 0 0       0 if (-d "$_/.") {
2866 0 0       0 return wantarray ? (-O _,@_) : -O _;
2867             }
2868             else {
2869 0         0 my $fh = gensym();
2870 0 0       0 if (_open_r($fh, $_)) {
2871 0         0 my $O = -O $fh;
2872 0 0       0 close($fh) or die "Can't close file: $_: $!";
2873 0 0       0 return wantarray ? ($O,@_) : $O;
2874             }
2875             }
2876             }
2877 0 0       0 return wantarray ? (undef,@_) : undef;
2878             }
2879              
2880             #
2881             # GBK file test -e expr
2882             #
2883             sub Egbk::e(;*@) {
2884              
2885 0 50   772 0 0 local $_ = shift if @_;
2886 772 50 33     3432 croak 'Too many arguments for -e (Egbk::e)' if @_ and not wantarray;
2887              
2888 772         2848 local $^W = 0;
2889 772     772   5795 local $SIG{__WARN__} = sub {}; # telldir() attempted on invalid dirhandle at here
2890              
2891 772         5039 my $fh = qualify_to_ref $_;
2892 772 50       2448 if ($_ eq '_') {
    50          
    50          
    50          
    50          
2893 772 0       3220 return wantarray ? (-e _,@_) : -e _;
2894             }
2895              
2896             # return false if directory handle
2897             elsif (defined Egbk::telldir($fh)) {
2898 0 0       0 return wantarray ? ('',@_) : '';
2899             }
2900              
2901             # return true if file handle
2902             elsif (defined fileno $fh) {
2903 0 0       0 return wantarray ? (1,@_) : 1;
2904             }
2905              
2906             elsif (-e $_) {
2907 0 0       0 return wantarray ? (1,@_) : 1;
2908             }
2909             elsif (_MSWin32_5Cended_path($_)) {
2910 0 0       0 if (-d "$_/.") {
2911 0 0       0 return wantarray ? (1,@_) : 1;
2912             }
2913             else {
2914 0         0 my $fh = gensym();
2915 0 0       0 if (_open_r($fh, $_)) {
2916 0         0 my $e = -e $fh;
2917 0 0       0 close($fh) or die "Can't close file: $_: $!";
2918 0 0       0 return wantarray ? ($e,@_) : $e;
2919             }
2920             }
2921             }
2922 0 50       0 return wantarray ? (undef,@_) : undef;
2923             }
2924              
2925             #
2926             # GBK file test -z expr
2927             #
2928             sub Egbk::z(;*@) {
2929              
2930 772 0   0 0 6723 local $_ = shift if @_;
2931 0 0 0     0 croak 'Too many arguments for -z (Egbk::z)' if @_ and not wantarray;
2932              
2933 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2934 0 0       0 return wantarray ? (-z _,@_) : -z _;
2935             }
2936             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2937 0 0       0 return wantarray ? (-z $fh,@_) : -z $fh;
2938             }
2939             elsif (-e $_) {
2940 0 0       0 return wantarray ? (-z _,@_) : -z _;
2941             }
2942             elsif (_MSWin32_5Cended_path($_)) {
2943 0 0       0 if (-d "$_/.") {
2944 0 0       0 return wantarray ? (-z _,@_) : -z _;
2945             }
2946             else {
2947 0         0 my $fh = gensym();
2948 0 0       0 if (_open_r($fh, $_)) {
2949 0         0 my $z = -z $fh;
2950 0 0       0 close($fh) or die "Can't close file: $_: $!";
2951 0 0       0 return wantarray ? ($z,@_) : $z;
2952             }
2953             }
2954             }
2955 0 0       0 return wantarray ? (undef,@_) : undef;
2956             }
2957              
2958             #
2959             # GBK file test -s expr
2960             #
2961             sub Egbk::s(;*@) {
2962              
2963 0 0   0 0 0 local $_ = shift if @_;
2964 0 0 0     0 croak 'Too many arguments for -s (Egbk::s)' if @_ and not wantarray;
2965              
2966 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
2967 0 0       0 return wantarray ? (-s _,@_) : -s _;
2968             }
2969             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
2970 0 0       0 return wantarray ? (-s $fh,@_) : -s $fh;
2971             }
2972             elsif (-e $_) {
2973 0 0       0 return wantarray ? (-s _,@_) : -s _;
2974             }
2975             elsif (_MSWin32_5Cended_path($_)) {
2976 0 0       0 if (-d "$_/.") {
2977 0 0       0 return wantarray ? (-s _,@_) : -s _;
2978             }
2979             else {
2980 0         0 my $fh = gensym();
2981 0 0       0 if (_open_r($fh, $_)) {
2982 0         0 my $s = -s $fh;
2983 0 0       0 close($fh) or die "Can't close file: $_: $!";
2984 0 0       0 return wantarray ? ($s,@_) : $s;
2985             }
2986             }
2987             }
2988 0 0       0 return wantarray ? (undef,@_) : undef;
2989             }
2990              
2991             #
2992             # GBK file test -f expr
2993             #
2994             sub Egbk::f(;*@) {
2995              
2996 0 0   0 0 0 local $_ = shift if @_;
2997 0 0 0     0 croak 'Too many arguments for -f (Egbk::f)' if @_ and not wantarray;
2998              
2999 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3000 0 0       0 return wantarray ? (-f _,@_) : -f _;
3001             }
3002             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3003 0 0       0 return wantarray ? (-f $fh,@_) : -f $fh;
3004             }
3005             elsif (-e $_) {
3006 0 0       0 return wantarray ? (-f _,@_) : -f _;
3007             }
3008             elsif (_MSWin32_5Cended_path($_)) {
3009 0 0       0 if (-d "$_/.") {
3010 0 0       0 return wantarray ? ('',@_) : '';
3011             }
3012             else {
3013 0         0 my $fh = gensym();
3014 0 0       0 if (_open_r($fh, $_)) {
3015 0         0 my $f = -f $fh;
3016 0 0       0 close($fh) or die "Can't close file: $_: $!";
3017 0 0       0 return wantarray ? ($f,@_) : $f;
3018             }
3019             }
3020             }
3021 0 0       0 return wantarray ? (undef,@_) : undef;
3022             }
3023              
3024             #
3025             # GBK file test -d expr
3026             #
3027             sub Egbk::d(;*@) {
3028              
3029 0 0   0 0 0 local $_ = shift if @_;
3030 0 0 0     0 croak 'Too many arguments for -d (Egbk::d)' if @_ and not wantarray;
3031              
3032 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3033 0 0       0 return wantarray ? (-d _,@_) : -d _;
3034             }
3035              
3036             # return false if file handle or directory handle
3037             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3038 0 0       0 return wantarray ? ('',@_) : '';
3039             }
3040             elsif (-e $_) {
3041 0 0       0 return wantarray ? (-d _,@_) : -d _;
3042             }
3043             elsif (_MSWin32_5Cended_path($_)) {
3044 0 0       0 return wantarray ? (-d "$_/.",@_) : -d "$_/.";
3045             }
3046 0 0       0 return wantarray ? (undef,@_) : undef;
3047             }
3048              
3049             #
3050             # GBK file test -l expr
3051             #
3052             sub Egbk::l(;*@) {
3053              
3054 0 0   0 0 0 local $_ = shift if @_;
3055 0 0 0     0 croak 'Too many arguments for -l (Egbk::l)' if @_ and not wantarray;
3056              
3057 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3058 0 0       0 return wantarray ? (-l _,@_) : -l _;
3059             }
3060             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3061 0 0       0 return wantarray ? (-l $fh,@_) : -l $fh;
3062             }
3063             elsif (-e $_) {
3064 0 0       0 return wantarray ? (-l _,@_) : -l _;
3065             }
3066             elsif (_MSWin32_5Cended_path($_)) {
3067 0 0       0 if (-d "$_/.") {
3068 0 0       0 return wantarray ? (-l _,@_) : -l _;
3069             }
3070             else {
3071 0         0 my $fh = gensym();
3072 0 0       0 if (_open_r($fh, $_)) {
3073 0         0 my $l = -l $fh;
3074 0 0       0 close($fh) or die "Can't close file: $_: $!";
3075 0 0       0 return wantarray ? ($l,@_) : $l;
3076             }
3077             }
3078             }
3079 0 0       0 return wantarray ? (undef,@_) : undef;
3080             }
3081              
3082             #
3083             # GBK file test -p expr
3084             #
3085             sub Egbk::p(;*@) {
3086              
3087 0 0   0 0 0 local $_ = shift if @_;
3088 0 0 0     0 croak 'Too many arguments for -p (Egbk::p)' if @_ and not wantarray;
3089              
3090 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3091 0 0       0 return wantarray ? (-p _,@_) : -p _;
3092             }
3093             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3094 0 0       0 return wantarray ? (-p $fh,@_) : -p $fh;
3095             }
3096             elsif (-e $_) {
3097 0 0       0 return wantarray ? (-p _,@_) : -p _;
3098             }
3099             elsif (_MSWin32_5Cended_path($_)) {
3100 0 0       0 if (-d "$_/.") {
3101 0 0       0 return wantarray ? (-p _,@_) : -p _;
3102             }
3103             else {
3104 0         0 my $fh = gensym();
3105 0 0       0 if (_open_r($fh, $_)) {
3106 0         0 my $p = -p $fh;
3107 0 0       0 close($fh) or die "Can't close file: $_: $!";
3108 0 0       0 return wantarray ? ($p,@_) : $p;
3109             }
3110             }
3111             }
3112 0 0       0 return wantarray ? (undef,@_) : undef;
3113             }
3114              
3115             #
3116             # GBK file test -S expr
3117             #
3118             sub Egbk::S(;*@) {
3119              
3120 0 0   0 0 0 local $_ = shift if @_;
3121 0 0 0     0 croak 'Too many arguments for -S (Egbk::S)' if @_ and not wantarray;
3122              
3123 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3124 0 0       0 return wantarray ? (-S _,@_) : -S _;
3125             }
3126             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3127 0 0       0 return wantarray ? (-S $fh,@_) : -S $fh;
3128             }
3129             elsif (-e $_) {
3130 0 0       0 return wantarray ? (-S _,@_) : -S _;
3131             }
3132             elsif (_MSWin32_5Cended_path($_)) {
3133 0 0       0 if (-d "$_/.") {
3134 0 0       0 return wantarray ? (-S _,@_) : -S _;
3135             }
3136             else {
3137 0         0 my $fh = gensym();
3138 0 0       0 if (_open_r($fh, $_)) {
3139 0         0 my $S = -S $fh;
3140 0 0       0 close($fh) or die "Can't close file: $_: $!";
3141 0 0       0 return wantarray ? ($S,@_) : $S;
3142             }
3143             }
3144             }
3145 0 0       0 return wantarray ? (undef,@_) : undef;
3146             }
3147              
3148             #
3149             # GBK file test -b expr
3150             #
3151             sub Egbk::b(;*@) {
3152              
3153 0 0   0 0 0 local $_ = shift if @_;
3154 0 0 0     0 croak 'Too many arguments for -b (Egbk::b)' if @_ and not wantarray;
3155              
3156 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3157 0 0       0 return wantarray ? (-b _,@_) : -b _;
3158             }
3159             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3160 0 0       0 return wantarray ? (-b $fh,@_) : -b $fh;
3161             }
3162             elsif (-e $_) {
3163 0 0       0 return wantarray ? (-b _,@_) : -b _;
3164             }
3165             elsif (_MSWin32_5Cended_path($_)) {
3166 0 0       0 if (-d "$_/.") {
3167 0 0       0 return wantarray ? (-b _,@_) : -b _;
3168             }
3169             else {
3170 0         0 my $fh = gensym();
3171 0 0       0 if (_open_r($fh, $_)) {
3172 0         0 my $b = -b $fh;
3173 0 0       0 close($fh) or die "Can't close file: $_: $!";
3174 0 0       0 return wantarray ? ($b,@_) : $b;
3175             }
3176             }
3177             }
3178 0 0       0 return wantarray ? (undef,@_) : undef;
3179             }
3180              
3181             #
3182             # GBK file test -c expr
3183             #
3184             sub Egbk::c(;*@) {
3185              
3186 0 0   0 0 0 local $_ = shift if @_;
3187 0 0 0     0 croak 'Too many arguments for -c (Egbk::c)' if @_ and not wantarray;
3188              
3189 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3190 0 0       0 return wantarray ? (-c _,@_) : -c _;
3191             }
3192             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3193 0 0       0 return wantarray ? (-c $fh,@_) : -c $fh;
3194             }
3195             elsif (-e $_) {
3196 0 0       0 return wantarray ? (-c _,@_) : -c _;
3197             }
3198             elsif (_MSWin32_5Cended_path($_)) {
3199 0 0       0 if (-d "$_/.") {
3200 0 0       0 return wantarray ? (-c _,@_) : -c _;
3201             }
3202             else {
3203 0         0 my $fh = gensym();
3204 0 0       0 if (_open_r($fh, $_)) {
3205 0         0 my $c = -c $fh;
3206 0 0       0 close($fh) or die "Can't close file: $_: $!";
3207 0 0       0 return wantarray ? ($c,@_) : $c;
3208             }
3209             }
3210             }
3211 0 0       0 return wantarray ? (undef,@_) : undef;
3212             }
3213              
3214             #
3215             # GBK file test -u expr
3216             #
3217             sub Egbk::u(;*@) {
3218              
3219 0 0   0 0 0 local $_ = shift if @_;
3220 0 0 0     0 croak 'Too many arguments for -u (Egbk::u)' if @_ and not wantarray;
3221              
3222 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3223 0 0       0 return wantarray ? (-u _,@_) : -u _;
3224             }
3225             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3226 0 0       0 return wantarray ? (-u $fh,@_) : -u $fh;
3227             }
3228             elsif (-e $_) {
3229 0 0       0 return wantarray ? (-u _,@_) : -u _;
3230             }
3231             elsif (_MSWin32_5Cended_path($_)) {
3232 0 0       0 if (-d "$_/.") {
3233 0 0       0 return wantarray ? (-u _,@_) : -u _;
3234             }
3235             else {
3236 0         0 my $fh = gensym();
3237 0 0       0 if (_open_r($fh, $_)) {
3238 0         0 my $u = -u $fh;
3239 0 0       0 close($fh) or die "Can't close file: $_: $!";
3240 0 0       0 return wantarray ? ($u,@_) : $u;
3241             }
3242             }
3243             }
3244 0 0       0 return wantarray ? (undef,@_) : undef;
3245             }
3246              
3247             #
3248             # GBK file test -g expr
3249             #
3250             sub Egbk::g(;*@) {
3251              
3252 0 0   0 0 0 local $_ = shift if @_;
3253 0 0 0     0 croak 'Too many arguments for -g (Egbk::g)' if @_ and not wantarray;
3254              
3255 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3256 0 0       0 return wantarray ? (-g _,@_) : -g _;
3257             }
3258             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3259 0 0       0 return wantarray ? (-g $fh,@_) : -g $fh;
3260             }
3261             elsif (-e $_) {
3262 0 0       0 return wantarray ? (-g _,@_) : -g _;
3263             }
3264             elsif (_MSWin32_5Cended_path($_)) {
3265 0 0       0 if (-d "$_/.") {
3266 0 0       0 return wantarray ? (-g _,@_) : -g _;
3267             }
3268             else {
3269 0         0 my $fh = gensym();
3270 0 0       0 if (_open_r($fh, $_)) {
3271 0         0 my $g = -g $fh;
3272 0 0       0 close($fh) or die "Can't close file: $_: $!";
3273 0 0       0 return wantarray ? ($g,@_) : $g;
3274             }
3275             }
3276             }
3277 0 0       0 return wantarray ? (undef,@_) : undef;
3278             }
3279              
3280             #
3281             # GBK file test -k expr
3282             #
3283             sub Egbk::k(;*@) {
3284              
3285 0 0   0 0 0 local $_ = shift if @_;
3286 0 0 0     0 croak 'Too many arguments for -k (Egbk::k)' if @_ and not wantarray;
3287              
3288 0 0       0 if ($_ eq '_') {
    0          
    0          
3289 0 0       0 return wantarray ? ('',@_) : '';
3290             }
3291             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3292 0 0       0 return wantarray ? ('',@_) : '';
3293             }
3294             elsif ($] =~ /^5\.008/oxms) {
3295 0 0       0 return wantarray ? ('',@_) : '';
3296             }
3297 0 0       0 return wantarray ? ($_,@_) : $_;
3298             }
3299              
3300             #
3301             # GBK file test -T expr
3302             #
3303             sub Egbk::T(;*@) {
3304              
3305 0 0   0 0 0 local $_ = shift if @_;
3306              
3307             # Use of croak without parentheses makes die on Strawberry Perl 5.008 and 5.010, like:
3308             # croak 'Too many arguments for -T (Egbk::T)';
3309             # Must be used by parentheses like:
3310             # croak('Too many arguments for -T (Egbk::T)');
3311              
3312 0 0 0     0 if (@_ and not wantarray) {
3313 0         0 croak('Too many arguments for -T (Egbk::T)');
3314             }
3315              
3316 0         0 my $T = 1;
3317              
3318 0         0 my $fh = qualify_to_ref $_;
3319 0 0       0 if (defined fileno $fh) {
3320              
3321 0     0   0 local $SIG{__WARN__} = sub {}; # telldir() attempted on invalid dirhandle at here
3322 0 0       0 if (defined Egbk::telldir($fh)) {
3323 0 0       0 return wantarray ? (undef,@_) : undef;
3324             }
3325              
3326             # P.813 29.2.176. tell
3327             # in Chapter 29: Functions
3328             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
3329              
3330             # P.970 tell
3331             # in Chapter 27: Functions
3332             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
3333              
3334             # (and so on)
3335              
3336 0         0 my $systell = sysseek $fh, 0, 1;
3337              
3338 0 0       0 if (sysread $fh, my $block, 512) {
3339              
3340             # P.163 Binary file check in Little Perl Parlor 16
3341             # of Book No. T1008901080816 ZASSHI 08901-8 UNIX MAGAZINE 1993 Aug VOL8#8
3342             # (and so on)
3343              
3344 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3345 0         0 $T = '';
3346             }
3347             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3348 0         0 $T = '';
3349             }
3350             }
3351              
3352             # 0 byte or eof
3353             else {
3354 0         0 $T = 1;
3355             }
3356              
3357 0         0 my $dummy_for_underline_cache = -T $fh;
3358 0         0 sysseek $fh, $systell, 0;
3359             }
3360             else {
3361 0 0 0     0 if (-d $_ or -d "$_/.") {
3362 0 0       0 return wantarray ? (undef,@_) : undef;
3363             }
3364              
3365 0         0 $fh = gensym();
3366 0 0       0 if (_open_r($fh, $_)) {
3367             }
3368             else {
3369 0 0       0 return wantarray ? (undef,@_) : undef;
3370             }
3371 0 0       0 if (sysread $fh, my $block, 512) {
3372 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3373 0         0 $T = '';
3374             }
3375             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3376 0         0 $T = '';
3377             }
3378             }
3379              
3380             # 0 byte or eof
3381             else {
3382 0         0 $T = 1;
3383             }
3384 0         0 my $dummy_for_underline_cache = -T $fh;
3385 0 0       0 close($fh) or die "Can't close file: $_: $!";
3386             }
3387              
3388 0 0       0 return wantarray ? ($T,@_) : $T;
3389             }
3390              
3391             #
3392             # GBK file test -B expr
3393             #
3394             sub Egbk::B(;*@) {
3395              
3396 0 0   0 0 0 local $_ = shift if @_;
3397 0 0 0     0 croak 'Too many arguments for -B (Egbk::B)' if @_ and not wantarray;
3398 0         0 my $B = '';
3399              
3400 0         0 my $fh = qualify_to_ref $_;
3401 0 0       0 if (defined fileno $fh) {
3402              
3403 0     0   0 local $SIG{__WARN__} = sub {}; # telldir() attempted on invalid dirhandle at here
3404 0 0       0 if (defined Egbk::telldir($fh)) {
3405 0 0       0 return wantarray ? (undef,@_) : undef;
3406             }
3407              
3408 0         0 my $systell = sysseek $fh, 0, 1;
3409              
3410 0 0       0 if (sysread $fh, my $block, 512) {
3411 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3412 0         0 $B = 1;
3413             }
3414             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3415 0         0 $B = 1;
3416             }
3417             }
3418              
3419             # 0 byte or eof
3420             else {
3421 0         0 $B = 1;
3422             }
3423              
3424 0         0 my $dummy_for_underline_cache = -B $fh;
3425 0         0 sysseek $fh, $systell, 0;
3426             }
3427             else {
3428 0 0 0     0 if (-d $_ or -d "$_/.") {
3429 0 0       0 return wantarray ? (undef,@_) : undef;
3430             }
3431              
3432 0         0 $fh = gensym();
3433 0 0       0 if (_open_r($fh, $_)) {
3434             }
3435             else {
3436 0 0       0 return wantarray ? (undef,@_) : undef;
3437             }
3438 0 0       0 if (sysread $fh, my $block, 512) {
3439 0 0       0 if ($block =~ /[\000\377]/oxms) {
    0          
3440 0         0 $B = 1;
3441             }
3442             elsif (($block =~ tr/\000-\007\013\016-\032\034-\037\377//) * 10 > CORE::length $block) {
3443 0         0 $B = 1;
3444             }
3445             }
3446              
3447             # 0 byte or eof
3448             else {
3449 0         0 $B = 1;
3450             }
3451 0         0 my $dummy_for_underline_cache = -B $fh;
3452 0 0       0 close($fh) or die "Can't close file: $_: $!";
3453             }
3454              
3455 0 0       0 return wantarray ? ($B,@_) : $B;
3456             }
3457              
3458             #
3459             # GBK file test -M expr
3460             #
3461             sub Egbk::M(;*@) {
3462              
3463 0 0   0 0 0 local $_ = shift if @_;
3464 0 0 0     0 croak 'Too many arguments for -M (Egbk::M)' if @_ and not wantarray;
3465              
3466 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3467 0 0       0 return wantarray ? (-M _,@_) : -M _;
3468             }
3469             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3470 0 0       0 return wantarray ? (-M $fh,@_) : -M $fh;
3471             }
3472             elsif (-e $_) {
3473 0 0       0 return wantarray ? (-M _,@_) : -M _;
3474             }
3475             elsif (_MSWin32_5Cended_path($_)) {
3476 0 0       0 if (-d "$_/.") {
3477 0 0       0 return wantarray ? (-M _,@_) : -M _;
3478             }
3479             else {
3480 0         0 my $fh = gensym();
3481 0 0       0 if (_open_r($fh, $_)) {
3482 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3483 0 0       0 close($fh) or die "Can't close file: $_: $!";
3484 0         0 my $M = ($^T - $mtime) / (24*60*60);
3485 0 0       0 return wantarray ? ($M,@_) : $M;
3486             }
3487             }
3488             }
3489 0 0       0 return wantarray ? (undef,@_) : undef;
3490             }
3491              
3492             #
3493             # GBK file test -A expr
3494             #
3495             sub Egbk::A(;*@) {
3496              
3497 0 0   0 0 0 local $_ = shift if @_;
3498 0 0 0     0 croak 'Too many arguments for -A (Egbk::A)' if @_ and not wantarray;
3499              
3500 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3501 0 0       0 return wantarray ? (-A _,@_) : -A _;
3502             }
3503             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3504 0 0       0 return wantarray ? (-A $fh,@_) : -A $fh;
3505             }
3506             elsif (-e $_) {
3507 0 0       0 return wantarray ? (-A _,@_) : -A _;
3508             }
3509             elsif (_MSWin32_5Cended_path($_)) {
3510 0 0       0 if (-d "$_/.") {
3511 0 0       0 return wantarray ? (-A _,@_) : -A _;
3512             }
3513             else {
3514 0         0 my $fh = gensym();
3515 0 0       0 if (_open_r($fh, $_)) {
3516 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3517 0 0       0 close($fh) or die "Can't close file: $_: $!";
3518 0         0 my $A = ($^T - $atime) / (24*60*60);
3519 0 0       0 return wantarray ? ($A,@_) : $A;
3520             }
3521             }
3522             }
3523 0 0       0 return wantarray ? (undef,@_) : undef;
3524             }
3525              
3526             #
3527             # GBK file test -C expr
3528             #
3529             sub Egbk::C(;*@) {
3530              
3531 0 0   0 0 0 local $_ = shift if @_;
3532 0 0 0     0 croak 'Too many arguments for -C (Egbk::C)' if @_ and not wantarray;
3533              
3534 0 0       0 if ($_ eq '_') {
    0          
    0          
    0          
3535 0 0       0 return wantarray ? (-C _,@_) : -C _;
3536             }
3537             elsif (defined fileno(my $fh = qualify_to_ref $_)) {
3538 0 0       0 return wantarray ? (-C $fh,@_) : -C $fh;
3539             }
3540             elsif (-e $_) {
3541 0 0       0 return wantarray ? (-C _,@_) : -C _;
3542             }
3543             elsif (_MSWin32_5Cended_path($_)) {
3544 0 0       0 if (-d "$_/.") {
3545 0 0       0 return wantarray ? (-C _,@_) : -C _;
3546             }
3547             else {
3548 0         0 my $fh = gensym();
3549 0 0       0 if (_open_r($fh, $_)) {
3550 0         0 my($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks) = CORE::stat $fh;
3551 0 0       0 close($fh) or die "Can't close file: $_: $!";
3552 0         0 my $C = ($^T - $ctime) / (24*60*60);
3553 0 0       0 return wantarray ? ($C,@_) : $C;
3554             }
3555             }
3556             }
3557 0 0       0 return wantarray ? (undef,@_) : undef;
3558             }
3559              
3560             #
3561             # GBK stacked file test $_
3562             #
3563             sub Egbk::filetest_ {
3564              
3565 0     0 0 0 my $filetest = substr(pop @_, 1);
3566              
3567 0 0       0 unless (CORE::eval qq{Egbk::${filetest}_}) {
3568 0         0 return '';
3569             }
3570 0         0 for my $filetest (CORE::reverse @_) {
3571 0 0       0 unless (CORE::eval qq{ $filetest _ }) {
3572 0         0 return '';
3573             }
3574             }
3575 0         0 return 1;
3576             }
3577              
3578             #
3579             # GBK file test -r $_
3580             #
3581             sub Egbk::r_() {
3582              
3583 0 0   0 0 0 if (-e $_) {
    0          
3584 0 0       0 return -r _ ? 1 : '';
3585             }
3586             elsif (_MSWin32_5Cended_path($_)) {
3587 0 0       0 if (-d "$_/.") {
3588 0 0       0 return -r _ ? 1 : '';
3589             }
3590             else {
3591 0         0 my $fh = gensym();
3592 0 0       0 if (_open_r($fh, $_)) {
3593 0         0 my $r = -r $fh;
3594 0 0       0 close($fh) or die "Can't close file: $_: $!";
3595 0 0       0 return $r ? 1 : '';
3596             }
3597             }
3598             }
3599              
3600             # 10.10. Returning Failure
3601             # in Chapter 10. Subroutines
3602             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
3603             # (and so on)
3604              
3605             # 2010-01-26 The difference of "return;" and "return undef;"
3606             # http://d.hatena.ne.jp/gfx/20100126/1264474754
3607             #
3608             # "Perl Best Practices" recommends to use "return;"*1 to return nothing, but
3609             # it might be wrong in some cases. If you use this idiom for those functions
3610             # which are expected to return a scalar value, e.g. searching functions, the
3611             # user of those functions will be surprised at what they return in list
3612             # context, an empty list - note that many functions and all the methods
3613             # evaluate their arguments in list context. You'd better to use "return undef;"
3614             # for such scalar functions.
3615             #
3616             # sub search_something {
3617             # my($arg) = @_;
3618             # # search_something...
3619             # if(defined $found){
3620             # return $found;
3621             # }
3622             # return; # XXX: you'd better to "return undef;"
3623             # }
3624             #
3625             # # ...
3626             #
3627             # # you'll get what you want, but ...
3628             # my $something = search_something($source);
3629             #
3630             # # you won't get what you want here.
3631             # # @_ for doit() is (-foo => $opt), not (undef, -foo => $opt).
3632             # $obj->doit(search_something($source), -option=> $optval);
3633             #
3634             # # you have to use the "scalar" operator in such a case.
3635             # $obj->doit(scalar search_something($source), ...);
3636             #
3637             # *1: it returns an empty list in list context, or returns undef in scalar
3638             # context
3639             #
3640             # (and so on)
3641              
3642 0         0 return undef;
3643             }
3644              
3645             #
3646             # GBK file test -w $_
3647             #
3648             sub Egbk::w_() {
3649              
3650 0 0   0 0 0 if (-e $_) {
    0          
3651 0 0       0 return -w _ ? 1 : '';
3652             }
3653             elsif (_MSWin32_5Cended_path($_)) {
3654 0 0       0 if (-d "$_/.") {
3655 0 0       0 return -w _ ? 1 : '';
3656             }
3657             else {
3658 0         0 my $fh = gensym();
3659 0 0       0 if (_open_a($fh, $_)) {
3660 0         0 my $w = -w $fh;
3661 0 0       0 close($fh) or die "Can't close file: $_: $!";
3662 0 0       0 return $w ? 1 : '';
3663             }
3664             }
3665             }
3666 0         0 return undef;
3667             }
3668              
3669             #
3670             # GBK file test -x $_
3671             #
3672             sub Egbk::x_() {
3673              
3674 0 0   0 0 0 if (-e $_) {
    0          
3675 0 0       0 return -x _ ? 1 : '';
3676             }
3677             elsif (_MSWin32_5Cended_path($_)) {
3678 0 0       0 if (-d "$_/.") {
3679 0 0       0 return -x _ ? 1 : '';
3680             }
3681             else {
3682 0         0 my $fh = gensym();
3683 0 0       0 if (_open_r($fh, $_)) {
3684 0         0 my $dummy_for_underline_cache = -x $fh;
3685 0 0       0 close($fh) or die "Can't close file: $_: $!";
3686             }
3687              
3688             # filename is not .COM .EXE .BAT .CMD
3689 0         0 return '';
3690             }
3691             }
3692 0         0 return undef;
3693             }
3694              
3695             #
3696             # GBK file test -o $_
3697             #
3698             sub Egbk::o_() {
3699              
3700 0 0   0 0 0 if (-e $_) {
    0          
3701 0 0       0 return -o _ ? 1 : '';
3702             }
3703             elsif (_MSWin32_5Cended_path($_)) {
3704 0 0       0 if (-d "$_/.") {
3705 0 0       0 return -o _ ? 1 : '';
3706             }
3707             else {
3708 0         0 my $fh = gensym();
3709 0 0       0 if (_open_r($fh, $_)) {
3710 0         0 my $o = -o $fh;
3711 0 0       0 close($fh) or die "Can't close file: $_: $!";
3712 0 0       0 return $o ? 1 : '';
3713             }
3714             }
3715             }
3716 0         0 return undef;
3717             }
3718              
3719             #
3720             # GBK file test -R $_
3721             #
3722             sub Egbk::R_() {
3723              
3724 0 0   0 0 0 if (-e $_) {
    0          
3725 0 0       0 return -R _ ? 1 : '';
3726             }
3727             elsif (_MSWin32_5Cended_path($_)) {
3728 0 0       0 if (-d "$_/.") {
3729 0 0       0 return -R _ ? 1 : '';
3730             }
3731             else {
3732 0         0 my $fh = gensym();
3733 0 0       0 if (_open_r($fh, $_)) {
3734 0         0 my $R = -R $fh;
3735 0 0       0 close($fh) or die "Can't close file: $_: $!";
3736 0 0       0 return $R ? 1 : '';
3737             }
3738             }
3739             }
3740 0         0 return undef;
3741             }
3742              
3743