File Coverage

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