File Coverage

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