File Coverage

Char/Eusascii.pm
Criterion Covered Total %
statement 51 954 5.3
branch 4 562 0.7
condition 1 180 0.5
subroutine 20 85 23.5
pod 7 50 14.0
total 83 1831 4.5


line stmt bran cond sub pod time code
1             #
2             # This file is *** FOR CPAN USE ONLY ***.
3             #
4             package Char::Eusascii;
5             ######################################################################
6             #
7             # Char::Eusascii - Run-time routines for Char/USASCII.pm
8             #
9             # http://search.cpan.org/dist/Char-USASCII/
10             #
11             # Copyright (c) 2008, 2009, 2010, 2011, 2012, 2013, 2014 INABA Hitoshi
12             ######################################################################
13              
14 177     177   3841 use 5.00503; # Galapagos Consensus 1998 for primetools
  177         590  
  177         9082  
15             # use 5.008001; # Lancaster Consensus 2013 for toolchains
16              
17             # 12.3. Delaying use Until Runtime
18             # in Chapter 12. Packages, Libraries, and Modules
19             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
20             # (and so on)
21              
22 177     177   11257 BEGIN { eval q{ use vars qw($VERSION) } }
  177     177   1455  
  177         364  
  177         28985  
23             $VERSION = sprintf '%d.%02d', q$Revision: 1.01 $ =~ /(\d+)/xmsg;
24              
25             BEGIN {
26 177 50   177   1695 if ($^X =~ / jperl /oxmsi) {
27 0         0 die __FILE__, ": needs perl(not jperl) 5.00503 or later. (\$^X==$^X)";
28             }
29 177         318 if (CORE::ord('A') == 193) {
30             die __FILE__, ": is not US-ASCII script (may be EBCDIC or EBCDIK script).";
31             }
32 177         30275 if (CORE::ord('A') != 0x41) {
33             die __FILE__, ": is not US-ASCII script (must be US-ASCII script).";
34             }
35             }
36              
37             BEGIN {
38              
39             # instead of utf8.pm
40 177     177   11494 eval q{
  177     177   1154  
  177     56   338  
  177         32198  
  56         10014  
  47         9599  
  67         14790  
  61         12625  
  64         12494  
  59         12774  
41             no warnings qw(redefine);
42             *utf8::upgrade = sub { CORE::length $_[0] };
43             *utf8::downgrade = sub { 1 };
44             *utf8::encode = sub { };
45             *utf8::decode = sub { 1 };
46             *utf8::is_utf8 = sub { };
47             *utf8::valid = sub { 1 };
48             };
49 177 50       119866 if ($@) {
50 0         0 *utf8::upgrade = sub { CORE::length $_[0] };
  0         0  
51 0         0 *utf8::downgrade = sub { 1 };
  0         0  
52 0         0 *utf8::encode = sub { };
  0         0  
53 0         0 *utf8::decode = sub { 1 };
  0         0  
54 0         0 *utf8::is_utf8 = sub { };
  0         0  
55 0         0 *utf8::valid = sub { 1 };
  0         0  
56             }
57             }
58              
59             # instead of Symbol.pm
60             BEGIN {
61 177     177   413 my $genpkg = "Symbol::";
62 177         8065 my $genseq = 0;
63              
64             sub gensym () {
65 0     0 0 0 my $name = "GEN" . $genseq++;
66              
67             # here, no strict qw(refs); if strict.pm exists
68              
69 0         0 my $ref = \*{$genpkg . $name};
  0         0  
70 0         0 delete $$genpkg{$name};
71 0         0 return $ref;
72             }
73              
74             sub qualify ($;$) {
75 0     0 0 0 my ($name) = @_;
76 0 0 0     0 if (!ref($name) && (Char::Eusascii::index($name, '::') == -1) && (Char::Eusascii::index($name, "'") == -1)) {
      0        
77 0         0 my $pkg;
78 0         0 my %global = map {$_ => 1} qw(ARGV ARGVOUT ENV INC SIG STDERR STDIN STDOUT DATA);
  0         0  
79              
80             # Global names: special character, "^xyz", or other.
81 0 0 0     0 if ($name =~ /^(([^a-z])|(\^[a-z_]+))\z/i || $global{$name}) {
82             # RGS 2001-11-05 : translate leading ^X to control-char
83 0         0 $name =~ s/^\^([a-z_])/'qq(\c'.$1.')'/eei;
  0         0  
84 0         0 $pkg = "main";
85             }
86             else {
87 0 0       0 $pkg = (@_ > 1) ? $_[1] : caller;
88             }
89 0         0 $name = $pkg . "::" . $name;
90             }
91 0         0 return $name;
92             }
93              
94             sub qualify_to_ref ($;$) {
95              
96             # here, no strict qw(refs); if strict.pm exists
97              
98 0 0   0 0 0 return \*{ qualify $_[0], @_ > 1 ? $_[1] : caller };
  0         0  
99             }
100             }
101              
102             # Column: local $@
103             # in Chapter 9. Osaete okitai Perl no kiso
104             # of ISBN 10: 4798119172 | ISBN 13: 978-4798119175 MODAN Perl NYUMON
105             # (and so on)
106              
107             # use strict; if strict.pm exists
108             BEGIN {
109 177 50   177   393 if (eval { local $@; CORE::require strict }) {
  177         448  
  177         1985  
110 177         25746 strict::->import;
111             }
112             }
113              
114             # P.714 29.2.39. flock
115             # in Chapter 29: Functions
116             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
117              
118             # P.863 flock
119             # in Chapter 27: Functions
120             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
121              
122             sub LOCK_SH() {1}
123             sub LOCK_EX() {2}
124             sub LOCK_UN() {8}
125             sub LOCK_NB() {4}
126              
127             # instead of Carp.pm
128             sub carp;
129             sub croak;
130             sub cluck;
131             sub confess;
132              
133             my $your_char = q{[\x00-\xFF]};
134              
135             # regexp of character
136 177     177   12192 BEGIN { eval q{ use vars qw($q_char) } }
  177     177   969  
  177         414  
  177         15173  
137             $q_char = qr/$your_char/oxms;
138              
139             #
140             # US-ASCII character range per length
141             #
142             my %range_tr = ();
143              
144             #
145             # alias of encoding name
146             #
147 177     177   10018 BEGIN { eval q{ use vars qw($encoding_alias) } }
  177     177   1050  
  177         353  
  177         208728  
148              
149             #
150             # US-ASCII case conversion
151             #
152             my %lc = ();
153             @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)} =
154             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);
155             my %uc = ();
156             @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)} =
157             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);
158             my %fc = ();
159             @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)} =
160             qw(a b c d e f g h i j k l m n o p q r s t u v w x y z);
161              
162             if (0) {
163             }
164              
165             elsif (__PACKAGE__ =~ / \b Eusascii \z/oxms) {
166             %range_tr = (
167             1 => [ [0x00..0xFF],
168             ],
169             );
170             $encoding_alias = qr/ \b (?: (?:us-?)?ascii ) \b /oxmsi;
171             }
172              
173             else {
174             croak "Don't know my package name '@{[__PACKAGE__]}'";
175             }
176              
177             #
178             # @ARGV wildcard globbing
179             #
180             sub import {
181              
182 0 0   0   0 if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
183 0         0 my @argv = ();
184 0         0 for (@ARGV) {
185              
186             # has space
187 0 0       0 if (/\A (?:$q_char)*? [ ] /oxms) {
    0          
188 0 0       0 if (my @glob = Char::Eusascii::glob(qq{"$_"})) {
189 0         0 push @argv, @glob;
190             }
191             else {
192 0         0 push @argv, $_;
193             }
194             }
195              
196             # has wildcard metachar
197             elsif (/\A (?:$q_char)*? [*?] /oxms) {
198 0 0       0 if (my @glob = Char::Eusascii::glob($_)) {
199 0         0 push @argv, @glob;
200             }
201             else {
202 0         0 push @argv, $_;
203             }
204             }
205              
206             # no wildcard globbing
207             else {
208 0         0 push @argv, $_;
209             }
210             }
211 0         0 @ARGV = @argv;
212             }
213             }
214              
215             # P.230 Care with Prototypes
216             # in Chapter 6: Subroutines
217             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
218             #
219             # If you aren't careful, you can get yourself into trouble with prototypes.
220             # But if you are careful, you can do a lot of neat things with them. This is
221             # all very powerful, of course, and should only be used in moderation to make
222             # the world a better place.
223              
224             # P.332 Care with Prototypes
225             # in Chapter 7: Subroutines
226             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
227             #
228             # If you aren't careful, you can get yourself into trouble with prototypes.
229             # But if you are careful, you can do a lot of neat things with them. This is
230             # all very powerful, of course, and should only be used in moderation to make
231             # the world a better place.
232              
233             #
234             # Prototypes of subroutines
235             #
236 0     0   0 sub unimport {}
237             sub Char::Eusascii::split(;$$$);
238             sub Char::Eusascii::tr($$$$;$);
239             sub Char::Eusascii::chop(@);
240             sub Char::Eusascii::index($$;$);
241             sub Char::Eusascii::rindex($$;$);
242             sub Char::Eusascii::lcfirst(@);
243             sub Char::Eusascii::lcfirst_();
244             sub Char::Eusascii::lc(@);
245             sub Char::Eusascii::lc_();
246             sub Char::Eusascii::ucfirst(@);
247             sub Char::Eusascii::ucfirst_();
248             sub Char::Eusascii::uc(@);
249             sub Char::Eusascii::uc_();
250             sub Char::Eusascii::fc(@);
251             sub Char::Eusascii::fc_();
252             sub Char::Eusascii::ignorecase;
253             sub Char::Eusascii::classic_character_class;
254             sub Char::Eusascii::capture;
255             sub Char::Eusascii::chr(;$);
256             sub Char::Eusascii::chr_();
257             sub Char::Eusascii::glob($);
258             sub Char::Eusascii::glob_();
259              
260             sub Char::USASCII::ord(;$);
261             sub Char::USASCII::ord_();
262             sub Char::USASCII::reverse(@);
263             sub Char::USASCII::getc(;*@);
264             sub Char::USASCII::length(;$);
265             sub Char::USASCII::substr($$;$$);
266             sub Char::USASCII::index($$;$);
267             sub Char::USASCII::rindex($$;$);
268              
269             #
270             # Regexp work
271             #
272 177     177   23216 BEGIN { eval q{ use vars qw(
  177     177   1334  
  177         353  
  177         91810  
273             $Char::USASCII::re_a
274             $Char::USASCII::re_t
275             $Char::USASCII::re_n
276             $Char::USASCII::re_r
277             ) } }
278              
279             #
280             # Character class
281             #
282 177     177   14546 BEGIN { eval q{ use vars qw(
  177     177   1049  
  177         332  
  177         3068942  
283             $dot
284             $dot_s
285             $eD
286             $eS
287             $eW
288             $eH
289             $eV
290             $eR
291             $eN
292             $not_alnum
293             $not_alpha
294             $not_ascii
295             $not_blank
296             $not_cntrl
297             $not_digit
298             $not_graph
299             $not_lower
300             $not_lower_i
301             $not_print
302             $not_punct
303             $not_space
304             $not_upper
305             $not_upper_i
306             $not_word
307             $not_xdigit
308             $eb
309             $eB
310             ) } }
311              
312             ${Char::Eusascii::dot} = qr{(?:[^\x0A])};
313             ${Char::Eusascii::dot_s} = qr{(?:[\x00-\xFF])};
314             ${Char::Eusascii::eD} = qr{(?:[^0-9])};
315              
316             # Vertical tabs are now whitespace
317             # \s in a regex now matches a vertical tab in all circumstances.
318             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
319             # ${Char::Eusascii::eS} = qr{(?:[^\x09\x0A \x0C\x0D\x20])};
320             # ${Char::Eusascii::eS} = qr{(?:[^\x09\x0A\x0B\x0C\x0D\x20])};
321             ${Char::Eusascii::eS} = qr{(?:[^\s])};
322              
323             ${Char::Eusascii::eW} = qr{(?:[^0-9A-Z_a-z])};
324             ${Char::Eusascii::eH} = qr{(?:[^\x09\x20])};
325             ${Char::Eusascii::eV} = qr{(?:[^\x0A\x0B\x0C\x0D])};
326             ${Char::Eusascii::eR} = qr{(?:\x0D\x0A|[\x0A\x0D])};
327             ${Char::Eusascii::eN} = qr{(?:[^\x0A])};
328             ${Char::Eusascii::not_alnum} = qr{(?:[^\x30-\x39\x41-\x5A\x61-\x7A])};
329             ${Char::Eusascii::not_alpha} = qr{(?:[^\x41-\x5A\x61-\x7A])};
330             ${Char::Eusascii::not_ascii} = qr{(?:[^\x00-\x7F])};
331             ${Char::Eusascii::not_blank} = qr{(?:[^\x09\x20])};
332             ${Char::Eusascii::not_cntrl} = qr{(?:[^\x00-\x1F\x7F])};
333             ${Char::Eusascii::not_digit} = qr{(?:[^\x30-\x39])};
334             ${Char::Eusascii::not_graph} = qr{(?:[^\x21-\x7F])};
335             ${Char::Eusascii::not_lower} = qr{(?:[^\x61-\x7A])};
336             ${Char::Eusascii::not_lower_i} = qr{(?:[\x00-\xFF])};
337             ${Char::Eusascii::not_print} = qr{(?:[^\x20-\x7F])};
338             ${Char::Eusascii::not_punct} = qr{(?:[^\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E])};
339             ${Char::Eusascii::not_space} = qr{(?:[^\s\x0B])};
340             ${Char::Eusascii::not_upper} = qr{(?:[^\x41-\x5A])};
341             ${Char::Eusascii::not_upper_i} = qr{(?:[\x00-\xFF])};
342             ${Char::Eusascii::not_word} = qr{(?:[^\x30-\x39\x41-\x5A\x5F\x61-\x7A])};
343             ${Char::Eusascii::not_xdigit} = qr{(?:[^\x30-\x39\x41-\x46\x61-\x66])};
344             ${Char::Eusascii::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))};
345             ${Char::Eusascii::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]))};
346              
347             # avoid: Name "Char::Eusascii::foo" used only once: possible typo at here.
348             ${Char::Eusascii::dot} = ${Char::Eusascii::dot};
349             ${Char::Eusascii::dot_s} = ${Char::Eusascii::dot_s};
350             ${Char::Eusascii::eD} = ${Char::Eusascii::eD};
351             ${Char::Eusascii::eS} = ${Char::Eusascii::eS};
352             ${Char::Eusascii::eW} = ${Char::Eusascii::eW};
353             ${Char::Eusascii::eH} = ${Char::Eusascii::eH};
354             ${Char::Eusascii::eV} = ${Char::Eusascii::eV};
355             ${Char::Eusascii::eR} = ${Char::Eusascii::eR};
356             ${Char::Eusascii::eN} = ${Char::Eusascii::eN};
357             ${Char::Eusascii::not_alnum} = ${Char::Eusascii::not_alnum};
358             ${Char::Eusascii::not_alpha} = ${Char::Eusascii::not_alpha};
359             ${Char::Eusascii::not_ascii} = ${Char::Eusascii::not_ascii};
360             ${Char::Eusascii::not_blank} = ${Char::Eusascii::not_blank};
361             ${Char::Eusascii::not_cntrl} = ${Char::Eusascii::not_cntrl};
362             ${Char::Eusascii::not_digit} = ${Char::Eusascii::not_digit};
363             ${Char::Eusascii::not_graph} = ${Char::Eusascii::not_graph};
364             ${Char::Eusascii::not_lower} = ${Char::Eusascii::not_lower};
365             ${Char::Eusascii::not_lower_i} = ${Char::Eusascii::not_lower_i};
366             ${Char::Eusascii::not_print} = ${Char::Eusascii::not_print};
367             ${Char::Eusascii::not_punct} = ${Char::Eusascii::not_punct};
368             ${Char::Eusascii::not_space} = ${Char::Eusascii::not_space};
369             ${Char::Eusascii::not_upper} = ${Char::Eusascii::not_upper};
370             ${Char::Eusascii::not_upper_i} = ${Char::Eusascii::not_upper_i};
371             ${Char::Eusascii::not_word} = ${Char::Eusascii::not_word};
372             ${Char::Eusascii::not_xdigit} = ${Char::Eusascii::not_xdigit};
373             ${Char::Eusascii::eb} = ${Char::Eusascii::eb};
374             ${Char::Eusascii::eB} = ${Char::Eusascii::eB};
375              
376             #
377             # US-ASCII split
378             #
379             sub Char::Eusascii::split(;$$$) {
380              
381             # P.794 29.2.161. split
382             # in Chapter 29: Functions
383             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
384              
385             # P.951 split
386             # in Chapter 27: Functions
387             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
388              
389 0     0 0 0 my $pattern = $_[0];
390 0         0 my $string = $_[1];
391 0         0 my $limit = $_[2];
392              
393             # if $pattern is also omitted or is the literal space, " "
394 0 0       0 if (not defined $pattern) {
395 0         0 $pattern = ' ';
396             }
397              
398             # if $string is omitted, the function splits the $_ string
399 0 0       0 if (not defined $string) {
400 0 0       0 if (defined $_) {
401 0         0 $string = $_;
402             }
403             else {
404 0         0 $string = '';
405             }
406             }
407              
408 0         0 my @split = ();
409              
410             # when string is empty
411 0 0       0 if ($string eq '') {
    0          
412              
413             # resulting list value in list context
414 0 0       0 if (wantarray) {
415 0         0 return @split;
416             }
417              
418             # count of substrings in scalar context
419             else {
420 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
421 0         0 @_ = @split;
422 0         0 return scalar @_;
423             }
424             }
425              
426             # split's first argument is more consistently interpreted
427             #
428             # After some changes earlier in v5.17, split's behavior has been simplified:
429             # if the PATTERN argument evaluates to a string containing one space, it is
430             # treated the way that a literal string containing one space once was.
431             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#split's_first_argument_is_more_consistently_interpreted
432              
433             # if $pattern is also omitted or is the literal space, " ", the function splits
434             # on whitespace, /\s+/, after skipping any leading whitespace
435             # (and so on)
436              
437             elsif ($pattern eq ' ') {
438 0 0       0 if (not defined $limit) {
439 0         0 return CORE::split(' ', $string);
440             }
441             else {
442 0         0 return CORE::split(' ', $string, $limit);
443             }
444             }
445              
446             # if $limit is negative, it is treated as if an arbitrarily large $limit has been specified
447 0 0 0     0 if ((not defined $limit) or ($limit <= 0)) {
    0          
448              
449             # a pattern capable of matching either the null string or something longer than the
450             # null string will split the value of $string into separate characters wherever it
451             # matches the null string between characters
452             # (and so on)
453              
454 0 0       0 if ('' =~ / \A $pattern \z /xms) {
455 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
456 0         0 my $limit = scalar(() = $string =~ /($pattern)/oxmsg);
457              
458             # P.1024 Appendix W.10 Multibyte Processing
459             # of ISBN 1-56592-224-7 CJKV Information Processing
460             # (and so on)
461              
462             # the //m modifier is assumed when you split on the pattern /^/
463             # (and so on)
464              
465             # V
466 0   0     0 while ((--$limit > 0) and ($string =~ s/\A((?:$q_char)+?)$pattern//m)) {
467              
468             # if the $pattern contains parentheses, then the substring matched by each pair of parentheses
469             # is included in the resulting list, interspersed with the fields that are ordinarily returned
470             # (and so on)
471              
472 0         0 local $@;
473 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
474 0         0 push @split, eval('$' . $digit);
475             }
476             }
477             }
478              
479             else {
480 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
481              
482             # V
483 0         0 while ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
484 0         0 local $@;
485 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
486 0         0 push @split, eval('$' . $digit);
487             }
488             }
489             }
490             }
491              
492             elsif ($limit > 0) {
493 0 0       0 if ('' =~ / \A $pattern \z /xms) {
494 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
495 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
496              
497             # V
498 0 0       0 if ($string =~ s/\A((?:$q_char)+?)$pattern//m) {
499 0         0 local $@;
500 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
501 0         0 push @split, eval('$' . $digit);
502             }
503             }
504             }
505             }
506             else {
507 0         0 my $last_subexpression_offsets = _last_subexpression_offsets($pattern);
508 0   0     0 while ((--$limit > 0) and (CORE::length($string) > 0)) {
509              
510             # V
511 0 0       0 if ($string =~ s/\A((?:$q_char)*?)$pattern//m) {
512 0         0 local $@;
513 0         0 for (my $digit=1; $digit <= ($last_subexpression_offsets + 1); $digit++) {
514 0         0 push @split, eval('$' . $digit);
515             }
516             }
517             }
518             }
519             }
520              
521 0 0       0 if (CORE::length($string) > 0) {
522 0         0 push @split, $string;
523             }
524              
525             # if $_[2] (NOT "$limit") is omitted or zero, trailing null fields are stripped from the result
526 0 0 0     0 if ((not defined $_[2]) or ($_[2] == 0)) {
527 0   0     0 while ((scalar(@split) >= 1) and ($split[-1] eq '')) {
528 0         0 pop @split;
529             }
530             }
531              
532             # resulting list value in list context
533 0 0       0 if (wantarray) {
534 0         0 return @split;
535             }
536              
537             # count of substrings in scalar context
538             else {
539 0 0       0 carp "Use of implicit split to \@_ is deprecated" if $^W;
540 0         0 @_ = @split;
541 0         0 return scalar @_;
542             }
543             }
544              
545             #
546             # get last subexpression offsets
547             #
548             sub _last_subexpression_offsets {
549 0     0   0 my $pattern = $_[0];
550              
551             # remove comment
552 0         0 $pattern =~ s/\(\?\# .*? \)//oxmsg;
553              
554 0         0 my $modifier = '';
555 0 0       0 if ($pattern =~ /\(\?\^? ([\-A-Za-z]+) :/oxms) {
556 0         0 $modifier = $1;
557 0         0 $modifier =~ s/-[A-Za-z]*//;
558             }
559              
560             # with /x modifier
561 0         0 my @char = ();
562 0 0       0 if ($modifier =~ /x/oxms) {
563 0         0 @char = $pattern =~ /\G(
564             \\ (?:$q_char) |
565             \# (?:$q_char)*? $ |
566             \[ (?: \\\] | (?:$q_char))+? \] |
567             \(\? |
568             (?:$q_char)
569             )/oxmsg;
570             }
571              
572             # without /x modifier
573             else {
574 0         0 @char = $pattern =~ /\G(
575             \\ (?:$q_char) |
576             \[ (?: \\\] | (?:$q_char))+? \] |
577             \(\? |
578             (?:$q_char)
579             )/oxmsg;
580             }
581              
582 0         0 return scalar grep { $_ eq '(' } @char;
  0         0  
583             }
584              
585             #
586             # US-ASCII transliteration (tr///)
587             #
588             sub Char::Eusascii::tr($$$$;$) {
589              
590 0     0 0 0 my $bind_operator = $_[1];
591 0         0 my $searchlist = $_[2];
592 0         0 my $replacementlist = $_[3];
593 0   0     0 my $modifier = $_[4] || '';
594              
595 0 0       0 if ($modifier =~ /r/oxms) {
596 0 0       0 if ($bind_operator =~ / !~ /oxms) {
597 0         0 croak "Using !~ with tr///r doesn't make sense";
598             }
599             }
600              
601 0         0 my @char = $_[0] =~ /\G ($q_char) /oxmsg;
602 0         0 my @searchlist = _charlist_tr($searchlist);
603 0         0 my @replacementlist = _charlist_tr($replacementlist);
604              
605 0         0 my %tr = ();
606 0         0 for (my $i=0; $i <= $#searchlist; $i++) {
607 0 0       0 if (not exists $tr{$searchlist[$i]}) {
608 0 0 0     0 if (defined $replacementlist[$i] and ($replacementlist[$i] ne '')) {
    0 0        
    0          
609 0         0 $tr{$searchlist[$i]} = $replacementlist[$i];
610             }
611             elsif ($modifier =~ /d/oxms) {
612 0         0 $tr{$searchlist[$i]} = '';
613             }
614             elsif (defined $replacementlist[-1] and ($replacementlist[-1] ne '')) {
615 0         0 $tr{$searchlist[$i]} = $replacementlist[-1];
616             }
617             else {
618 0         0 $tr{$searchlist[$i]} = $searchlist[$i];
619             }
620             }
621             }
622              
623 0         0 my $tr = 0;
624 0         0 my $replaced = '';
625 0 0       0 if ($modifier =~ /c/oxms) {
626 0         0 while (defined(my $char = shift @char)) {
627 0 0       0 if (not exists $tr{$char}) {
628 0 0       0 if (defined $replacementlist[0]) {
629 0         0 $replaced .= $replacementlist[0];
630             }
631 0         0 $tr++;
632 0 0       0 if ($modifier =~ /s/oxms) {
633 0   0     0 while (@char and (not exists $tr{$char[0]})) {
634 0         0 shift @char;
635 0         0 $tr++;
636             }
637             }
638             }
639             else {
640 0         0 $replaced .= $char;
641             }
642             }
643             }
644             else {
645 0         0 while (defined(my $char = shift @char)) {
646 0 0       0 if (exists $tr{$char}) {
647 0         0 $replaced .= $tr{$char};
648 0         0 $tr++;
649 0 0       0 if ($modifier =~ /s/oxms) {
650 0   0     0 while (@char and (exists $tr{$char[0]}) and ($tr{$char[0]} eq $tr{$char})) {
      0        
651 0         0 shift @char;
652 0         0 $tr++;
653             }
654             }
655             }
656             else {
657 0         0 $replaced .= $char;
658             }
659             }
660             }
661              
662 0 0       0 if ($modifier =~ /r/oxms) {
663 0         0 return $replaced;
664             }
665             else {
666 0         0 $_[0] = $replaced;
667 0 0       0 if ($bind_operator =~ / !~ /oxms) {
668 0         0 return not $tr;
669             }
670             else {
671 0         0 return $tr;
672             }
673             }
674             }
675              
676             #
677             # US-ASCII chop
678             #
679             sub Char::Eusascii::chop(@) {
680              
681 0     0 0 0 my $chop;
682 0 0       0 if (@_ == 0) {
683 0         0 my @char = /\G ($q_char) /oxmsg;
684 0         0 $chop = pop @char;
685 0         0 $_ = join '', @char;
686             }
687             else {
688 0         0 for (@_) {
689 0         0 my @char = /\G ($q_char) /oxmsg;
690 0         0 $chop = pop @char;
691 0         0 $_ = join '', @char;
692             }
693             }
694 0         0 return $chop;
695             }
696              
697             #
698             # US-ASCII index by octet
699             #
700             sub Char::Eusascii::index($$;$) {
701              
702 0     0 1 0 my($str,$substr,$position) = @_;
703 0   0     0 $position ||= 0;
704 0         0 my $pos = 0;
705              
706 0         0 while ($pos < CORE::length($str)) {
707 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
708 0 0       0 if ($pos >= $position) {
709 0         0 return $pos;
710             }
711             }
712 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
713 0         0 $pos += CORE::length($1);
714             }
715             else {
716 0         0 $pos += 1;
717             }
718             }
719 0         0 return -1;
720             }
721              
722             #
723             # US-ASCII reverse index
724             #
725             sub Char::Eusascii::rindex($$;$) {
726              
727 0     0 0 0 my($str,$substr,$position) = @_;
728 0   0     0 $position ||= CORE::length($str) - 1;
729 0         0 my $pos = 0;
730 0         0 my $rindex = -1;
731              
732 0   0     0 while (($pos < CORE::length($str)) and ($pos <= $position)) {
733 0 0       0 if (CORE::substr($str,$pos,CORE::length($substr)) eq $substr) {
734 0         0 $rindex = $pos;
735             }
736 0 0       0 if (CORE::substr($str,$pos) =~ /\A ($q_char) /oxms) {
737 0         0 $pos += CORE::length($1);
738             }
739             else {
740 0         0 $pos += 1;
741             }
742             }
743 0         0 return $rindex;
744             }
745              
746             #
747             # US-ASCII lower case first with parameter
748             #
749             sub Char::Eusascii::lcfirst(@) {
750 0 0   0 0 0 if (@_) {
751 0         0 my $s = shift @_;
752 0 0 0     0 if (@_ and wantarray) {
753 0         0 return Char::Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
754             }
755             else {
756 0         0 return Char::Eusascii::lc(CORE::substr($s,0,1)) . CORE::substr($s,1);
757             }
758             }
759             else {
760 0         0 return Char::Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
761             }
762             }
763              
764             #
765             # US-ASCII lower case first without parameter
766             #
767             sub Char::Eusascii::lcfirst_() {
768 0     0 0 0 return Char::Eusascii::lc(CORE::substr($_,0,1)) . CORE::substr($_,1);
769             }
770              
771             #
772             # US-ASCII lower case with parameter
773             #
774             sub Char::Eusascii::lc(@) {
775 0 0   0 0 0 if (@_) {
776 0         0 my $s = shift @_;
777 0 0 0     0 if (@_ and wantarray) {
778 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
779             }
780             else {
781 0 0       0 return join('', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
782             }
783             }
784             else {
785 0         0 return Char::Eusascii::lc_();
786             }
787             }
788              
789             #
790             # US-ASCII lower case without parameter
791             #
792             sub Char::Eusascii::lc_() {
793 0     0 0 0 my $s = $_;
794 0 0       0 return join '', map {defined($lc{$_}) ? $lc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
795             }
796              
797             #
798             # US-ASCII upper case first with parameter
799             #
800             sub Char::Eusascii::ucfirst(@) {
801 0 0   0 0 0 if (@_) {
802 0         0 my $s = shift @_;
803 0 0 0     0 if (@_ and wantarray) {
804 0         0 return Char::Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1), @_;
805             }
806             else {
807 0         0 return Char::Eusascii::uc(CORE::substr($s,0,1)) . CORE::substr($s,1);
808             }
809             }
810             else {
811 0         0 return Char::Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
812             }
813             }
814              
815             #
816             # US-ASCII upper case first without parameter
817             #
818             sub Char::Eusascii::ucfirst_() {
819 0     0 0 0 return Char::Eusascii::uc(CORE::substr($_,0,1)) . CORE::substr($_,1);
820             }
821              
822             #
823             # US-ASCII upper case with parameter
824             #
825             sub Char::Eusascii::uc(@) {
826 0 0   0 0 0 if (@_) {
827 0         0 my $s = shift @_;
828 0 0 0     0 if (@_ and wantarray) {
829 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
830             }
831             else {
832 0 0       0 return join('', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
833             }
834             }
835             else {
836 0         0 return Char::Eusascii::uc_();
837             }
838             }
839              
840             #
841             # US-ASCII upper case without parameter
842             #
843             sub Char::Eusascii::uc_() {
844 0     0 0 0 my $s = $_;
845 0 0       0 return join '', map {defined($uc{$_}) ? $uc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
846             }
847              
848             #
849             # US-ASCII fold case with parameter
850             #
851             sub Char::Eusascii::fc(@) {
852 0 0   0 0 0 if (@_) {
853 0         0 my $s = shift @_;
854 0 0 0     0 if (@_ and wantarray) {
855 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg)), @_;
  0         0  
856             }
857             else {
858 0 0       0 return join('', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg));
  0         0  
859             }
860             }
861             else {
862 0         0 return Char::Eusascii::fc_();
863             }
864             }
865              
866             #
867             # US-ASCII fold case without parameter
868             #
869             sub Char::Eusascii::fc_() {
870 0     0 0 0 my $s = $_;
871 0 0       0 return join '', map {defined($fc{$_}) ? $fc{$_} : $_} ($s =~ /\G ($q_char) /oxmsg);
  0         0  
872             }
873              
874             #
875             # US-ASCII regexp capture
876             #
877             {
878             sub Char::Eusascii::capture {
879 0     0 1 0 return $_[0];
880             }
881             }
882              
883             #
884             # US-ASCII regexp ignore case modifier
885             #
886             sub Char::Eusascii::ignorecase {
887              
888 0     0 0 0 my @string = @_;
889 0         0 my $metachar = qr/[\@\\|[\]{]/oxms;
890              
891             # ignore case of $scalar or @array
892 0         0 for my $string (@string) {
893              
894             # split regexp
895 0         0 my @char = $string =~ /\G(
896             \[\^ |
897             \\? (?:$q_char)
898             )/oxmsg;
899              
900             # unescape character
901 0         0 for (my $i=0; $i <= $#char; $i++) {
902 0 0       0 next if not defined $char[$i];
903              
904             # open character class [...]
905 0 0       0 if ($char[$i] eq '[') {
    0          
    0          
    0          
906 0         0 my $left = $i;
907              
908             # [] make die "unmatched [] in regexp ..."
909              
910 0 0       0 if ($char[$i+1] eq ']') {
911 0         0 $i++;
912             }
913              
914 0         0 while (1) {
915 0 0       0 if (++$i > $#char) {
916 0         0 croak "Unmatched [] in regexp";
917             }
918 0 0       0 if ($char[$i] eq ']') {
919 0         0 my $right = $i;
920 0         0 my @charlist = charlist_qr(@char[$left+1..$right-1], 'i');
921              
922             # escape character
923 0         0 for my $char (@charlist) {
924 0 0       0 if (0) {
925             }
926              
927 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
928 0         0 $char = $1 . '\\' . $char;
929             }
930             }
931              
932             # [...]
933 0         0 splice @char, $left, $right-$left+1, '(?:' . join('|', @charlist) . ')';
934              
935 0         0 $i = $left;
936 0         0 last;
937             }
938             }
939             }
940              
941             # open character class [^...]
942             elsif ($char[$i] eq '[^') {
943 0         0 my $left = $i;
944              
945             # [^] make die "unmatched [] in regexp ..."
946              
947 0 0       0 if ($char[$i+1] eq ']') {
948 0         0 $i++;
949             }
950              
951 0         0 while (1) {
952 0 0       0 if (++$i > $#char) {
953 0         0 croak "Unmatched [] in regexp";
954             }
955 0 0       0 if ($char[$i] eq ']') {
956 0         0 my $right = $i;
957 0         0 my @charlist = charlist_not_qr(@char[$left+1..$right-1], 'i');
958              
959             # escape character
960 0         0 for my $char (@charlist) {
961 0 0       0 if (0) {
962             }
963              
964 0         0 elsif ($char =~ /\A [.|)] \z/oxms) {
965 0         0 $char = '\\' . $char;
966             }
967             }
968              
969             # [^...]
970 0         0 splice @char, $left, $right-$left+1, '(?!' . join('|', @charlist) . ")(?:$your_char)";
971              
972 0         0 $i = $left;
973 0         0 last;
974             }
975             }
976             }
977              
978             # rewrite classic character class or escape character
979             elsif (my $char = classic_character_class($char[$i])) {
980 0         0 $char[$i] = $char;
981             }
982              
983             # with /i modifier
984             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
985 0         0 my $uc = Char::Eusascii::uc($char[$i]);
986 0         0 my $fc = Char::Eusascii::fc($char[$i]);
987 0 0       0 if ($uc ne $fc) {
988 0 0       0 if (CORE::length($fc) == 1) {
989 0         0 $char[$i] = '[' . $uc . $fc . ']';
990             }
991             else {
992 0         0 $char[$i] = '(?:' . $uc . '|' . $fc . ')';
993             }
994             }
995             }
996             }
997              
998             # characterize
999 0         0 for (my $i=0; $i <= $#char; $i++) {
1000 0 0       0 next if not defined $char[$i];
1001              
1002 0 0       0 if (0) {
1003             }
1004              
1005             # quote character before ? + * {
1006 0 0       0 elsif (($i >= 1) and ($char[$i] =~ /\A [\?\+\*\{] \z/oxms)) {
1007 0 0       0 if ($char[$i-1] !~ /\A [\x00-\xFF] \z/oxms) {
1008 0         0 $char[$i-1] = '(?:' . $char[$i-1] . ')';
1009             }
1010             }
1011             }
1012              
1013 0         0 $string = join '', @char;
1014             }
1015              
1016             # make regexp string
1017 0         0 return @string;
1018             }
1019              
1020             #
1021             # classic character class ( \D \S \W \d \s \w \C \X \H \V \h \v \R \N \b \B )
1022             #
1023             sub Char::Eusascii::classic_character_class {
1024 0     0 0 0 my($char) = @_;
1025              
1026             return {
1027 0   0     0 '\D' => '${Char::Eusascii::eD}',
1028             '\S' => '${Char::Eusascii::eS}',
1029             '\W' => '${Char::Eusascii::eW}',
1030             '\d' => '[0-9]',
1031              
1032             # Before Perl 5.6, \s only matched the five whitespace characters
1033             # tab, newline, form-feed, carriage return, and the space character
1034             # itself, which, taken together, is the character class [\t\n\f\r ].
1035              
1036             # Vertical tabs are now whitespace
1037             # \s in a regex now matches a vertical tab in all circumstances.
1038             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1039             # \t \n \v \f \r space
1040             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1041             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1042             '\s' => '\s',
1043              
1044             '\w' => '[0-9A-Z_a-z]',
1045             '\C' => '[\x00-\xFF]',
1046             '\X' => 'X',
1047              
1048             # \h \v \H \V
1049              
1050             # P.114 Character Class Shortcuts
1051             # in Chapter 7: In the World of Regular Expressions
1052             # of ISBN 978-0-596-52010-6 Learning Perl, Fifth Edition
1053              
1054             # P.357 13.2.3 Whitespace
1055             # in Chapter 13: perlrecharclass: Perl Regular Expression Character Classes
1056             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1057             #
1058             # 0x00009 CHARACTER TABULATION h s
1059             # 0x0000a LINE FEED (LF) vs
1060             # 0x0000b LINE TABULATION v
1061             # 0x0000c FORM FEED (FF) vs
1062             # 0x0000d CARRIAGE RETURN (CR) vs
1063             # 0x00020 SPACE h s
1064              
1065             # P.196 Table 5-9. Alphanumeric regex metasymbols
1066             # in Chapter 5. Pattern Matching
1067             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1068              
1069             # (and so on)
1070              
1071             '\H' => '${Char::Eusascii::eH}',
1072             '\V' => '${Char::Eusascii::eV}',
1073             '\h' => '[\x09\x20]',
1074             '\v' => '[\x0A\x0B\x0C\x0D]',
1075             '\R' => '${Char::Eusascii::eR}',
1076              
1077             # \N
1078             #
1079             # http://perldoc.perl.org/perlre.html
1080             # Character Classes and other Special Escapes
1081             # Any character but \n (experimental). Not affected by /s modifier
1082              
1083             '\N' => '${Char::Eusascii::eN}',
1084              
1085             # \b \B
1086              
1087             # P.180 Boundaries: The \b and \B Assertions
1088             # in Chapter 5: Pattern Matching
1089             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1090              
1091             # P.219 Boundaries: The \b and \B Assertions
1092             # in Chapter 5: Pattern Matching
1093             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1094              
1095             # '\b' => '(?:(?<=\A|\W)(?=\w)|(?<=\w)(?=\W|\z))',
1096             '\b' => '${Char::Eusascii::eb}',
1097              
1098             # '\B' => '(?:(?<=\w)(?=\w)|(?<=\W)(?=\W))',
1099             '\B' => '${Char::Eusascii::eB}',
1100              
1101             }->{$char} || '';
1102             }
1103              
1104             #
1105             # prepare US-ASCII characters per length
1106             #
1107              
1108             # 1 octet characters
1109             my @chars1 = ();
1110             sub chars1 {
1111 0 0   0 0 0 if (@chars1) {
1112 0         0 return @chars1;
1113             }
1114 0 0       0 if (exists $range_tr{1}) {
1115 0         0 my @ranges = @{ $range_tr{1} };
  0         0  
1116 0         0 while (my @range = splice(@ranges,0,1)) {
1117 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1118 0         0 push @chars1, pack 'C', $oct0;
1119             }
1120             }
1121             }
1122 0         0 return @chars1;
1123             }
1124              
1125             # 2 octets characters
1126             my @chars2 = ();
1127             sub chars2 {
1128 0 0   0 0 0 if (@chars2) {
1129 0         0 return @chars2;
1130             }
1131 0 0       0 if (exists $range_tr{2}) {
1132 0         0 my @ranges = @{ $range_tr{2} };
  0         0  
1133 0         0 while (my @range = splice(@ranges,0,2)) {
1134 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1135 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1136 0         0 push @chars2, pack 'CC', $oct0,$oct1;
1137             }
1138             }
1139             }
1140             }
1141 0         0 return @chars2;
1142             }
1143              
1144             # 3 octets characters
1145             my @chars3 = ();
1146             sub chars3 {
1147 0 0   0 0 0 if (@chars3) {
1148 0         0 return @chars3;
1149             }
1150 0 0       0 if (exists $range_tr{3}) {
1151 0         0 my @ranges = @{ $range_tr{3} };
  0         0  
1152 0         0 while (my @range = splice(@ranges,0,3)) {
1153 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1154 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1155 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1156 0         0 push @chars3, pack 'CCC', $oct0,$oct1,$oct2;
1157             }
1158             }
1159             }
1160             }
1161             }
1162 0         0 return @chars3;
1163             }
1164              
1165             # 4 octets characters
1166             my @chars4 = ();
1167             sub chars4 {
1168 0 0   0 0 0 if (@chars4) {
1169 0         0 return @chars4;
1170             }
1171 0 0       0 if (exists $range_tr{4}) {
1172 0         0 my @ranges = @{ $range_tr{4} };
  0         0  
1173 0         0 while (my @range = splice(@ranges,0,4)) {
1174 0         0 for my $oct0 (@{$range[0]}) {
  0         0  
1175 0         0 for my $oct1 (@{$range[1]}) {
  0         0  
1176 0         0 for my $oct2 (@{$range[2]}) {
  0         0  
1177 0         0 for my $oct3 (@{$range[3]}) {
  0         0  
1178 0         0 push @chars4, pack 'CCCC', $oct0,$oct1,$oct2,$oct3;
1179             }
1180             }
1181             }
1182             }
1183             }
1184             }
1185 0         0 return @chars4;
1186             }
1187              
1188             #
1189             # US-ASCII open character list for tr
1190             #
1191             sub _charlist_tr {
1192              
1193 0     0   0 local $_ = shift @_;
1194              
1195             # unescape character
1196 0         0 my @char = ();
1197 0         0 while (not /\G \z/oxmsgc) {
1198 0 0       0 if (/\G (\\0?55|\\x2[Dd]|\\-) /oxmsgc) {
    0          
    0          
    0          
    0          
    0          
    0          
1199 0         0 push @char, '\-';
1200             }
1201             elsif (/\G \\ ([0-7]{2,3}) /oxmsgc) {
1202 0         0 push @char, CORE::chr(oct $1);
1203             }
1204             elsif (/\G \\x ([0-9A-Fa-f]{1,2}) /oxmsgc) {
1205 0         0 push @char, CORE::chr(hex $1);
1206             }
1207             elsif (/\G \\c ([\x40-\x5F]) /oxmsgc) {
1208 0         0 push @char, CORE::chr(CORE::ord($1) & 0x1F);
1209             }
1210             elsif (/\G (\\ [0nrtfbae]) /oxmsgc) {
1211 0         0 push @char, {
1212             '\0' => "\0",
1213             '\n' => "\n",
1214             '\r' => "\r",
1215             '\t' => "\t",
1216             '\f' => "\f",
1217             '\b' => "\x08", # \b means backspace in character class
1218             '\a' => "\a",
1219             '\e' => "\e",
1220             }->{$1};
1221             }
1222             elsif (/\G \\ ($q_char) /oxmsgc) {
1223 0         0 push @char, $1;
1224             }
1225             elsif (/\G ($q_char) /oxmsgc) {
1226 0         0 push @char, $1;
1227             }
1228             }
1229              
1230             # join separated multiple-octet
1231 0         0 @char = join('',@char) =~ /\G (\\-|$q_char) /oxmsg;
1232              
1233             # unescape '-'
1234 0         0 my @i = ();
1235 0         0 for my $i (0 .. $#char) {
1236 0 0       0 if ($char[$i] eq '\-') {
    0          
1237 0         0 $char[$i] = '-';
1238             }
1239             elsif ($char[$i] eq '-') {
1240 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1241 0         0 push @i, $i;
1242             }
1243             }
1244             }
1245              
1246             # open character list (reverse for splice)
1247 0         0 for my $i (CORE::reverse @i) {
1248 0         0 my @range = ();
1249              
1250             # range error
1251 0 0 0     0 if ((CORE::length($char[$i-1]) > CORE::length($char[$i+1])) or ($char[$i-1] gt $char[$i+1])) {
1252 0         0 croak "Invalid tr/// range \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1253             }
1254              
1255             # range of multiple-octet code
1256 0 0       0 if (CORE::length($char[$i-1]) == 1) {
    0          
    0          
    0          
1257 0 0       0 if (CORE::length($char[$i+1]) == 1) {
    0          
    0          
    0          
1258 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars1();
  0         0  
1259             }
1260             elsif (CORE::length($char[$i+1]) == 2) {
1261 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1262 0         0 push @range, grep {$_ le $char[$i+1]} chars2();
  0         0  
1263             }
1264             elsif (CORE::length($char[$i+1]) == 3) {
1265 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1266 0         0 push @range, chars2();
1267 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1268             }
1269             elsif (CORE::length($char[$i+1]) == 4) {
1270 0         0 push @range, grep {$char[$i-1] le $_} chars1();
  0         0  
1271 0         0 push @range, chars2();
1272 0         0 push @range, chars3();
1273 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1274             }
1275             else {
1276 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1277             }
1278             }
1279             elsif (CORE::length($char[$i-1]) == 2) {
1280 0 0       0 if (CORE::length($char[$i+1]) == 2) {
    0          
    0          
1281 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars2();
  0         0  
1282             }
1283             elsif (CORE::length($char[$i+1]) == 3) {
1284 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1285 0         0 push @range, grep {$_ le $char[$i+1]} chars3();
  0         0  
1286             }
1287             elsif (CORE::length($char[$i+1]) == 4) {
1288 0         0 push @range, grep {$char[$i-1] le $_} chars2();
  0         0  
1289 0         0 push @range, chars3();
1290 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1291             }
1292             else {
1293 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1294             }
1295             }
1296             elsif (CORE::length($char[$i-1]) == 3) {
1297 0 0       0 if (CORE::length($char[$i+1]) == 3) {
    0          
1298 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars3();
  0         0  
1299             }
1300             elsif (CORE::length($char[$i+1]) == 4) {
1301 0         0 push @range, grep {$char[$i-1] le $_} chars3();
  0         0  
1302 0         0 push @range, grep {$_ le $char[$i+1]} chars4();
  0         0  
1303             }
1304             else {
1305 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1306             }
1307             }
1308             elsif (CORE::length($char[$i-1]) == 4) {
1309 0 0       0 if (CORE::length($char[$i+1]) == 4) {
1310 0 0       0 push @range, grep {($char[$i-1] le $_) and ($_ le $char[$i+1])} chars4();
  0         0  
1311             }
1312             else {
1313 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1314             }
1315             }
1316             else {
1317 0         0 croak "Invalid tr/// range (over 4octets) \"\\x" . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]) . '"';
1318             }
1319              
1320 0         0 splice @char, $i-1, 3, @range;
1321             }
1322              
1323 0         0 return @char;
1324             }
1325              
1326             #
1327             # US-ASCII open character class
1328             #
1329             sub _cc {
1330 0 0   0   0 if (scalar(@_) == 0) {
    0          
    0          
1331 0         0 die __FILE__, ": subroutine cc got no parameter.";
1332             }
1333             elsif (scalar(@_) == 1) {
1334 0         0 return sprintf('\x%02X',$_[0]);
1335             }
1336             elsif (scalar(@_) == 2) {
1337 0 0       0 if ($_[0] > $_[1]) {
    0          
    0          
1338 0         0 die __FILE__, ": subroutine cc got \$_[0] > \$_[1] parameters).";
1339             }
1340             elsif ($_[0] == $_[1]) {
1341 0         0 return sprintf('\x%02X',$_[0]);
1342             }
1343             elsif (($_[0]+1) == $_[1]) {
1344 0         0 return sprintf('[\\x%02X\\x%02X]',$_[0],$_[1]);
1345             }
1346             else {
1347 0         0 return sprintf('[\\x%02X-\\x%02X]',$_[0],$_[1]);
1348             }
1349             }
1350             else {
1351 0         0 die __FILE__, ": subroutine cc got 3 or more parameters (@{[scalar(@_)]} parameters).";
  0         0  
1352             }
1353             }
1354              
1355             #
1356             # US-ASCII octet range
1357             #
1358             sub _octets {
1359 0     0   0 my $length = shift @_;
1360              
1361 0 0       0 if ($length == 1) {
1362 0         0 my($a1) = unpack 'C', $_[0];
1363 0         0 my($z1) = unpack 'C', $_[1];
1364              
1365 0 0       0 if ($a1 > $z1) {
1366 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$a1) . '-\x' . unpack('H*',$z1);
1367             }
1368              
1369 0 0       0 if ($a1 == $z1) {
    0          
1370 0         0 return sprintf('\x%02X',$a1);
1371             }
1372             elsif (($a1+1) == $z1) {
1373 0         0 return sprintf('\x%02X\x%02X',$a1,$z1);
1374             }
1375             else {
1376 0         0 return sprintf('\x%02X-\x%02X',$a1,$z1);
1377             }
1378             }
1379             else {
1380 0         0 die __FILE__, ": subroutine _octets got invalid length ($length).";
1381             }
1382             }
1383              
1384             #
1385             # US-ASCII range regexp
1386             #
1387             sub _range_regexp {
1388 0     0   0 my($length,$first,$last) = @_;
1389              
1390 0         0 my @range_regexp = ();
1391 0 0       0 if (not exists $range_tr{$length}) {
1392 0         0 return @range_regexp;
1393             }
1394              
1395 0         0 my @ranges = @{ $range_tr{$length} };
  0         0  
1396 0         0 while (my @range = splice(@ranges,0,$length)) {
1397 0         0 my $min = '';
1398 0         0 my $max = '';
1399 0         0 for (my $i=0; $i < $length; $i++) {
1400 0         0 $min .= pack 'C', $range[$i][0];
1401 0         0 $max .= pack 'C', $range[$i][-1];
1402             }
1403              
1404             # min___max
1405             # FIRST_____________LAST
1406             # (nothing)
1407              
1408 0 0 0     0 if ($max lt $first) {
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
    0 0        
1409             }
1410              
1411             # **********
1412             # min_________max
1413             # FIRST_____________LAST
1414             # **********
1415              
1416             elsif (($min le $first) and ($first le $max) and ($max le $last)) {
1417 0         0 push @range_regexp, _octets($length,$first,$max,$min,$max);
1418             }
1419              
1420             # **********************
1421             # min________________max
1422             # FIRST_____________LAST
1423             # **********************
1424              
1425             elsif (($min eq $first) and ($max eq $last)) {
1426 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1427             }
1428              
1429             # *********
1430             # min___max
1431             # FIRST_____________LAST
1432             # *********
1433              
1434             elsif (($first le $min) and ($max le $last)) {
1435 0         0 push @range_regexp, _octets($length,$min,$max,$min,$max);
1436             }
1437              
1438             # **********************
1439             # min__________________________max
1440             # FIRST_____________LAST
1441             # **********************
1442              
1443             elsif (($min le $first) and ($last le $max)) {
1444 0         0 push @range_regexp, _octets($length,$first,$last,$min,$max);
1445             }
1446              
1447             # *********
1448             # min________max
1449             # FIRST_____________LAST
1450             # *********
1451              
1452             elsif (($first le $min) and ($min le $last) and ($last le $max)) {
1453 0         0 push @range_regexp, _octets($length,$min,$last,$min,$max);
1454             }
1455              
1456             # min___max
1457             # FIRST_____________LAST
1458             # (nothing)
1459              
1460             elsif ($last lt $min) {
1461             }
1462              
1463             else {
1464 0         0 die __FILE__, ": subroutine _range_regexp panic.";
1465             }
1466             }
1467              
1468 0         0 return @range_regexp;
1469             }
1470              
1471             #
1472             # US-ASCII open character list for qr and not qr
1473             #
1474             sub _charlist {
1475              
1476 0     0   0 my $modifier = pop @_;
1477 0         0 my @char = @_;
1478              
1479 0 0       0 my $ignorecase = ($modifier =~ /i/oxms) ? 1 : 0;
1480              
1481             # unescape character
1482 0         0 for (my $i=0; $i <= $#char; $i++) {
1483              
1484             # escape - to ...
1485 0 0 0     0 if ($char[$i] eq '-') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
1486 0 0 0     0 if ((0 < $i) and ($i < $#char)) {
1487 0         0 $char[$i] = '...';
1488             }
1489             }
1490              
1491             # octal escape sequence
1492             elsif ($char[$i] =~ /\A \\o \{ ([0-7]+) \} \z/oxms) {
1493 0         0 $char[$i] = octchr($1);
1494             }
1495              
1496             # hexadecimal escape sequence
1497             elsif ($char[$i] =~ /\A \\x \{ ([0-9A-Fa-f]+) \} \z/oxms) {
1498 0         0 $char[$i] = hexchr($1);
1499             }
1500              
1501             # \N{CHARNAME} --> N\{CHARNAME}
1502             elsif ($char[$i] =~ /\A \\ (N) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1503 0         0 $char[$i] = $1 . '\\' . $2;
1504             }
1505              
1506             # \p{PROPERTY} --> p\{PROPERTY}
1507             elsif ($char[$i] =~ /\A \\ (p) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1508 0         0 $char[$i] = $1 . '\\' . $2;
1509             }
1510              
1511             # \P{PROPERTY} --> P\{PROPERTY}
1512             elsif ($char[$i] =~ /\A \\ (P) ( \{ ([^0-9\}][^\}]*) \} ) \z/oxms) {
1513 0         0 $char[$i] = $1 . '\\' . $2;
1514             }
1515              
1516             # \p, \P, \X --> p, P, X
1517             elsif ($char[$i] =~ /\A \\ ( [pPX] ) \z/oxms) {
1518 0         0 $char[$i] = $1;
1519             }
1520              
1521             elsif ($char[$i] =~ /\A \\ ([0-7]{2,3}) \z/oxms) {
1522 0         0 $char[$i] = CORE::chr oct $1;
1523             }
1524             elsif ($char[$i] =~ /\A \\x ([0-9A-Fa-f]{1,2}) \z/oxms) {
1525 0         0 $char[$i] = CORE::chr hex $1;
1526             }
1527             elsif ($char[$i] =~ /\A \\c ([\x40-\x5F]) \z/oxms) {
1528 0         0 $char[$i] = CORE::chr(CORE::ord($1) & 0x1F);
1529             }
1530             elsif ($char[$i] =~ /\A (\\ [0nrtfbaedswDSWHVhvR]) \z/oxms) {
1531 0         0 $char[$i] = {
1532             '\0' => "\0",
1533             '\n' => "\n",
1534             '\r' => "\r",
1535             '\t' => "\t",
1536             '\f' => "\f",
1537             '\b' => "\x08", # \b means backspace in character class
1538             '\a' => "\a",
1539             '\e' => "\e",
1540             '\d' => '[0-9]',
1541              
1542             # Vertical tabs are now whitespace
1543             # \s in a regex now matches a vertical tab in all circumstances.
1544             # http://search.cpan.org/dist/perl-5.18.0/pod/perldelta.pod#Vertical_tabs_are_now_whitespace
1545             # \t \n \v \f \r space
1546             # '\s' => '[\x09\x0A \x0C\x0D\x20]',
1547             # '\s' => '[\x09\x0A\x0B\x0C\x0D\x20]',
1548             '\s' => '\s',
1549              
1550             '\w' => '[0-9A-Z_a-z]',
1551             '\D' => '${Char::Eusascii::eD}',
1552             '\S' => '${Char::Eusascii::eS}',
1553             '\W' => '${Char::Eusascii::eW}',
1554              
1555             '\H' => '${Char::Eusascii::eH}',
1556             '\V' => '${Char::Eusascii::eV}',
1557             '\h' => '[\x09\x20]',
1558             '\v' => '[\x0A\x0B\x0C\x0D]',
1559             '\R' => '${Char::Eusascii::eR}',
1560              
1561             }->{$1};
1562             }
1563              
1564             # POSIX-style character classes
1565             elsif ($ignorecase and ($char[$i] =~ /\A ( \[\: \^? (?:lower|upper) :\] ) \z/oxms)) {
1566 0         0 $char[$i] = {
1567              
1568             '[:lower:]' => '[\x41-\x5A\x61-\x7A]',
1569             '[:upper:]' => '[\x41-\x5A\x61-\x7A]',
1570             '[:^lower:]' => '${Char::Eusascii::not_lower_i}',
1571             '[:^upper:]' => '${Char::Eusascii::not_upper_i}',
1572              
1573             }->{$1};
1574             }
1575             elsif ($char[$i] =~ /\A ( \[\: \^? (?:alnum|alpha|ascii|blank|cntrl|digit|graph|lower|print|punct|space|upper|word|xdigit) :\] ) \z/oxms) {
1576 0         0 $char[$i] = {
1577              
1578             '[:alnum:]' => '[\x30-\x39\x41-\x5A\x61-\x7A]',
1579             '[:alpha:]' => '[\x41-\x5A\x61-\x7A]',
1580             '[:ascii:]' => '[\x00-\x7F]',
1581             '[:blank:]' => '[\x09\x20]',
1582             '[:cntrl:]' => '[\x00-\x1F\x7F]',
1583             '[:digit:]' => '[\x30-\x39]',
1584             '[:graph:]' => '[\x21-\x7F]',
1585             '[:lower:]' => '[\x61-\x7A]',
1586             '[:print:]' => '[\x20-\x7F]',
1587             '[:punct:]' => '[\x21-\x2F\x3A-\x3F\x40\x5B-\x5F\x60\x7B-\x7E]',
1588              
1589             # P.174 POSIX-Style Character Classes
1590             # in Chapter 5: Pattern Matching
1591             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
1592              
1593             # P.311 11.2.4 Character Classes and other Special Escapes
1594             # in Chapter 11: perlre: Perl regular expressions
1595             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
1596              
1597             # P.210 POSIX-Style Character Classes
1598             # in Chapter 5: Pattern Matching
1599             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
1600              
1601             '[:space:]' => '[\s\x0B]', # "\s" plus vertical tab ("\cK")
1602              
1603             '[:upper:]' => '[\x41-\x5A]',
1604             '[:word:]' => '[\x30-\x39\x41-\x5A\x5F\x61-\x7A]',
1605             '[:xdigit:]' => '[\x30-\x39\x41-\x46\x61-\x66]',
1606             '[:^alnum:]' => '${Char::Eusascii::not_alnum}',
1607             '[:^alpha:]' => '${Char::Eusascii::not_alpha}',
1608             '[:^ascii:]' => '${Char::Eusascii::not_ascii}',
1609             '[:^blank:]' => '${Char::Eusascii::not_blank}',
1610             '[:^cntrl:]' => '${Char::Eusascii::not_cntrl}',
1611             '[:^digit:]' => '${Char::Eusascii::not_digit}',
1612             '[:^graph:]' => '${Char::Eusascii::not_graph}',
1613             '[:^lower:]' => '${Char::Eusascii::not_lower}',
1614             '[:^print:]' => '${Char::Eusascii::not_print}',
1615             '[:^punct:]' => '${Char::Eusascii::not_punct}',
1616             '[:^space:]' => '${Char::Eusascii::not_space}',
1617             '[:^upper:]' => '${Char::Eusascii::not_upper}',
1618             '[:^word:]' => '${Char::Eusascii::not_word}',
1619             '[:^xdigit:]' => '${Char::Eusascii::not_xdigit}',
1620              
1621             }->{$1};
1622             }
1623             elsif ($char[$i] =~ /\A \\ ($q_char) \z/oxms) {
1624 0         0 $char[$i] = $1;
1625             }
1626             }
1627              
1628             # open character list
1629 0         0 my @singleoctet = ();
1630 0         0 my @multipleoctet = ();
1631 0         0 for (my $i=0; $i <= $#char; ) {
1632              
1633             # escaped -
1634 0 0 0     0 if (defined($char[$i+1]) and ($char[$i+1] eq '...')) {
    0          
    0          
    0          
    0          
    0          
1635 0         0 $i += 1;
1636 0         0 next;
1637             }
1638              
1639             # make range regexp
1640             elsif ($char[$i] eq '...') {
1641              
1642             # range error
1643 0 0       0 if (CORE::length($char[$i-1]) > CORE::length($char[$i+1])) {
    0          
1644 0         0 croak 'Invalid [] range in regexp (length(A) > length(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1645             }
1646             elsif (CORE::length($char[$i-1]) == CORE::length($char[$i+1])) {
1647 0 0       0 if ($char[$i-1] gt $char[$i+1]) {
1648 0         0 croak 'Invalid [] range in regexp (CORE::ord(A) > CORE::ord(B)) ' . '\x' . unpack('H*',$char[$i-1]) . '-\x' . unpack('H*',$char[$i+1]);
1649             }
1650             }
1651              
1652             # make range regexp per length
1653 0         0 for my $length (CORE::length($char[$i-1]) .. CORE::length($char[$i+1])) {
1654 0         0 my @regexp = ();
1655              
1656             # is first and last
1657 0 0 0     0 if (($length == CORE::length($char[$i-1])) and ($length == CORE::length($char[$i+1]))) {
    0 0        
    0          
    0          
1658 0         0 push @regexp, _range_regexp($length, $char[$i-1], $char[$i+1]);
1659             }
1660              
1661             # is first
1662             elsif ($length == CORE::length($char[$i-1])) {
1663 0         0 push @regexp, _range_regexp($length, $char[$i-1], "\xFF" x $length);
1664             }
1665              
1666             # is inside in first and last
1667             elsif ((CORE::length($char[$i-1]) < $length) and ($length < CORE::length($char[$i+1]))) {
1668 0         0 push @regexp, _range_regexp($length, "\x00" x $length, "\xFF" x $length);
1669             }
1670              
1671             # is last
1672             elsif ($length == CORE::length($char[$i+1])) {
1673 0         0 push @regexp, _range_regexp($length, "\x00" x $length, $char[$i+1]);
1674             }
1675              
1676             else {
1677 0         0 die __FILE__, ": subroutine make_regexp panic.";
1678             }
1679              
1680 0 0       0 if ($length == 1) {
1681 0         0 push @singleoctet, @regexp;
1682             }
1683             else {
1684 0         0 push @multipleoctet, @regexp;
1685             }
1686             }
1687              
1688 0         0 $i += 2;
1689             }
1690              
1691             # with /i modifier
1692             elsif ($char[$i] =~ /\A [\x00-\xFF] \z/oxms) {
1693 0 0       0 if ($modifier =~ /i/oxms) {
1694 0         0 my $uc = Char::Eusascii::uc($char[$i]);
1695 0         0 my $fc = Char::Eusascii::fc($char[$i]);
1696 0 0       0 if ($uc ne $fc) {
1697 0 0       0 if (CORE::length($fc) == 1) {
1698 0         0 push @singleoctet, $uc, $fc;
1699             }
1700             else {
1701 0         0 push @singleoctet, $uc;
1702 0         0 push @multipleoctet, $fc;
1703             }
1704             }
1705             else {
1706 0         0 push @singleoctet, $char[$i];
1707             }
1708             }
1709             else {
1710 0         0 push @singleoctet, $char[$i];
1711             }
1712 0         0 $i += 1;
1713             }
1714              
1715             # single character of single octet code
1716             elsif ($char[$i] =~ /\A (?: \\h ) \z/oxms) {
1717 0         0 push @singleoctet, "\t", "\x20";
1718 0         0 $i += 1;
1719             }
1720             elsif ($char[$i] =~ /\A (?: \\v ) \z/oxms) {
1721 0         0 push @singleoctet, "\x0A", "\x0B", "\x0C", "\x0D";
1722 0         0 $i += 1;
1723             }
1724             elsif ($char[$i] =~ /\A (?: \\d | \\s | \\w ) \z/oxms) {
1725 0         0 push @singleoctet, $char[$i];
1726 0         0 $i += 1;
1727             }
1728              
1729             # single character of multiple-octet code
1730             else {
1731 0         0 push @multipleoctet, $char[$i];
1732 0         0 $i += 1;
1733             }
1734             }
1735              
1736             # quote metachar
1737 0         0 for (@singleoctet) {
1738 0 0       0 if ($_ eq '...') {
    0          
    0          
    0          
    0          
1739 0         0 $_ = '-';
1740             }
1741             elsif (/\A \n \z/oxms) {
1742 0         0 $_ = '\n';
1743             }
1744             elsif (/\A \r \z/oxms) {
1745 0         0 $_ = '\r';
1746             }
1747             elsif (/\A ([\x00-\x20\x7F-\xFF]) \z/oxms) {
1748 0         0 $_ = sprintf('\x%02X', CORE::ord $1);
1749             }
1750             elsif (/\A [\x00-\xFF] \z/oxms) {
1751 0         0 $_ = quotemeta $_;
1752             }
1753             }
1754              
1755             # return character list
1756 0         0 return \@singleoctet, \@multipleoctet;
1757             }
1758              
1759             #
1760             # US-ASCII octal escape sequence
1761             #
1762             sub octchr {
1763 0     0 0 0 my($octdigit) = @_;
1764              
1765 0         0 my @binary = ();
1766 0         0 for my $octal (split(//,$octdigit)) {
1767 0         0 push @binary, {
1768             '0' => '000',
1769             '1' => '001',
1770             '2' => '010',
1771             '3' => '011',
1772             '4' => '100',
1773             '5' => '101',
1774             '6' => '110',
1775             '7' => '111',
1776             }->{$octal};
1777             }
1778 0         0 my $binary = join '', @binary;
1779              
1780 0         0 my $octchr = {
1781             # 1234567
1782             1 => pack('B*', "0000000$binary"),
1783             2 => pack('B*', "000000$binary"),
1784             3 => pack('B*', "00000$binary"),
1785             4 => pack('B*', "0000$binary"),
1786             5 => pack('B*', "000$binary"),
1787             6 => pack('B*', "00$binary"),
1788             7 => pack('B*', "0$binary"),
1789             0 => pack('B*', "$binary"),
1790              
1791             }->{CORE::length($binary) % 8};
1792              
1793 0         0 return $octchr;
1794             }
1795              
1796             #
1797             # US-ASCII hexadecimal escape sequence
1798             #
1799             sub hexchr {
1800 0     0 0 0 my($hexdigit) = @_;
1801              
1802 0         0 my $hexchr = {
1803             1 => pack('H*', "0$hexdigit"),
1804             0 => pack('H*', "$hexdigit"),
1805              
1806             }->{CORE::length($_[0]) % 2};
1807              
1808 0         0 return $hexchr;
1809             }
1810              
1811             #
1812             # US-ASCII open character list for qr
1813             #
1814             sub charlist_qr {
1815              
1816 0     0 0 0 my $modifier = pop @_;
1817 0         0 my @char = @_;
1818              
1819 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1820 0         0 my @singleoctet = @$singleoctet;
1821 0         0 my @multipleoctet = @$multipleoctet;
1822              
1823             # return character list
1824 0 0       0 if (scalar(@singleoctet) >= 1) {
1825              
1826             # with /i modifier
1827 0 0       0 if ($modifier =~ m/i/oxms) {
1828 0         0 my %singleoctet_ignorecase = ();
1829 0         0 for (@singleoctet) {
1830 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1831 0         0 for my $ord (hex($1) .. hex($2)) {
1832 0         0 my $char = CORE::chr($ord);
1833 0         0 my $uc = Char::Eusascii::uc($char);
1834 0         0 my $fc = Char::Eusascii::fc($char);
1835 0 0       0 if ($uc eq $fc) {
1836 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1837             }
1838             else {
1839 0 0       0 if (CORE::length($fc) == 1) {
1840 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1841 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1842             }
1843             else {
1844 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1845 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1846             }
1847             }
1848             }
1849             }
1850 0 0       0 if ($_ ne '') {
1851 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1852             }
1853             }
1854 0         0 my $i = 0;
1855 0         0 my @singleoctet_ignorecase = ();
1856 0         0 for my $ord (0 .. 255) {
1857 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1858 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1859             }
1860             else {
1861 0         0 $i++;
1862             }
1863             }
1864 0         0 @singleoctet = ();
1865 0         0 for my $range (@singleoctet_ignorecase) {
1866 0 0       0 if (ref $range) {
1867 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1868 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1869             }
1870             elsif (scalar(@{$range}) == 2) {
1871 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1872             }
1873             else {
1874 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1875             }
1876             }
1877             }
1878             }
1879              
1880 0         0 my $not_anchor = '';
1881              
1882 0         0 push @multipleoctet, join('', $not_anchor, '[', @singleoctet, ']' );
1883             }
1884 0 0       0 if (scalar(@multipleoctet) >= 2) {
1885 0         0 return '(?:' . join('|', @multipleoctet) . ')';
1886             }
1887             else {
1888 0         0 return $multipleoctet[0];
1889             }
1890             }
1891              
1892             #
1893             # US-ASCII open character list for not qr
1894             #
1895             sub charlist_not_qr {
1896              
1897 0     0 0 0 my $modifier = pop @_;
1898 0         0 my @char = @_;
1899              
1900 0         0 my($singleoctet, $multipleoctet) = _charlist(@char, $modifier);
1901 0         0 my @singleoctet = @$singleoctet;
1902 0         0 my @multipleoctet = @$multipleoctet;
1903              
1904             # with /i modifier
1905 0 0       0 if ($modifier =~ m/i/oxms) {
1906 0         0 my %singleoctet_ignorecase = ();
1907 0         0 for (@singleoctet) {
1908 0   0     0 while (s/ \A \\x(..) - \\x(..) //oxms or s/ \A \\x((..)) //oxms) {
1909 0         0 for my $ord (hex($1) .. hex($2)) {
1910 0         0 my $char = CORE::chr($ord);
1911 0         0 my $uc = Char::Eusascii::uc($char);
1912 0         0 my $fc = Char::Eusascii::fc($char);
1913 0 0       0 if ($uc eq $fc) {
1914 0         0 $singleoctet_ignorecase{unpack 'C*', $char} = 1;
1915             }
1916             else {
1917 0 0       0 if (CORE::length($fc) == 1) {
1918 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1919 0         0 $singleoctet_ignorecase{unpack 'C*', $fc} = 1;
1920             }
1921             else {
1922 0         0 $singleoctet_ignorecase{unpack 'C*', $uc} = 1;
1923 0         0 push @multipleoctet, join '', map {sprintf('\x%02X',$_)} unpack 'C*', $fc;
  0         0  
1924             }
1925             }
1926             }
1927             }
1928 0 0       0 if ($_ ne '') {
1929 0         0 $singleoctet_ignorecase{unpack 'C*', $_} = 1;
1930             }
1931             }
1932 0         0 my $i = 0;
1933 0         0 my @singleoctet_ignorecase = ();
1934 0         0 for my $ord (0 .. 255) {
1935 0 0       0 if (exists $singleoctet_ignorecase{$ord}) {
1936 0         0 push @{$singleoctet_ignorecase[$i]}, $ord;
  0         0  
1937             }
1938             else {
1939 0         0 $i++;
1940             }
1941             }
1942 0         0 @singleoctet = ();
1943 0         0 for my $range (@singleoctet_ignorecase) {
1944 0 0       0 if (ref $range) {
1945 0 0       0 if (scalar(@{$range}) == 1) {
  0 0       0  
  0         0  
1946 0         0 push @singleoctet, sprintf('\x%02X', @{$range}[0]);
  0         0  
1947             }
1948             elsif (scalar(@{$range}) == 2) {
1949 0         0 push @singleoctet, sprintf('\x%02X\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1950             }
1951             else {
1952 0         0 push @singleoctet, sprintf('\x%02X-\x%02X', @{$range}[0], @{$range}[-1]);
  0         0  
  0         0  
1953             }
1954             }
1955             }
1956             }
1957              
1958             # return character list
1959 0 0       0 if (scalar(@multipleoctet) >= 1) {
1960 0 0       0 if (scalar(@singleoctet) >= 1) {
1961              
1962             # any character other than multiple-octet and single octet character class
1963 0         0 return '(?!' . join('|', @multipleoctet) . ')(?:[^' . join('', @singleoctet) . '])';
1964             }
1965             else {
1966              
1967             # any character other than multiple-octet character class
1968 0         0 return '(?!' . join('|', @multipleoctet) . ")(?:$your_char)";
1969             }
1970             }
1971             else {
1972 0 0       0 if (scalar(@singleoctet) >= 1) {
1973              
1974             # any character other than single octet character class
1975 0         0 return '(?:[^' . join('', @singleoctet) . '])';
1976             }
1977             else {
1978              
1979             # any character
1980 0         0 return "(?:$your_char)";
1981             }
1982             }
1983             }
1984              
1985             #
1986             # open file in read mode
1987             #
1988             sub _open_r {
1989 177     177   617 my(undef,$file) = @_;
1990 177         1084 $file =~ s#\A (\s) #./$1#oxms;
1991 177   33     15801 return eval(q{open($_[0],'<',$_[1])}) ||
1992             open($_[0],"< $file\0");
1993             }
1994              
1995             #
1996             # open file in write mode
1997             #
1998             sub _open_w {
1999 0     0   0 my(undef,$file) = @_;
2000 0         0 $file =~ s#\A (\s) #./$1#oxms;
2001 0   0     0 return eval(q{open($_[0],'>',$_[1])}) ||
2002             open($_[0],"> $file\0");
2003             }
2004              
2005             #
2006             # open file in append mode
2007             #
2008             sub _open_a {
2009 0     0   0 my(undef,$file) = @_;
2010 0         0 $file =~ s#\A (\s) #./$1#oxms;
2011 0   0     0 return eval(q{open($_[0],'>>',$_[1])}) ||
2012             open($_[0],">> $file\0");
2013             }
2014              
2015             #
2016             # safe system
2017             #
2018             sub _systemx {
2019              
2020             # P.707 29.2.33. exec
2021             # in Chapter 29: Functions
2022             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2023             #
2024             # Be aware that in older releases of Perl, exec (and system) did not flush
2025             # your output buffer, so you needed to enable command buffering by setting $|
2026             # on one or more filehandles to avoid lost output in the case of exec, or
2027             # misordererd output in the case of system. This situation was largely remedied
2028             # in the 5.6 release of Perl. (So, 5.005 release not yet.)
2029              
2030             # P.855 exec
2031             # in Chapter 27: Functions
2032             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2033             #
2034             # In very old release of Perl (before v5.6), exec (and system) did not flush
2035             # your output buffer, so you needed to enable command buffering by setting $|
2036             # on one or more filehandles to avoid lost output with exec or misordered
2037             # output with system.
2038              
2039 177     177   739 $| = 1;
2040              
2041             # P.565 23.1.2. Cleaning Up Your Environment
2042             # in Chapter 23: Security
2043             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2044              
2045             # P.656 Cleaning Up Your Environment
2046             # in Chapter 20: Security
2047             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2048              
2049             # local $ENV{'PATH'} = '.';
2050 177         2833 local @ENV{qw(IFS CDPATH ENV BASH_ENV)}; # Make %ENV safer
2051              
2052             # P.707 29.2.33. exec
2053             # in Chapter 29: Functions
2054             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2055             #
2056             # As we mentioned earlier, exec treats a discrete list of arguments as an
2057             # indication that it should bypass shell processing. However, there is one
2058             # place where you might still get tripped up. The exec call (and system, too)
2059             # will not distinguish between a single scalar argument and an array containing
2060             # only one element.
2061             #
2062             # @args = ("echo surprise"); # just one element in list
2063             # exec @args # still subject to shell escapes
2064             # or die "exec: $!"; # because @args == 1
2065             #
2066             # To avoid this, you can use the PATHNAME syntax, explicitly duplicating the
2067             # first argument as the pathname, which forces the rest of the arguments to be
2068             # interpreted as a list, even if there is only one of them:
2069             #
2070             # exec { $args[0] } @args # safe even with one-argument list
2071             # or die "can't exec @args: $!";
2072              
2073             # P.855 exec
2074             # in Chapter 27: Functions
2075             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2076             #
2077             # As we mentioned earlier, exec treats a discrete list of arguments as a
2078             # directive to bypass shell processing. However, there is one place where
2079             # you might still get tripped up. The exec call (and system, too) cannot
2080             # distinguish between a single scalar argument and an array containing
2081             # only one element.
2082             #
2083             # @args = ("echo surprise"); # just one element in list
2084             # exec @args # still subject to shell escapes
2085             # || die "exec: $!"; # because @args == 1
2086             #
2087             # To avoid this, use the PATHNAME syntax, explicitly duplicating the first
2088             # argument as the pathname, which forces the rest of the arguments to be
2089             # interpreted as a list, even if there is only one of them:
2090             #
2091             # exec { $args[0] } @args # safe even with one-argument list
2092             # || die "can't exec @args: $!";
2093              
2094 177         417 return CORE::system { $_[0] } @_; # safe even with one-argument list
  177         11007014  
2095             }
2096              
2097             #
2098             # US-ASCII order to character (with parameter)
2099             #
2100             sub Char::Eusascii::chr(;$) {
2101              
2102 0 0   0 0   my $c = @_ ? $_[0] : $_;
2103              
2104 0 0         if ($c == 0x00) {
2105 0           return "\x00";
2106             }
2107             else {
2108 0           my @chr = ();
2109 0           while ($c > 0) {
2110 0           unshift @chr, ($c % 0x100);
2111 0           $c = int($c / 0x100);
2112             }
2113 0           return pack 'C*', @chr;
2114             }
2115             }
2116              
2117             #
2118             # US-ASCII order to character (without parameter)
2119             #
2120             sub Char::Eusascii::chr_() {
2121              
2122 0     0 0   my $c = $_;
2123              
2124 0 0         if ($c == 0x00) {
2125 0           return "\x00";
2126             }
2127             else {
2128 0           my @chr = ();
2129 0           while ($c > 0) {
2130 0           unshift @chr, ($c % 0x100);
2131 0           $c = int($c / 0x100);
2132             }
2133 0           return pack 'C*', @chr;
2134             }
2135             }
2136              
2137             #
2138             # US-ASCII path globbing (with parameter)
2139             #
2140             sub Char::Eusascii::glob($) {
2141              
2142 0 0   0 0   if (wantarray) {
2143 0           my @glob = _DOS_like_glob(@_);
2144 0           for my $glob (@glob) {
2145 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2146             }
2147 0           return @glob;
2148             }
2149             else {
2150 0           my $glob = _DOS_like_glob(@_);
2151 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2152 0           return $glob;
2153             }
2154             }
2155              
2156             #
2157             # US-ASCII path globbing (without parameter)
2158             #
2159             sub Char::Eusascii::glob_() {
2160              
2161 0 0   0 0   if (wantarray) {
2162 0           my @glob = _DOS_like_glob();
2163 0           for my $glob (@glob) {
2164 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2165             }
2166 0           return @glob;
2167             }
2168             else {
2169 0           my $glob = _DOS_like_glob();
2170 0           $glob =~ s{ \A (?:\./)+ }{}oxms;
2171 0           return $glob;
2172             }
2173             }
2174              
2175             #
2176             # US-ASCII path globbing via File::DosGlob 1.10
2177             #
2178             # Often I confuse "_dosglob" and "_doglob".
2179             # So, I renamed "_dosglob" to "_DOS_like_glob".
2180             #
2181             my %iter;
2182             my %entries;
2183             sub _DOS_like_glob {
2184              
2185             # context (keyed by second cxix argument provided by core)
2186 0     0     my($expr,$cxix) = @_;
2187              
2188             # glob without args defaults to $_
2189 0 0         $expr = $_ if not defined $expr;
2190              
2191             # represents the current user's home directory
2192             #
2193             # 7.3. Expanding Tildes in Filenames
2194             # in Chapter 7. File Access
2195             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2196             #
2197             # and File::HomeDir, File::HomeDir::Windows module
2198              
2199             # DOS-like system
2200 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2201 0           $expr =~ s{ \A ~ (?= [^/\\] ) }
2202 0           { my_home_MSWin32() }oxmse;
2203             }
2204              
2205             # UNIX-like system
2206             else {
2207 0           $expr =~ s{ \A ~ ( (?:[^/])* ) }
2208 0 0 0       { $1 ? (eval(q{(getpwnam($1))[7]})||my_home()) : my_home() }oxmse;
2209             }
2210              
2211             # assume global context if not provided one
2212 0 0         $cxix = '_G_' if not defined $cxix;
2213 0 0         $iter{$cxix} = 0 if not exists $iter{$cxix};
2214              
2215             # if we're just beginning, do it all first
2216 0 0         if ($iter{$cxix} == 0) {
2217 0           $entries{$cxix} = [ _do_glob(1, _parse_line($expr)) ];
2218             }
2219              
2220             # chuck it all out, quick or slow
2221 0 0         if (wantarray) {
2222 0           delete $iter{$cxix};
2223 0           return @{delete $entries{$cxix}};
  0            
2224             }
2225             else {
2226 0 0         if ($iter{$cxix} = scalar @{$entries{$cxix}}) {
  0            
2227 0           return shift @{$entries{$cxix}};
  0            
2228             }
2229             else {
2230             # return undef for EOL
2231 0           delete $iter{$cxix};
2232 0           delete $entries{$cxix};
2233 0           return undef;
2234             }
2235             }
2236             }
2237              
2238             #
2239             # US-ASCII path globbing subroutine
2240             #
2241             sub _do_glob {
2242              
2243 0     0     my($cond,@expr) = @_;
2244 0           my @glob = ();
2245 0           my $fix_drive_relative_paths = 0;
2246              
2247             OUTER:
2248 0           for my $expr (@expr) {
2249 0 0         next OUTER if not defined $expr;
2250 0 0         next OUTER if $expr eq '';
2251              
2252 0           my @matched = ();
2253 0           my @globdir = ();
2254 0           my $head = '.';
2255 0           my $pathsep = '/';
2256 0           my $tail;
2257              
2258             # if argument is within quotes strip em and do no globbing
2259 0 0         if ($expr =~ /\A " ((?:$q_char)*) " \z/oxms) {
2260 0           $expr = $1;
2261 0 0         if ($cond eq 'd') {
2262 0 0         if (-d $expr) {
2263 0           push @glob, $expr;
2264             }
2265             }
2266             else {
2267 0 0         if (-e $expr) {
2268 0           push @glob, $expr;
2269             }
2270             }
2271 0           next OUTER;
2272             }
2273              
2274             # wildcards with a drive prefix such as h:*.pm must be changed
2275             # to h:./*.pm to expand correctly
2276 0 0         if ($^O =~ /\A (?: MSWin32 | NetWare | symbian | dos ) \z/oxms) {
2277 0 0         if ($expr =~ s# \A ((?:[A-Za-z]:)?) ([^/\\]) #$1./$2#oxms) {
2278 0           $fix_drive_relative_paths = 1;
2279             }
2280             }
2281              
2282 0 0         if (($head, $tail) = _parse_path($expr,$pathsep)) {
2283 0 0         if ($tail eq '') {
2284 0           push @glob, $expr;
2285 0           next OUTER;
2286             }
2287 0 0         if ($head =~ / \A (?:$q_char)*? [*?] /oxms) {
2288 0 0         if (@globdir = _do_glob('d', $head)) {
2289 0           push @glob, _do_glob($cond, map {"$_$pathsep$tail"} @globdir);
  0            
2290 0           next OUTER;
2291             }
2292             }
2293 0 0 0       if ($head eq '' or $head =~ /\A [A-Za-z]: \z/oxms) {
2294 0           $head .= $pathsep;
2295             }
2296 0           $expr = $tail;
2297             }
2298              
2299             # If file component has no wildcards, we can avoid opendir
2300 0 0         if ($expr !~ / \A (?:$q_char)*? [*?] /oxms) {
2301 0 0         if ($head eq '.') {
2302 0           $head = '';
2303             }
2304 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2305 0           $head .= $pathsep;
2306             }
2307 0           $head .= $expr;
2308 0 0         if ($cond eq 'd') {
2309 0 0         if (-d $head) {
2310 0           push @glob, $head;
2311             }
2312             }
2313             else {
2314 0 0         if (-e $head) {
2315 0           push @glob, $head;
2316             }
2317             }
2318 0           next OUTER;
2319             }
2320 0 0         opendir(*DIR, $head) or next OUTER;
2321 0           my @leaf = readdir DIR;
2322 0           closedir DIR;
2323              
2324 0 0         if ($head eq '.') {
2325 0           $head = '';
2326             }
2327 0 0 0       if ($head ne '' and ($head =~ / \G ($q_char) /oxmsg)[-1] ne $pathsep) {
2328 0           $head .= $pathsep;
2329             }
2330              
2331 0           my $pattern = '';
2332 0           while ($expr =~ / \G ($q_char) /oxgc) {
2333 0           my $char = $1;
2334              
2335             # 6.9. Matching Shell Globs as Regular Expressions
2336             # in Chapter 6. Pattern Matching
2337             # of ISBN 0-596-00313-7 Perl Cookbook, 2nd Edition.
2338             # (and so on)
2339              
2340 0 0         if ($char eq '*') {
    0          
    0          
2341 0           $pattern .= "(?:$your_char)*",
2342             }
2343             elsif ($char eq '?') {
2344 0           $pattern .= "(?:$your_char)?", # DOS style
2345             # $pattern .= "(?:$your_char)", # UNIX style
2346             }
2347             elsif ((my $fc = Char::Eusascii::fc($char)) ne $char) {
2348 0           $pattern .= $fc;
2349             }
2350             else {
2351 0           $pattern .= quotemeta $char;
2352             }
2353             }
2354 0     0     my $matchsub = sub { Char::Eusascii::fc($_[0]) =~ /\A $pattern \z/xms };
  0            
2355              
2356             # if ($@) {
2357             # print STDERR "$0: $@\n";
2358             # next OUTER;
2359             # }
2360              
2361             INNER:
2362 0           for my $leaf (@leaf) {
2363 0 0 0       if ($leaf eq '.' or $leaf eq '..') {
2364 0           next INNER;
2365             }
2366 0 0 0       if ($cond eq 'd' and not -d "$head$leaf") {
2367 0           next INNER;
2368             }
2369              
2370 0 0         if (&$matchsub($leaf)) {
2371 0           push @matched, "$head$leaf";
2372 0           next INNER;
2373             }
2374              
2375             # [DOS compatibility special case]
2376             # Failed, add a trailing dot and try again, but only...
2377              
2378 0 0 0       if (Char::Eusascii::index($leaf,'.') == -1 and # if name does not have a dot in it *and*
      0        
2379             CORE::length($leaf) <= 8 and # name is shorter than or equal to 8 chars *and*
2380             Char::Eusascii::index($pattern,'\\.') != -1 # pattern has a dot.
2381             ) {
2382 0 0         if (&$matchsub("$leaf.")) {
2383 0           push @matched, "$head$leaf";
2384 0           next INNER;
2385             }
2386             }
2387             }
2388 0 0         if (@matched) {
2389 0           push @glob, @matched;
2390             }
2391             }
2392 0 0         if ($fix_drive_relative_paths) {
2393 0           for my $glob (@glob) {
2394 0           $glob =~ s# \A ([A-Za-z]:) \./ #$1#oxms;
2395             }
2396             }
2397 0           return @glob;
2398             }
2399              
2400             #
2401             # US-ASCII parse line
2402             #
2403             sub _parse_line {
2404              
2405 0     0     my($line) = @_;
2406              
2407 0           $line .= ' ';
2408 0           my @piece = ();
2409 0           while ($line =~ /
2410             " ( (?: [^"] )* ) " \s+ |
2411             ( (?: [^"\s] )* ) \s+
2412             /oxmsg
2413             ) {
2414 0 0         push @piece, defined($1) ? $1 : $2;
2415             }
2416 0           return @piece;
2417             }
2418              
2419             #
2420             # US-ASCII parse path
2421             #
2422             sub _parse_path {
2423              
2424 0     0     my($path,$pathsep) = @_;
2425              
2426 0           $path .= '/';
2427 0           my @subpath = ();
2428 0           while ($path =~ /
2429             ((?: [^\/\\] )+?) [\/\\]
2430             /oxmsg
2431             ) {
2432 0           push @subpath, $1;
2433             }
2434              
2435 0           my $tail = pop @subpath;
2436 0           my $head = join $pathsep, @subpath;
2437 0           return $head, $tail;
2438             }
2439              
2440             #
2441             # via File::HomeDir::Windows 1.00
2442             #
2443             sub my_home_MSWin32 {
2444              
2445             # A lot of unix people and unix-derived tools rely on
2446             # the ability to overload HOME. We will support it too
2447             # so that they can replace raw HOME calls with File::HomeDir.
2448 0 0 0 0 0   if (exists $ENV{'HOME'} and $ENV{'HOME'}) {
    0 0        
    0 0        
      0        
      0        
2449 0           return $ENV{'HOME'};
2450             }
2451              
2452             # Do we have a user profile?
2453             elsif (exists $ENV{'USERPROFILE'} and $ENV{'USERPROFILE'}) {
2454 0           return $ENV{'USERPROFILE'};
2455             }
2456              
2457             # Some Windows use something like $ENV{'HOME'}
2458             elsif (exists $ENV{'HOMEDRIVE'} and exists $ENV{'HOMEPATH'} and $ENV{'HOMEDRIVE'} and $ENV{'HOMEPATH'}) {
2459 0           return join '', $ENV{'HOMEDRIVE'}, $ENV{'HOMEPATH'};
2460             }
2461              
2462 0           return undef;
2463             }
2464              
2465             #
2466             # via File::HomeDir::Unix 1.00
2467             #
2468             sub my_home {
2469 0     0 0   my $home;
2470              
2471 0 0 0       if (exists $ENV{'HOME'} and defined $ENV{'HOME'}) {
    0 0        
2472 0           $home = $ENV{'HOME'};
2473             }
2474              
2475             # This is from the original code, but I'm guessing
2476             # it means "login directory" and exists on some Unixes.
2477             elsif (exists $ENV{'LOGDIR'} and $ENV{'LOGDIR'}) {
2478 0           $home = $ENV{'LOGDIR'};
2479             }
2480              
2481             ### More-desperate methods
2482              
2483             # Light desperation on any (Unixish) platform
2484             else {
2485 0           $home = eval q{ (getpwuid($<))[7] };
2486             }
2487              
2488             # On Unix in general, a non-existant home means "no home"
2489             # For example, "nobody"-like users might use /nonexistant
2490 0 0 0       if (defined $home and ! -d($home)) {
2491 0           $home = undef;
2492             }
2493 0           return $home;
2494             }
2495              
2496             #
2497             # ${^PREMATCH}, $PREMATCH, $` the string preceding what was matched
2498             #
2499             sub Char::Eusascii::PREMATCH {
2500 0     0 0   return $`;
2501             }
2502              
2503             #
2504             # ${^MATCH}, $MATCH, $& the string that matched
2505             #
2506             sub Char::Eusascii::MATCH {
2507 0     0 0   return $&;
2508             }
2509              
2510             #
2511             # ${^POSTMATCH}, $POSTMATCH, $' the string following what was matched
2512             #
2513             sub Char::Eusascii::POSTMATCH {
2514 0     0 0   return $';
2515             }
2516              
2517             #
2518             # US-ASCII character to order (with parameter)
2519             #
2520             sub Char::USASCII::ord(;$) {
2521              
2522 0 0   0 1   local $_ = shift if @_;
2523              
2524 0 0         if (/\A ($q_char) /oxms) {
2525 0           my @ord = unpack 'C*', $1;
2526 0           my $ord = 0;
2527 0           while (my $o = shift @ord) {
2528 0           $ord = $ord * 0x100 + $o;
2529             }
2530 0           return $ord;
2531             }
2532             else {
2533 0           return CORE::ord $_;
2534             }
2535             }
2536              
2537             #
2538             # US-ASCII character to order (without parameter)
2539             #
2540             sub Char::USASCII::ord_() {
2541              
2542 0 0   0 0   if (/\A ($q_char) /oxms) {
2543 0           my @ord = unpack 'C*', $1;
2544 0           my $ord = 0;
2545 0           while (my $o = shift @ord) {
2546 0           $ord = $ord * 0x100 + $o;
2547             }
2548 0           return $ord;
2549             }
2550             else {
2551 0           return CORE::ord $_;
2552             }
2553             }
2554              
2555             #
2556             # US-ASCII reverse
2557             #
2558             sub Char::USASCII::reverse(@) {
2559              
2560 0 0   0 0   if (wantarray) {
2561 0           return CORE::reverse @_;
2562             }
2563             else {
2564              
2565             # One of us once cornered Larry in an elevator and asked him what
2566             # problem he was solving with this, but he looked as far off into
2567             # the distance as he could in an elevator and said, "It seemed like
2568             # a good idea at the time."
2569              
2570 0           return join '', CORE::reverse(join('',@_) =~ /\G ($q_char) /oxmsg);
2571             }
2572             }
2573              
2574             #
2575             # US-ASCII getc (with parameter, without parameter)
2576             #
2577             sub Char::USASCII::getc(;*@) {
2578              
2579 0     0 0   my($package) = caller;
2580 0 0         my $fh = @_ ? qualify_to_ref(shift,$package) : \*STDIN;
2581 0 0 0       croak 'Too many arguments for Char::USASCII::getc' if @_ and not wantarray;
2582              
2583 0           my @length = sort { $a <=> $b } keys %range_tr;
  0            
2584 0           my $getc = '';
2585 0           for my $length ($length[0] .. $length[-1]) {
2586 0           $getc .= CORE::getc($fh);
2587 0 0         if (exists $range_tr{CORE::length($getc)}) {
2588 0 0         if ($getc =~ /\A ${Char::Eusascii::dot_s} \z/oxms) {
2589 0 0         return wantarray ? ($getc,@_) : $getc;
2590             }
2591             }
2592             }
2593 0 0         return wantarray ? ($getc,@_) : $getc;
2594             }
2595              
2596             #
2597             # US-ASCII length by character
2598             #
2599             sub Char::USASCII::length(;$) {
2600              
2601 0 0   0 1   local $_ = shift if @_;
2602              
2603 0           local @_ = /\G ($q_char) /oxmsg;
2604 0           return scalar @_;
2605             }
2606              
2607             #
2608             # US-ASCII substr by character
2609             #
2610             BEGIN {
2611              
2612             # P.232 The lvalue Attribute
2613             # in Chapter 6: Subroutines
2614             # of ISBN 0-596-00027-8 Programming Perl Third Edition.
2615              
2616             # P.336 The lvalue Attribute
2617             # in Chapter 7: Subroutines
2618             # of ISBN 978-0-596-00492-7 Programming Perl 4th Edition.
2619              
2620             # P.144 8.4 Lvalue subroutines
2621             # in Chapter 8: perlsub: Perl subroutines
2622             # of ISBN-13: 978-1-906966-02-7 The Perl Language Reference Manual (for Perl version 5.12.1)
2623              
2624 177 50 0 177 1 301284 eval sprintf(<<'END', ($] >= 5.014000) ? ':lvalue' : '');
  0 0   0      
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0 0          
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
2625             # vv----------------*******
2626             sub Char::USASCII::substr($$;$$) %s {
2627              
2628             my @char = $_[0] =~ /\G ($q_char) /oxmsg;
2629              
2630             # If the substring is beyond either end of the string, substr() returns the undefined
2631             # value and produces a warning. When used as an lvalue, specifying a substring that
2632             # is entirely outside the string raises an exception.
2633             # http://perldoc.perl.org/functions/substr.html
2634              
2635             # A return with no argument returns the scalar value undef in scalar context,
2636             # an empty list () in list context, and (naturally) nothing at all in void
2637             # context.
2638              
2639             my $offset = $_[1];
2640             if (($offset > scalar(@char)) or ($offset < (-1 * scalar(@char)))) {
2641             return;
2642             }
2643              
2644             # substr($string,$offset,$length,$replacement)
2645             if (@_ == 4) {
2646             my(undef,undef,$length,$replacement) = @_;
2647             my $substr = join '', splice(@char, $offset, $length, $replacement);
2648             $_[0] = join '', @char;
2649              
2650             # return $substr; this doesn't work, don't say "return"
2651             $substr;
2652             }
2653              
2654             # substr($string,$offset,$length)
2655             elsif (@_ == 3) {
2656             my(undef,undef,$length) = @_;
2657             my $octet_offset = 0;
2658             my $octet_length = 0;
2659             if ($offset == 0) {
2660             $octet_offset = 0;
2661             }
2662             elsif ($offset > 0) {
2663             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2664             }
2665             else {
2666             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2667             }
2668             if ($length == 0) {
2669             $octet_length = 0;
2670             }
2671             elsif ($length > 0) {
2672             $octet_length = CORE::length(join '', @char[$offset..$offset+$length-1]);
2673             }
2674             else {
2675             $octet_length = -1 * CORE::length(join '', @char[$#char+$length+1..$#char]);
2676             }
2677             CORE::substr($_[0], $octet_offset, $octet_length);
2678             }
2679              
2680             # substr($string,$offset)
2681             else {
2682             my $octet_offset = 0;
2683             if ($offset == 0) {
2684             $octet_offset = 0;
2685             }
2686             elsif ($offset > 0) {
2687             $octet_offset = CORE::length(join '', @char[0..$offset-1]);
2688             }
2689             else {
2690             $octet_offset = -1 * CORE::length(join '', @char[$#char+$offset+1..$#char]);
2691             }
2692             CORE::substr($_[0], $octet_offset);
2693             }
2694             }
2695             END
2696             }
2697              
2698             #
2699             # US-ASCII index by character
2700             #
2701             sub Char::USASCII::index($$;$) {
2702              
2703 0     0 1   my $index;
2704 0 0         if (@_ == 3) {
2705 0           $index = Char::Eusascii::index($_[0], $_[1], CORE::length(Char::USASCII::substr($_[0], 0, $_[2])));
2706             }
2707             else {
2708 0           $index = Char::Eusascii::index($_[0], $_[1]);
2709             }
2710              
2711 0 0         if ($index == -1) {
2712 0           return -1;
2713             }
2714             else {
2715 0           return Char::USASCII::length(CORE::substr $_[0], 0, $index);
2716             }
2717             }
2718              
2719             #
2720             # US-ASCII rindex by character
2721             #
2722             sub Char::USASCII::rindex($$;$) {
2723              
2724 0     0 1   my $rindex;
2725 0 0         if (@_ == 3) {
2726 0           $rindex = Char::Eusascii::rindex($_[0], $_[1], CORE::length(Char::USASCII::substr($_[0], 0, $_[2])));
2727             }
2728             else {
2729 0           $rindex = Char::Eusascii::rindex($_[0], $_[1]);
2730             }
2731              
2732 0 0         if ($rindex == -1) {
2733 0           return -1;
2734             }
2735             else {
2736 0           return Char::USASCII::length(CORE::substr $_[0], 0, $rindex);
2737             }
2738             }
2739              
2740             #
2741             # instead of Carp::carp
2742             #
2743             sub carp {
2744 0     0 0   my($package,$filename,$line) = caller(1);
2745 0           print STDERR "@_ at $filename line $line.\n";
2746             }
2747              
2748             #
2749             # instead of Carp::croak
2750             #
2751             sub croak {
2752 0     0 0   my($package,$filename,$line) = caller(1);
2753 0           print STDERR "@_ at $filename line $line.\n";
2754 0           die "\n";
2755             }
2756              
2757             #
2758             # instead of Carp::cluck
2759             #
2760             sub cluck {
2761 0     0 0   my $i = 0;
2762 0           my @cluck = ();
2763 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
2764 0           push @cluck, "[$i] $filename($line) $package::$subroutine\n";
2765 0           $i++;
2766             }
2767 0           print STDERR CORE::reverse @cluck;
2768 0           print STDERR "\n";
2769 0           carp @_;
2770             }
2771              
2772             #
2773             # instead of Carp::confess
2774             #
2775             sub confess {
2776 0     0 0   my $i = 0;
2777 0           my @confess = ();
2778 0           while (my($package,$filename,$line,$subroutine) = caller($i)) {
2779 0           push @confess, "[$i] $filename($line) $package::$subroutine\n";
2780 0           $i++;
2781             }
2782 0           print STDERR CORE::reverse @confess;
2783 0           print STDERR "\n";
2784 0           croak @_;
2785             }
2786              
2787             1;
2788              
2789             __END__