File Coverage

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