File Coverage

blib/lib/Lingua/Any/Numbers.pm
Criterion Covered Total %
statement 202 227 88.9
branch 58 80 72.5
condition 35 62 56.4
subroutine 34 40 85.0
pod 1 1 100.0
total 330 410 80.4


line stmt bran cond sub pod time code
1             package Lingua::Any::Numbers;
2 4     4   179110 use strict;
  4         8  
  4         183  
3 4     4   24 use warnings;
  4         10  
  4         170  
4 4     4   24 use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS );
  4         14  
  4         913  
5              
6             $VERSION = '0.45';
7              
8 4         21 use subs qw(
9             to_string
10             num2str
11             number_to_string
12              
13             to_ordinal
14             num2ord
15             number_to_ordinal
16              
17             available
18             available_langs
19             available_languages
20 4     4   5696 );
  4         130  
21              
22 4     4   476 use constant LCLASS => 0;
  4         8  
  4         463  
23 4         178 use constant RE_LEGACY_PERL => qr{
24             Perl \s+ (.+?) \s+ required
25             --this \s+ is \s+ only \s+ (.+?),
26             \s+ stopped
27 4     4   298 }xmsi;
  4         8  
28 4     4   24 use File::Spec;
  4         8  
  4         114  
29 4     4   22 use base qw( Exporter );
  4         5  
  4         469  
30 4     4   23 use Carp qw(croak);
  4         8  
  4         593  
31              
32             BEGIN {
33 4     4   191 *num2str = *number_to_string = \&to_string;
34 4         17 *num2ord = *number_to_ordinal = \&to_ordinal;
35 4         13 *available_langs = *available_languages = \&available;
36              
37 4         9 @EXPORT = ();
38 4         25336 @EXPORT_OK = qw(
39             to_string number_to_string num2str
40             to_ordinal number_to_ordinal num2ord
41             available available_langs available_languages
42             language_handler
43             );
44             }
45              
46             %EXPORT_TAGS = (
47             all => [ @EXPORT_OK ],
48             standard => [ qw/ available to_string to_ordinal / ],
49             standard2 => [ qw/ available_languages to_string to_ordinal / ],
50             long => [ qw/ available_languages number_to_string number_to_ordinal / ],
51             );
52              
53             @EXPORT_TAGS{ qw/ std std2 / } = @EXPORT_TAGS{ qw/ standard standard2 / };
54              
55             my %LMAP;
56             my $DEFAULT = 'EN';
57             my $USE_LOCALE = 0;
58             # blacklist non-language modules
59             my %NOT_LANG = map { $_ => 1 } qw(
60             Any
61             Base
62             Conlang
63             Slavic
64             );
65              
66             _probe(); # fetch/examine/compile all available modules
67              
68             sub import {
69 4     4   53 my($class, @args) = @_;
70 4         11 my @exports;
71              
72 4         111 foreach my $thing ( @args ) {
73 8 100       28 if ( lc $thing eq '+locale' ) { $USE_LOCALE = 1; next; }
  2         4  
  2         7  
74 6 50       57 if ( lc $thing eq '-locale' ) { $USE_LOCALE = 0; next; }
  0         0  
  0         0  
75 6         17 push @exports, $thing;
76             }
77              
78 4         4512 return $class->export_to_level( 1, $class, @exports );
79             }
80              
81             sub to_string {
82 42     42   15672 my @args = @_;
83 42         153 return _to( string => @args )
84             }
85              
86             sub to_ordinal {
87 42     42   69334 my @args = @_;
88 42         136 return _to( ordinal => @args )
89             }
90              
91             sub available {
92 2     2   824 my @ids = sort keys %LMAP;
93 2         68 return @ids;
94             }
95              
96             sub language_handler {
97 46   50 46 1 782 my $lang = shift || return;
98 46   50     221 my $h = $LMAP{ uc $lang } || return;
99 46         280 return $h->{class};
100             }
101              
102             # -- PRIVATE -- #
103              
104             sub _to {
105 84   33 84   476 my $type = shift || croak 'No type specified';
106 84         254 my $n = shift;
107 84   66     304 my $lang = shift || _get_lang();
108 84         1300 $lang = uc $lang;
109 84 100       446 $lang = _get_lang($lang) if $lang eq 'LOCALE';
110 84 50 66     1821 if ( ($lang eq 'LOCALE' || $USE_LOCALE) && ! exists $LMAP{ $lang } ) {
      66        
111 0         0 _w("Locale language ($lang) is not available. "
112             ."Falling back to default language ($DEFAULT)");
113 0         0 $lang = $DEFAULT; # prevent die()ing from an absent driver
114             }
115 84   33     271 my $struct = $LMAP{ $lang } || croak "Language ($lang) is not available";
116 84         419 return $struct->{ $type }->( $n );
117             }
118              
119             sub _get_lang {
120 8     8   11 my $lang;
121 8         11 my $locale = shift;
122 8 50 66     54 $lang = _get_lang_from_locale() if $locale || $USE_LOCALE;
123 8 50       25 $lang = $DEFAULT if ! $lang;
124 8         34 return uc $lang;
125             }
126              
127             sub _get_lang_from_locale {
128 8     8   2421 require I18N::LangTags::Detect;
129 8         11849 my @user_wants = I18N::LangTags::Detect::detect();
130 8   50     1300 my $lang = $user_wants[0] || return;
131 0         0 ($lang,undef) = split m{\-}xms, $lang; # tr-tr
132 0         0 return $lang;
133             }
134              
135 0   0 0   0 sub _is_silent { return defined &SILENT && SILENT() }
136              
137 18     18   143 sub _dummy_ordinal { return shift }
138 0     0   0 sub _dummy_string { return shift }
139             sub _dummy_oo {
140 24     24   47 my $class = shift;
141 24         105 my $type = shift;
142             return $type && ! $class->can('parse')
143 6     6   51 ? sub { $class->new->$type( shift ) }
144 6     6   44 : sub { $class->new->parse( shift ) }
145 24 100 66     499 ;
146             }
147              
148             sub _probe {
149 4     4   353 my @compile;
150 4         16 foreach my $module ( _probe_inc() ) {
151 80         386 my $class = $module->[LCLASS];
152              
153 80         550 (my $inc = $class) =~ s{::}{/}xmsg;
154 80         234 $inc .= q{.pm};
155              
156 80 50       309 if ( ! $INC{ $inc } ) {
157 80         1568 my $file = File::Spec->catfile( split m{::}xms, $class ) . '.pm';
158             eval {
159 80         258547 require $file;
160 80         1423334 $class->import;
161 80         966 1;
162 80 50       241 } or do {
163             # some modules need attention
164 0         0 _probe_error($@, $class);
165 0         0 next;
166             };
167 80         312 $INC{ $inc } = $INC{ $file };
168             }
169              
170 80         443 push @compile, $module;
171             }
172 4         37 _compile( \@compile );
173 4         54 return 1;
174             }
175              
176             sub _probe_error {
177 0     0   0 my($e, $class) = @_;
178 0 0       0 if ( $e =~ RE_LEGACY_PERL ) { # JA -> 5.6.2
179 0         0 return _w( _eprobe( $class, $1, $2 ) );
180             }
181 0         0 croak("An error occurred while including sub modules: $e");
182             }
183              
184             sub _probe_inc {
185 4     4   7369 require Symbol;
186 4         8385 my @classes;
187 4         24 foreach my $inc ( @INC ) {
188 46         504 my $path = File::Spec->catfile( $inc, 'Lingua' );
189 46 100       3034 next if ! -d $path;
190 12         47 my $DIRH = Symbol::gensym();
191 12 50       1495 opendir $DIRH, $path or croak "opendir($path): $!";
192 12         423 while ( my $dir = readdir $DIRH ) {
193 120 100 100     944 next if $dir =~ m{ \A [.] }xms || $NOT_LANG{ $dir };
194 76 50       516 ($dir) = $dir =~ m{([a-z0-9_]+)}xmsi or next; # untaint
195 76         179 my @rs = _probe_exists($path, $dir);
196 76 50       170 next if ! @rs; # bogus
197 76         126 foreach my $e ( @rs ) {
198 80         96 my($file, $type) = @{ $e };
  80         155  
199 80         2660 push @classes, [ join(q{::}, 'Lingua', $dir, $type), $file, $dir ];
200             }
201             }
202 12         243 closedir $DIRH;
203             }
204              
205 4         28 return @classes;
206             }
207              
208             sub _probe_exists {
209 76     76   118 my($path, $dir) = @_;
210 76         88 my @results;
211 76         127 foreach my $possibility ( qw[ Numbers Num2Word Nums2Words Numeros Nums2Ords ] ) {
212 380         3712 my $file = File::Spec->catfile( $path, $dir, $possibility . '.pm' );
213 380 100 66     225054 next if ! -e $file || -d _;
214 80         306 push @results, [ $file, $possibility ];
215             }
216 76         253 return @results;
217             }
218              
219             sub _w {
220 0 0   0   0 return _is_silent() ? 1 : do { warn "@_\n"; 1 };
  0         0  
  0         0  
221             }
222              
223             sub _eprobe {
224 0     0   0 my @args = @_;
225 0 0       0 my $tmp = @args > 2 ? q{%s requires a newer (%s) perl binary. You have %s}
226             : q{%s requires a newer perl binary. You have %s}
227             ;
228 0         0 return sprintf $tmp, @args;
229             }
230              
231             sub _merge_into_numbers {
232 4     4   12 my($id, $lang ) = @_;
233 4         17 my $e = delete $lang->{ $id };
234 4         7 my %test = map { @{ $_ } } @{ $e };
  8         13  
  8         45  
  4         11  
235 4         18 my $words = delete $test{'Lingua::' . $id . '::Nums2Words' };
236 4         15 my $ords = delete $test{'Lingua::' . $id . '::Nums2Ords' };
237 4         13 my $numbers = delete $test{'Lingua::' . $id . '::Numbers' };
238              
239 4 50 33     37 if ( ! $numbers && ( $ords || $words ) ) {
      33        
240 4         28 my $file = sprintf 'Lingua/%s/Numbers.pm', $id;
241 4         13 my $c = sprintf 'Lingua::%s::Numbers', $id;
242 4   50     38 $INC{ $file } ||= 'Fake placeholder module';
243 4         16 my $n = $c . '::num2' . lc $id;
244 4         11 my $v = $c . '::VERSION';
245 4         12 my $o = $n . '_ordinal';
246 4         12 my $f = $c . '::_faked_by_lingua_any_numbers';
247 4         13 my $card = 'Lingua::' . $id . '::Nums2Words::num2word';
248 4         13 my $ord = 'Lingua::' . $id . '::Nums2Ords::num2ord';
249 4         17 $lang->{ $id } = [ $c, $INC{ $file } ];
250              
251 4     4   56 no strict qw( refs ); ## no critic (ProhibitProlongedStrictureOverride)
  4         11  
  4         4895  
252 4 50 33     84 *{ $n } = \&{ $card } if $words && ! $c->can('num2tr');
  4         47  
  4         22  
253 4 50 33     112 *{ $o } = \&{ $ord } if $ords && ! $c->can('num2ord');
  4         23  
  4         22  
254 4 50   0   43 *{ $v } = sub { $VERSION } if ! $c->can('VERSION');
  0         0  
  0         0  
255 4     2   40 *{ $f } = sub { return { words => $words, ords => $ords } };
  4         38  
  2         754  
256              
257 4         21 return;
258             }
259              
260 0         0 $lang->{ $id } = $e; # restore
261              
262 0         0 return;
263             }
264              
265             sub _compile {
266 4     4   15 my $classes = shift;
267 4         9 my %lang;
268 4         76 foreach my $e ( @{ $classes } ) {
  4         15  
269 80         84 my($class, $file, $id) = @{ $e };
  80         188  
270 80 100       405 $lang{ $id } = [] if ! defined $lang{ $id };
271 80         98 push @{ $lang{ $id } }, [ $class, $file ];
  80         262  
272             }
273              
274 4         29 foreach my $id ( keys %lang ) {
275 76 100       176 if ( $id eq 'PT' ) {
276 4         32 _merge_into_numbers( $id, \%lang );
277 4         12 next;
278             }
279 72         78 my @choices = @{ $lang{ $id } };
  72         235  
280 72         88 my $numbers;
281 72         136 foreach my $c ( @choices ) {
282 72         73 my($class, $file) = @{ $c };
  72         119  
283 72 100       342 $numbers = $c if $class =~ m{::Numbers\z}xms;
284             }
285 72 100       259 $lang{ $id } = $numbers ? [ @{ $numbers} ] : shift @choices;
  52         189  
286             }
287              
288 4         24 foreach my $l ( keys %lang ) {
289 76         128 my $e = $lang{ $l };
290 76         109 my $c = $e->[0];
291 76         147 $LMAP{ uc $l } = {
292             string => _test_cardinal($c, $l),
293             ordinal => _test_ordinal( $c, $l),
294             class => $c,
295             };
296             }
297              
298 4         39 return;
299             }
300              
301             sub _test_cardinal {
302 76     76   120 my($c, $l) = @_;
303 76         128 $l = lc $l;
304 4     4   30 no strict qw(refs);
  4         8  
  4         8148  
305 76         78 my %s = %{ "${c}::" };
  76         2491  
306 76         245 my $n = $s{new};
307             return
308 24         262 $s{"num2${l}"} ? \&{"${c}::num2${l}" }
  16         176  
309 4         41 : $s{"number_to_${l}"} ? \&{"${c}::number_to_${l}" }
310 0         0 : $s{'nums2words'} ? \&{"${c}::nums2words" }
311 4         39 : $s{'num2word'} ? \&{"${c}::num2word" }
312 8         61 : $s{cardinal2alpha} ? \&{"${c}::cardinal2alpha" }
313             : $s{cardinal} && $n ? _dummy_oo( $c, 'cardinal' )
314             : $s{parse} ? _dummy_oo( $c )
315             : $s{"num2${l}_cardinal"}? $n ? _dummy_oo( $c, "num2${l}_cardinal" )
316 76 100 66     465 : \&{"${c}::num2${l}_cardinal" }
    50          
    100          
    100          
    100          
    50          
    100          
    100          
    100          
317             : \&_dummy_string
318             ;
319             }
320              
321             sub _test_ordinal {
322 76     76   145 my($c, $l) = @_;
323 76         119 $l = lc $l;
324 4     4   35 no strict qw(refs);
  4         27  
  4         1329  
325 76         82 my %s = %{ "${c}::" };
  76         1130  
326 76   100     333 my $n = $s{new} && ! _like_en( $c );
327             return
328 8         91 $s{"ordinate_to_${l}"} ? \&{"${c}::ordinate_to_${l}"}
  4         51  
329 24         306 : $s{ordinal2alpha} ? \&{"${c}::ordinal2alpha" }
330             : $s{ordinal} && $n ? _dummy_oo( $c, 'ordinal' )
331             : $s{"num2${l}_ordinal"} ? $n ? _dummy_oo( $c, "num2${l}_ordinal" )
332 76 50 100     774 : \&{ "${c}::num2${l}_ordinal" }
    100          
    100          
    100          
    100          
333             : \&_dummy_ordinal
334             ;
335             }
336              
337             sub _like_en {
338 36     36   52 my $c = shift;
339 36   66     798 my $rv = $c->isa('Lingua::EN::Numbers')
340             || $c->isa('Lingua::JA::Numbers')
341             || $c->isa('Lingua::TR::Numbers')
342             ;
343 36         134 return $rv;
344             }
345              
346             1;
347              
348             __END__