File Coverage

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