File Coverage

lib/Locale/Maketext/Utils.pm
Criterion Covered Total %
statement 605 730 82.8
branch 289 444 65.0
condition 76 157 48.4
subroutine 99 113 87.6
pod 61 89 68.5
total 1130 1533 73.7


line stmt bran cond sub pod time code
1             package Locale::Maketext::Utils;
2              
3             # these work fine, but are not used in production
4             # use strict;
5             # use warnings;
6             $Locale::Maketext::Utils::VERSION = '0.41';
7              
8 13     13   264951 use Locale::Maketext 1.21 ();
  13         271639  
  13         641  
9 13     13   18141 use Locales 0.26 ();
  13         199728  
  13         472  
10 13     13   19631 use Locales::DB::CharacterOrientation::Tiny ();
  13         6206  
  13         399  
11 13     13   14603 use Locales::DB::LocaleDisplayPattern::Tiny ();
  13         2971  
  13         4481  
12              
13             @Locale::Maketext::Utils::ISA = qw(Locale::Maketext);
14              
15             my %singleton_stash = ();
16              
17             # This is necessary to support embedded arguments (e.g. '... [output,foo,bar _1 baz] ...') and not interpolate things in the arguments that look like embedded args (e.g. argument #1 is '_2')
18             sub _compile {
19 214     214   4040 my ( $lh, $string, @args ) = @_;
20 214         859 $string =~ s/_TILDE_/~~/g; # this helps make parsing easier (via code or visually)
21              
22 214         3141 my $compiled = $lh->SUPER::_compile($string);
23 198 100       66456 return $compiled if ref($compiled) ne 'CODE';
24              
25             return sub {
26 240     240   24893 my ( $lh, @ref_args ) = @_;
27              
28             # Change embedded-arg-looking-string to a not-likley-to-exist-but-if-it-does-then-you-have-bigger-problems placeholder (i.e. '_1 -!-1-!-' would act wonky, so don't do that)
29 240 100       428 @ref_args = map { s/\_(\-?[0-9]+|\*)/-!-$1-!-/g if defined; $_ } @ref_args;
  190         968  
  190         591  
30 240         6309 my $built = $compiled->( $lh, @ref_args ); # if an method that supported embedded args ever looked for /\_(\-?[0-9]+|\*)/ and acted upon it then it'd need to be aware of this convention and operate on /-!-(\-?[0-9]+|\*)-!-/ instead (or better yet don't have it look for an act upon things that look like bracket notation arguments)
31 230         7517 $built =~ s/-!-(\-?[0-9]+|\*)-!-/_$1/g; # Change placeholders back to their original
32              
33 230         1227 return $built;
34 170         2970 };
35             }
36              
37             # surgically alter a part of L::M::_langtag_munging() that is buggy but cannot otherwise be overridden
38 13     13   105 no warnings 'redefine';
  13         27  
  13         9322  
39             *I18N::LangTags::panic_languages = sub { # make it CLDR based instead of arbitrary
40 30     30   8351 my (@languages) = @_;
41              
42 30         58 my @tags;
43              
44 30         67 for my $arg (@languages) {
45 31 100       301 next if substr( $arg, 0, 2 ) =~ m/i[-_]/;
46              
47 27         181 my $loc = Locales->new($arg);
48 27 100       172333 next if !$loc;
49 21         223 push @tags, $loc->get_fallback_list();
50             }
51              
52 30         554 return @tags, @languages, 'en'; # same results but CLDR based instead of arbitrary (e.g. it falling back to es, whaaaa?)
53             };
54              
55             sub get_handle {
56 51     51 0 6088 my ( $class, @langtags ) = @_;
57              
58             # order is important so we don't sort() in an attempt to normalize (i.e. fr, es is not the same as es, fr)
59 51   100     330 my $args_sig = join( ',', @langtags ) || 'no_args';
60              
61 51 100       226 if ( exists $singleton_stash{$class}{$args_sig} ) {
62 21         67 $singleton_stash{$class}{$args_sig}->{'_singleton_reused'}++;
63             }
64             else {
65 30         297 $singleton_stash{$class}{$args_sig} = $class->SUPER::get_handle(@langtags);
66             }
67              
68 51         807 return $singleton_stash{$class}{$args_sig};
69             }
70              
71             sub get_locales_obj {
72 20     20 1 2601 my ( $lh, $tag ) = @_;
73 20   66     147 $tag ||= $lh->get_language_tag();
74              
75 20 100       83 if ( !exists $lh->{'Locales.pm'}{$tag} ) {
76 9   0     73 $lh->{'Locales.pm'}{$tag} =
77             Locales->new($tag)
78             || ( $tag ne substr( $tag, 0, 2 ) ? Locales->new( substr( $tag, 0, 2 ) ) : '' )
79             || (
80             $lh->{'fallback_locale'}
81             ? ( Locales->new( $lh->{'fallback_locale'} )
82             || ( $lh->{'fallback_locale'} ne substr( $lh->{'fallback_locale'}, 0, 2 ) ? Locales->new( substr( $lh->{'fallback_locale'}, 0, 2 ) ) : '' ) )
83             : ''
84             )
85             || Locales->new('en');
86             }
87              
88 20         79855 return $lh->{'Locales.pm'}{$tag};
89             }
90              
91             sub init {
92 30     30 0 7666 my ($lh) = @_;
93              
94 30 100       516 $ENV{'maketext_obj'} = $lh if !$ENV{'maketext_obj_skip_env'};
95              
96 30         179 $lh->SUPER::init();
97 30         254 $lh->remove_key_from_lexicons('_AUTO');
98              
99             # use the base class if available, then the class itself if available
100 13     13   259 no strict 'refs';
  13         29  
  13         5696  
101 30         224 for my $ns ( $lh->get_base_class(), $lh->get_language_class() ) {
102 60 100       88 if ( defined ${ $ns . '::Encoding' } ) {
  60         359  
103 27 50       40 $lh->{'encoding'} = ${ $ns . '::Encoding' } if ${ $ns . '::Encoding' };
  27         115  
  27         133  
104             }
105             }
106              
107             # This will happen on the first call to get_context() or context_is*() so we do not do it here to avoid doing the work unless we actually need it.
108             # $lh->set_context();
109              
110             $lh->fail_with(
111             sub {
112 126     126   1070786 my ( $lh, $key, @args ) = @_;
113              
114 126         177 my $lookup;
115 126 100       364 if ( exists $lh->{'_get_key_from_lookup'} ) {
116 1 50       9 if ( ref $lh->{'_get_key_from_lookup'} eq 'CODE' ) {
117 1         5 $lookup = $lh->{'_get_key_from_lookup'}->( $lh, $key, @args );
118             }
119             }
120              
121 126 100       385 return $lookup if defined $lookup;
122              
123 125 100       305 if ( exists $lh->{'_log_phantom_key'} ) {
124 1 50       7 if ( ref $lh->{'_log_phantom_key'} eq 'CODE' ) {
125 1         6 $lh->{'_log_phantom_key'}->( $lh, $key, @args );
126             }
127             }
128              
129 125 50       288 if ( $lh->{'use_external_lex_cache'} ) {
130 0         0 local $lh->{'_external_lex_cache'}{'_AUTO'} = 1;
131              
132             # _AUTO does not short circuit _ keys so we can get a loop
133 0 0       0 if ( $key =~ m/^_/s ) {
134 0         0 return $lh->{'_external_lex_cache'}{$key} = $key;
135             }
136 0         0 return $lh->maketext( $key, @args );
137             }
138             else {
139 13     13   95 no strict 'refs';
  13         27  
  13         10035  
140 125         138 local ${ $lh->get_base_class() . '::Lexicon' }{'_AUTO'} = 1;
  125         627  
141              
142             # _AUTO does not short circuit _ keys so we can get a loop
143 125 50       362 if ( $key =~ m/^_/s ) {
144 0         0 return ${ $lh->get_base_class() . '::Lexicon' }{$key} = $key;
  0         0  
145             }
146              
147 125         429 return $lh->maketext( $key, @args );
148             }
149             }
150 30         389 );
151             }
152              
153             sub makevar {
154 3     3 1 2590 my ( $lh, $phrase, @args ) = @_;
155 3 100 66     23 @_ = ( $lh, @{$phrase} ) if !@args && ref($phrase) eq 'ARRAY'; # Feature per rt 85588
  1         4  
156 3         17 goto &Locale::Maketext::maketext;
157             }
158              
159             # TODO Normalize White Space [into key form] (name? export, do meth/function or just funtion?, etc), needs POD and tests once finalized (update parser also: rt 80489)
160             # sub _NWS {
161             #
162             # # $lh->_NWS($str) || _NWS($str)
163             # my $string = @_ > 1 ? $_[1] : $_[0];
164             #
165             # $string =~ s/\s+/ /g;
166             # $string =~ s/\A(?:\x20|\xc2\xa0)+//g; # remove leading white space
167             # $string =~ s/(?:\x20|\xc2\xa0){2,}/ /g; # collapse multiple internal white space
168             # $string =~ s/(?:\x20|\xc2\xa0)+\z//g; # remove trailing white space
169             # if ( substr( $string, 0, 3 ) eq "\xE2\x80\xA6" ) {
170             # $string = " $string";
171             # }
172             # return $string;
173             # }
174              
175             sub makethis {
176 99     99 1 688 my ( $lh, $phrase, @phrase_args ) = @_;
177              
178 99   66     856 $lh->{'cache'}{'makethis'}{$phrase} ||= $lh->_compile($phrase);
179              
180 83         289 my $type = ref( $lh->{'cache'}{'makethis'}{$phrase} );
181              
182 83 100       329 if ( $type eq 'SCALAR' ) {
    50          
183 19         23 return ${ $lh->{'cache'}{'makethis'}{$phrase} };
  19         109  
184             }
185             elsif ( $type eq 'CODE' ) {
186 64         302 return $lh->{'cache'}{'makethis'}{$phrase}->( $lh, @phrase_args );
187             }
188             else {
189              
190             # ? carp() ?
191 0         0 return $lh->{'cache'}{'makethis'}{$phrase};
192             }
193             }
194              
195             # We do this because we do not want the language semantics of $lh
196             sub makethis_base {
197 4     4 1 8 my ($lh) = @_;
198 4   100     28 $lh->{'cache'}{'makethis_base'} ||= $lh->get_base_class()->get_handle( $lh->{'fallback_locale'} || 'en' ); # this allows to have a seperate cache of compiled phrases (? get_handle() explicit or base_locales() (i.e. en en_us i_default || L::M->fallback_languages) ?)
      66        
199 4         23 return $lh->{'cache'}{'makethis_base'}->makethis( @_[ 1 .. $#_ ] );
200             }
201              
202             sub make_alias {
203 10     10 0 32702 my ( $lh, $pkgs, $is_base_class ) = @_;
204              
205 10         97 my $ns = $lh->get_language_class();
206 10 50       111 return if $ns !~ m{ \A \w+ (::\w+)* \z }xms;
207 10 100       54 my $base = $is_base_class ? $ns : $lh->get_base_class();
208              
209 13     13   104 no strict 'refs';
  13         28  
  13         14368  
210 10 100       41 for my $pkg ( ref $pkgs ? @{$pkgs} : $pkgs ) {
  7         22  
211 23 50       132 next if $pkg !~ m{ \A \w+ (::\w+)* \z }xms;
212 23         30 *{ $base . '::' . $pkg . '::VERSION' } = *{ $ns . '::VERSION' };
  23         180  
  23         87  
213 23         30 *{ $base . '::' . $pkg . '::Encoding' } = *{ $ns . '::Encoding' };
  23         103  
  23         208  
214 23         36 *{ $base . '::' . $pkg . '::Lexicon' } = *{ $ns . '::Lexicon' };
  23         92  
  23         58  
215 23         36 @{ $base . '::' . $pkg . '::ISA' } = ($ns);
  23         766  
216             }
217             }
218              
219             sub remove_key_from_lexicons {
220 30     30 1 70 my ( $lh, $key ) = @_;
221 30         59 my $idx = 0;
222              
223 30         53 for my $lex_hr ( @{ $lh->_lex_refs() } ) {
  30         244  
224 63 100       1896 $lh->{'_removed_from_lexicons'}{$idx}{$key} = delete $lex_hr->{$key} if exists $lex_hr->{$key};
225 63         137 $idx++;
226             }
227             }
228              
229             sub get_base_class {
230 175     175 1 10542 my $ns = shift->get_language_class();
231 175         976 $ns =~ s{::\w+$}{};
232 175         1372 return $ns;
233             }
234              
235             sub append_to_lexicons {
236 1     1 1 843 my ( $lh, $appendage ) = @_;
237 1 50       7 return if ref $appendage ne 'HASH';
238              
239 13     13   248 no strict 'refs';
  13         138  
  13         47577  
240 1         2 for my $lang ( keys %{$appendage} ) {
  1         6  
241 2 100       6 my $ns = $lh->get_base_class() . ( $lang eq '_' ? '' : "::$lang" ) . '::Lexicon';
242 2         3 %{$ns} = ( %{$ns}, %{ $appendage->{$lang} } );
  2         17  
  2         11  
  2         6  
243             }
244             }
245              
246             sub langtag_is_loadable {
247 7     7 1 1502 my ( $lh, $wants_tag ) = @_;
248 7         20 $wants_tag = Locale::Maketext::language_tag($wants_tag);
249              
250             # why doesn't this work ?
251             # no strict 'refs';
252             # my $tag_obj = ${ $lh->get_base_class() }->get_handle( $wants_tag );
253 7         86 my $tag_obj = eval $lh->get_base_class() . q{->get_handle( $wants_tag );};
254              
255 7         45 my $has_tag = $tag_obj->language_tag();
256 7 100       151 return $wants_tag eq $has_tag ? $tag_obj : 0;
257             }
258              
259             sub get_language_tag {
260 23     23 1 8715 return ( split '::', shift->get_language_class() )[-1];
261             }
262              
263             sub print {
264 0     0 1 0 local $Carp::CarpLevel = 1;
265 0         0 print shift->maketext(@_);
266             }
267              
268             sub fetch {
269 7     7 1 3625 local $Carp::CarpLevel = 1;
270 7         46 return shift->maketext(@_);
271             }
272              
273             sub say {
274 0     0 1 0 local $Carp::CarpLevel = 1;
275 0         0 my $text = shift->maketext(@_);
276 0 0 0     0 local $/ = !defined $/ || !$/ ? "\n" : $/; # otherwise assume they are not stupid
277 0 0       0 print $text . $/ if $text;
278             }
279              
280             sub get {
281 1     1 1 1602 local $Carp::CarpLevel = 1;
282 1         5 my $text = shift->maketext(@_);
283 1 50 33     17 local $/ = !defined $/ || !$/ ? "\n" : $/; # otherwise assume they are not stupid
284 1 50       20 return $text . $/ if $text;
285 0         0 return;
286             }
287              
288             sub get_language_tag_name {
289 0     0 1 0 my ( $lh, $tag, $in_locale_tongue ) = @_;
290 0   0     0 $tag ||= $lh->get_language_tag();
291              
292 0 0       0 my $loc_obj = $lh->get_locales_obj( $in_locale_tongue ? () : ($tag) );
293              
294 0         0 return $loc_obj->get_language_from_code($tag);
295             }
296              
297             sub get_html_dir_attr {
298 0     0 1 0 my ( $lh, $raw_cldr, $is_tag ) = @_;
299              
300 0 0       0 if ($is_tag) {
301 0         0 $raw_cldr = $lh->get_language_tag_character_orientation($raw_cldr);
302             }
303             else {
304 0   0     0 $raw_cldr ||= $lh->get_language_tag_character_orientation();
305             }
306              
307 0 0       0 if ( $raw_cldr eq 'left-to-right' ) {
    0          
308 0         0 return 'ltr';
309             }
310             elsif ( $raw_cldr eq 'right-to-left' ) {
311 0         0 return 'rtl';
312             }
313              
314 0         0 return;
315             }
316              
317             sub get_locale_display_pattern {
318              
319             # my ( $lh, $tag ) = @_;
320             # $tag ||= $lh->get_language_tag();
321              
322 0   0 0 1 0 return Locales::DB::LocaleDisplayPattern::Tiny::get_locale_display_pattern( $_[1] || $_[0]->{'fallback_locale'} || $_[0]->get_language_tag() );
323             }
324              
325             sub get_language_tag_character_orientation {
326              
327             # my ( $lh, $tag ) = @_;
328             # $tag ||= $lh->get_language_tag();
329              
330 0   0 0 1 0 return Locales::DB::CharacterOrientation::Tiny::get_orientation( $_[1] || $_[0]->{'fallback_locale'} || $_[0]->get_language_tag() );
331             }
332              
333             sub text {
334 1     1 1 91 require Carp;
335 1         25 Carp::carp('text() is deprecated, use lextext() instead');
336 1         692 goto &lextext;
337             }
338              
339             sub lextext {
340              
341 4     4 1 39 require Carp;
342              
343             # Remember, this can fail. Failure is controllable many ways.
344 4 50       13 Carp::croak 'lextext() requires a single parameter' unless @_ == 2;
345              
346 4         12 my ( $handle, $phrase ) = splice( @_, 0, 2 );
347 4 50 33     23 Carp::confess('No handle/phrase') unless ( defined($handle) && defined($phrase) );
348              
349 4 50       14 if ( !$handle->{'use_external_lex_cache'} ) {
350 0         0 Carp::carp("lextext() requires you to have 'use_external_lex_cache' enabled.");
351 0         0 return;
352             }
353              
354             # backup $@ in case it is still being used in the calling code.
355             # If no failures, we'll re-set it back to what it was later.
356 4         8 my $at = $@;
357              
358             # Copy @_ case one of its elements is $@.
359 4         7 @_ = @_;
360              
361             # Look up the value:
362              
363 4         6 my $value;
364 4         5 foreach my $h_r ( @{ $handle->_lex_refs } ) { # _lex_refs() caches itself
  4         22  
365              
366             # DEBUG and warn "* Looking up \"$phrase\" in $h_r\n";
367 4 50 0     40 if ( exists $h_r->{$phrase} ) {
    0          
368              
369 4 50       14 if ( ref( $h_r->{$phrase} ) ) {
370 0         0 Carp::carp("Previously compiled phrase ('use_external_lex_cache' enabled after phrase was compiled?)");
371             }
372              
373             # DEBUG and warn " Found \"$phrase\" in $h_r\n";
374 4         9 $value = $h_r->{$phrase};
375 4         10 last;
376             }
377              
378             # extending packages need to be able to localize _AUTO and if readonly can't "local $h_r->{'_AUTO'} = 1;"
379             # but they can "local $handle->{'_external_lex_cache'}{'_AUTO'} = 1;"
380             elsif ( $phrase !~ m/^_/s and $h_r->{'_AUTO'} ) {
381              
382             # it is an auto lex, and this is an autoable key!
383             # DEBUG and warn " Automaking \"$phrase\" into $h_r\n";
384 0         0 $value = $phrase;
385 0         0 last;
386             }
387              
388             # DEBUG > 1 and print " Not found in $h_r, nor automakable\n";
389              
390             # else keep looking
391             }
392              
393 4 50       12 unless ( defined($value) ) {
394              
395             # DEBUG and warn "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, " fails.\n";
396             }
397              
398 4         7 $@ = $at; # Put $@ back in case we altered it along the way.
399 4         20 return $value;
400             }
401              
402             sub lang_names_hashref {
403 5     5 1 11539 my ( $lh, @langcodes ) = @_;
404              
405 5 100       21 if ( !@langcodes ) { # they havn't specified any langcodes...
406 2         20 require File::Spec; # only needed here, so we don't use() it
407              
408 2         3 my @search;
409 2         17 my $path = $lh->get_base_class();
410 2         9 $path =~ s{::}{/}g; # !!!! make this File::Spec safe !! File::Spec->separator() !-e
411              
412 2 100       1043 if ( ref $lh->{'_lang_pm_search_paths'} eq 'ARRAY' ) {
413 1         3 @search = @{ $lh->{'_lang_pm_search_paths'} };
  1         4  
414             }
415              
416 2 100       14 @search = @INC if !@search; # they havn't told us where they are specifically
417              
418             DIR:
419 2         7 for my $dir (@search) {
420 15         116 my $lookin = File::Spec->catdir( $dir, $path );
421 15 100       338 next DIR if !-d $lookin;
422 2 50       77 if ( opendir my $dh, $lookin ) {
423 2         14 PM:
424 2         66 for my $pm ( grep { /^\w+\.pm$/ } grep !/^\.+$/, readdir($dh) ) {
425 2         8 $pm =~ s{\.pm$}{};
426 2 50       6 next PM if !$pm;
427 2 50       6 next PM if $pm eq 'Utils';
428 2         6 push @langcodes, $pm;
429             }
430 2         35 closedir $dh;
431             }
432             }
433             }
434              
435             # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
436             # method call if we already have the Locales object that belongs to the handle's locale.
437 5   66     47 $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
438              
439 5         13 my $langname = {};
440 5 100 66     30 my $native = wantarray && $Locales::VERSION > 0.06 ? {} : undef;
441 5 100 66     24 my $direction = wantarray && $Locales::VERSION > 0.09 ? {} : undef;
442              
443 5         12 for my $code ( 'en', @langcodes ) { # en since it is "built in"
444              
445 17         146 $langname->{$code} = $lh->{'Locales.pm'}{'_main_'}->get_language_from_code( $code, 1 );
446              
447 17 100       543 if ( defined $native ) {
448 4         16 $native->{$code} = $lh->{'Locales.pm'}{'_main_'}->get_native_language_from_code( $code, 1 );
449             }
450              
451 17 100       5455 if ( defined $direction ) {
452 4         17 $direction->{$code} = $lh->{'Locales.pm'}{'_main_'}->get_character_orientation_from_code_fast($code);
453             }
454             }
455              
456 5 100       46 return wantarray ? ( $langname, $native, $direction ) : $langname;
457             }
458              
459             sub loadable_lang_names_hashref {
460 1     1 1 12750 my ( $lh, @langcodes ) = @_;
461              
462 1         8 my $langname = $lh->lang_names_hashref(@langcodes);
463              
464 1         4 for my $tag ( keys %{$langname} ) {
  1         5  
465 5 100       21 delete $langname->{$tag} if !$lh->langtag_is_loadable($tag);
466             }
467              
468 1         8 return $langname;
469             }
470              
471             sub add_lexicon_override_hash {
472 1     1 1 3 my ( $lh, $langtag, $name, $hr ) = @_;
473 1 50       6 if ( @_ == 3 ) {
474 0         0 $hr = $name;
475 0         0 $name = $langtag;
476 0         0 $langtag = $lh->get_language_tag();
477             }
478              
479 1 50       12 my $ns = $lh->get_language_tag() eq $langtag ? $lh->get_language_class() : $lh->get_base_class();
480              
481 13     13   291 no strict 'refs';
  13         26  
  13         11814  
482 1 50       2 if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
  1         8  
483 0 0 0     0 return 1 if $lh->{'add_lex_hash_silent_if_already_added'} && exists $ref->{'hashes'} && exists $ref->{'hashes'}{$name};
      0        
484 0 0       0 if ( $ref->can('add_lookup_override_hash') ) {
485 0         0 return $ref->add_lookup_override_hash( $name, $hr );
486             }
487             }
488              
489 1         3 my $cur_errno = $!;
490 1 50       3 if ( eval { require Sub::Todo } ) {
  1         474  
491 0         0 goto &Sub::Todo::todo;
492             }
493             else {
494 1         4 $! = $cur_errno;
495 1         8 return;
496             }
497             }
498              
499             sub add_lexicon_fallback_hash {
500 1     1 0 813 my ( $lh, $langtag, $name, $hr ) = @_;
501 1 50       6 if ( @_ == 3 ) {
502 0         0 $hr = $name;
503 0         0 $name = $langtag;
504 0         0 $langtag = $lh->get_language_tag();
505             }
506              
507 1 50       5 my $ns = $lh->get_language_tag() eq $langtag ? $lh->get_language_class() : $lh->get_base_class();
508              
509 13     13   97 no strict 'refs';
  13         30  
  13         2973  
510 1 50       3 if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
  1         8  
511 0 0 0     0 return 1 if $lh->{'add_lex_hash_silent_if_already_added'} && exists $ref->{'hashes'} && exists $ref->{'hashes'}{$name};
      0        
512 0 0       0 if ( $ref->can('add_lookup_fallback_hash') ) {
513 0         0 return $ref->add_lookup_fallback_hash( $name, $hr );
514             }
515             }
516              
517 1         4 my $cur_errno = $!;
518 1 50       2 if ( eval { require Sub::Todo } ) {
  1         419  
519 0         0 goto &Sub::Todo::todo;
520             }
521             else {
522 1         5 $! = $cur_errno;
523 1         5 return;
524             }
525             }
526              
527             sub del_lexicon_hash {
528 2     2 1 1580 my ( $lh, $langtag, $name ) = @_;
529              
530 2 50       7 if ( @_ == 2 ) {
531 0 0       0 return if $langtag eq '*';
532 0         0 $name = $langtag;
533 0         0 $langtag = '*';
534             }
535              
536 2 50       5 return if !$langtag;
537              
538 2         5 my $count = 0;
539 2 100       7 if ( $langtag eq '*' ) {
540 13     13   82 no strict 'refs';
  13         29  
  13         2179  
541 1         6 for my $ns ( $lh->get_base_class(), $lh->get_language_class() ) {
542 2 50       3 if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
  2         19  
543 0 0       0 if ( $ref->can('del_lookup_hash') ) {
544 0         0 $ref->del_lookup_hash($name);
545 0         0 $count++;
546             }
547             }
548             }
549              
550 1 50       5 return 1 if $count;
551              
552 1         4 my $cur_errno = $!;
553 1 50       2 if ( eval { require Sub::Todo } ) {
  1         434  
554 0         0 goto &Sub::Todo::todo;
555             }
556             else {
557 1         4 $! = $cur_errno;
558 1         6 return;
559             }
560             }
561             else {
562 1 50       5 my $ns = $lh->get_language_tag() eq $langtag ? $lh->get_language_class() : $lh->get_base_class();
563              
564 13     13   85 no strict 'refs';
  13         36  
  13         127236  
565 1 50       3 if ( my $ref = tied( %{ $ns . '::Lexicon' } ) ) {
  1         8  
566 0 0       0 if ( $ref->can('del_lookup_hash') ) {
567 0         0 return $ref->del_lookup_hash($name);
568             }
569             }
570              
571 1         3 my $cur_errno = $!;
572 1 50       3 if ( eval { require Sub::Todo } ) {
  1         439  
573 0         0 goto &Sub::Todo::todo;
574             }
575             else {
576 1         3 $! = $cur_errno;
577 1         7 return;
578             }
579             }
580             }
581              
582             sub get_language_class {
583 244     244 1 1089 my ($lh) = @_;
584 244   66     1482 return ( ref($lh) || $lh );
585             }
586              
587             # $Autoalias is a bad idea, if we did this method we'd need to do a proper symbol/ISA traversal
588             # sub get_alias_list {
589             # my ($lh, $ns) = @_;
590             # $ns ||= $lh->get_base_class();
591             #
592             # no strict 'refs';
593             # if (defined @{ $ns . "::Autoalias"}) {
594             # return @{ $ns . "::Autoalias"};
595             # }
596             #
597             # return;
598             # }
599              
600             sub get_base_class_dir {
601 4     4 1 13 my ($lh) = @_;
602 4 100       16 if ( !exists $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} ) {
603 2         7 $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} = undef;
604              
605 2         7 my $inc_key = $lh->get_base_class();
606              
607             # require File::Spec; # only needed here, so we don't use() it
608 2         7 $inc_key =~ s{::}{/}g; # TODO make portable via File::Spec
609 2         3 $inc_key .= '.pm';
610 2 100       10 if ( exists $INC{$inc_key} ) {
611 1 50       16 if ( -e $INC{$inc_key} ) {
612 1         3 $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} = $INC{$inc_key};
613 1         4 $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'} =~ s{\.pm$}{};
614             }
615             }
616             }
617              
618 4         23 return $lh->{'Locale::Maketext::Utils'}{'_base_clase_dir'};
619             }
620              
621             sub list_available_locales {
622 2     2 1 5 my ($lh) = @_;
623              
624             # all comments in this function relate to get_alias_list() above
625             # my ($lh, $include_fileless_aliases) = @_;
626              
627             # my $base;
628             # if ($include_fileless_aliases) {
629             # $base = $lh->get_base_class_dir();
630             # }
631              
632 2   100     7 my $main_ns_dir = $lh->get_base_class_dir() || return;
633              
634             # glob() is disabled in some environments
635 1         2 my @glob;
636 1 50       48 if ( opendir my $dh, $main_ns_dir ) {
637 1 100 100     20 @glob = map { ( m{([^/]+)\.pm$} && $1 ne 'Utils' ) ? $1 : () } readdir($dh); #de-taint
  7         37  
638 1         14 closedir $dh;
639             }
640              
641             # return ($lh->get_alias_list($base)), grep { $_ ne 'Utils' }
642 1         15 return sort @glob;
643             }
644              
645             sub get_asset {
646 13     13 1 44 my ( $lh, $code, $tag ) = @_; # No caching since $code can do anything.
647              
648 13         44 my $loc_obj = $lh->get_locales_obj($tag);
649              
650 13         20 my $ret;
651             my $loc; # buffer
652 13         84 for $loc ( $loc_obj->get_fallback_list( $lh->{'Locales.pm'}{'get_fallback_list_special_lookup_coderef'} ) ) {
653              
654             # allow $code to be a soft ref?
655             # no strict 'refs';
656 20         343 $ret = $code->($loc);
657 20 100       99 last if defined $ret;
658             }
659              
660 13 100       91 return $ret if defined $ret;
661 4         17 return;
662             }
663              
664             sub get_asset_file {
665 3     3 1 35888 my ( $lh, $find, $return ) = @_;
666 3 50       16 $return = $find if !defined $return;
667              
668 3 100       76 return $lh->{'cache'}{'get_asset_file'}{$find}{$return} if exists $lh->{'cache'}{'get_asset_file'}{$find}{$return};
669              
670             $lh->{'cache'}{'get_asset_file'}{$find}{$return} = $lh->get_asset(
671             sub {
672 3 100   3   241 return sprintf( $return, $_[0] ) if -f sprintf( $find, $_[0] );
673 2         5 return;
674             }
675 2         16 );
676              
677 2 100       29 return $lh->{'cache'}{'get_asset_file'}{$find}{$return} if defined $lh->{'cache'}{'get_asset_file'}{$find}{$return};
678 1         5 return;
679             }
680              
681             sub get_asset_dir {
682 3     3 1 32 my ( $lh, $find, $return ) = @_;
683 3 50       10 $return = $find if !defined $return;
684              
685 3 100       18 return $lh->{'cache'}{'get_asset_dir'}{$find}{$return} if exists $lh->{'cache'}{'get_asset_dir'}{$find}{$return};
686              
687             $lh->{'cache'}{'get_asset_dir'}{$find}{$return} = $lh->get_asset(
688             sub {
689 3 100   3   275 return sprintf( $return, $_[0] ) if -d sprintf( $find, $_[0] );
690 2         5 return;
691             }
692 2         15 );
693              
694 2 100       18 return $lh->{'cache'}{'get_asset_dir'}{$find}{$return} if defined $lh->{'cache'}{'get_asset_dir'}{$find}{$return};
695 1         5 return;
696             }
697              
698             sub delete_cache {
699 4     4 1 1580 my ( $lh, $which ) = @_;
700 4 100       18 if ( defined $which ) {
701 3         20 return delete $lh->{'cache'}{$which};
702             }
703             else {
704 1         11 return delete $lh->{'cache'};
705             }
706             }
707              
708             #### CLDR aware quant()/numerate ##
709              
710             sub quant {
711 15     15 1 119 my ( $handle, $num, @forms ) = @_;
712              
713 15         23 my $max_decimal_places = 3;
714              
715 15 100       47 if ( ref($num) eq 'ARRAY' ) {
716 7         12 $max_decimal_places = $num->[1];
717 7         17 $num = $num->[0];
718             }
719              
720             # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
721             # method call if we already have the Locales object that belongs to the handle's locale.
722 15   66     83 $handle->{'Locales.pm'}{'_main_'} ||= $handle->get_locales_obj();
723              
724             # numerate() is scalar context get_plural_form(), we need array context get_plural_form() here
725 15         77 my ( $string, $spec_zero ) = $handle->{'Locales.pm'}{'_main_'}->get_plural_form( $num, @forms );
726              
727             # If you find a need for more than 1 %s please submit an rt w/ details
728 15 100 100     1156 if ( $string =~ m/%s\b/ ) {
    100          
729 7         64 return sprintf( $string, $handle->numf( $num, $max_decimal_places ) );
730             }
731             elsif ( $num == 0 && $spec_zero ) {
732 3         8 return $string;
733             }
734             else {
735 5         21 $handle->numf( $num, $max_decimal_places ) . " $string";
736             }
737             }
738              
739             sub numerate {
740 0     0 1 0 my ( $handle, $num, @forms ) = @_;
741              
742             # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
743             # method call if we already have the Locales object that belongs to the handle's locale.
744 0   0     0 $handle->{'Locales.pm'}{'_main_'} ||= $handle->get_locales_obj();
745              
746 0         0 return scalar( $handle->{'Locales.pm'}{'_main_'}->get_plural_form( $num, @forms ) );
747             }
748              
749             #### CLDR aware quant()/numerate ##
750              
751             #### CLDR aware numf() w/ decimal ##
752              
753             sub numf {
754 33     33 1 537 my ( $handle, $num, $max_decimal_places ) = @_;
755              
756             # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
757             # method call if we already have the Locales object that belongs to the handle's locale.
758 33   66     121 $handle->{'Locales.pm'}{'_main_'} ||= $handle->get_locales_obj();
759              
760 33         149 return $handle->{'Locales.pm'}{'_main_'}->get_formatted_decimal( $num, $max_decimal_places );
761             }
762              
763             #### / CLDR aware numf() w/ decimal/formatter ##
764              
765             #### more BN methods ##
766              
767             # W1301 revision 1:
768             # [value] was a proposed way to avoid ambiguous '_thisthing' keys by "tagging" a phrase
769             # as having a value different from the key while keeping it self-documenting:
770             # '[value] Description of foo, arguments are …'
771             # sub value {
772             # my ($lh, @contexts) = @_;
773             #
774             # return '' if !@contexts; # must be for all contexts, cool
775             #
776             # my $context = $lh->get_context();
777             #
778             # if (!grep { $context eq $_ } @contexts) {
779             # require Carp;
780             # local $Carp::CarpLevel = 1;
781             # my $context_csv = join(',',@contexts);
782             # Carp::carp("The current context “$context” is not supported by the phrase ([value,$context_csv])");
783             # }
784             # return '';
785             # }
786              
787             sub join {
788 4     4 1 41 shift;
789 4 50       10 return CORE::join( shift, map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_ );
  13         45  
  0         0  
790             }
791              
792             sub list_and {
793 4     4 1 23 my $lh = shift;
794              
795             # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
796             # method call if we already have the Locales object that belongs to the handle's locale.
797 4   33     18 $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
798 4 50       13 return $lh->{'Locales.pm'}{'_main_'}->get_list_and( map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_ );
  24         61  
  0         0  
799             }
800              
801             sub list_or {
802 0     0 1 0 my $lh = shift;
803              
804             # Even though get_locales_obj() memoizes/caches/singletons itself we can still avoid a
805             # method call if we already have the Locales object that belongs to the handle's locale.
806 0   0     0 $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
807 0 0       0 return $lh->{'Locales.pm'}{'_main_'}->get_list_or( map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_ );
  0         0  
  0         0  
808             }
809              
810             sub list_and_quoted {
811 2     2 1 3411 my ( $lh, @args ) = @_;
812              
813 2   33     11 $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
814 2         7 local $lh->{'Locales.pm'}{'_main_'}{'misc'}{'list_quote_mode'} = 'all';
815 2         9 return $lh->list_and(@args);
816             }
817              
818             sub list_or_quoted {
819 0     0 1 0 my ( $lh, @args ) = @_;
820              
821 0   0     0 $lh->{'Locales.pm'}{'_main_'} ||= $lh->get_locales_obj();
822 0         0 local $lh->{'Locales.pm'}{'_main_'}{'misc'}{'list_quote_mode'} = 'all';
823 0         0 return $lh->list_or(@args);
824             }
825              
826             sub list {
827 0     0 1 0 require Carp;
828 0         0 Carp::carp('list() is deprecated, use list_and() or list_or() instead');
829              
830 0         0 my $lh = shift;
831 0         0 my $com_sep = ', ';
832 0         0 my $oxford = ',';
833 0         0 my $def_sep = '&';
834              
835 0 0       0 if ( ref($lh) ) {
836 0 0       0 $com_sep = $lh->{'list_separator'} if exists $lh->{'list_separator'};
837 0 0       0 $oxford = $lh->{'oxford_separator'} if exists $lh->{'oxford_separator'};
838 0 0       0 $def_sep = $lh->{'list_default_and'} if exists $lh->{'list_default_and'};
839             }
840              
841 0   0     0 my $sep = shift || $def_sep;
842 0 0       0 return if !@_;
843              
844 0 0       0 my @expanded = map { ref($_) eq 'ARRAY' ? @{$_} : $_ } @_;
  0         0  
  0         0  
845 0 0       0 if ( @expanded == 1 ) {
    0          
846 0         0 return $expanded[0];
847             }
848             elsif ( @expanded == 2 ) {
849 0         0 return CORE::join( " $sep ", @expanded );
850             }
851             else {
852 0         0 my $last = pop @expanded;
853 0         0 return CORE::join( $com_sep, @expanded ) . "$oxford $sep $last";
854             }
855             }
856              
857             sub output_asis {
858 4     4 0 20 return $_[1];
859             }
860              
861             sub asis {
862 4     4 1 36 return $_[0]->output( 'asis', $_[1] ); # this allows for embedded methods but still called via [asis,...] instead of [output,asis,...]
863             }
864              
865             sub comment {
866 2     2 1 37 return '';
867             }
868              
869             sub is_future {
870 0     0 1 0 my ( $lh, $dt, $future, $past, $current, $current_type ) = @_;
871              
872 0 0       0 if ( $dt !~ m/\A[0-9]+\z/ ) {
873 0         0 $dt = __get_dt_obj_from_arg( $dt, 0 );
874 0         0 $dt = $dt->epoch();
875             }
876              
877 0 0       0 if ($current) {
878 0 0       0 if ( !ref $dt ) {
879 0         0 $dt = __get_dt_obj_from_arg( $dt, 0 );
880             }
881 0   0     0 $current_type ||= 'hour';
882              
883 0 0       0 if ( $current_type eq 'day' ) {
    0          
884              
885             # TODO implement
886             }
887             elsif ( $current_type eq 'minute' ) {
888              
889             # TODO implement
890             }
891             else {
892              
893             # TODO implement
894             }
895             }
896              
897 0 0       0 return ref $dt ? $dt->epoch() : $dt > time() ? $future : $past;
    0          
898             }
899              
900             sub __get_dt_obj_from_arg {
901 15     15   1545 require DateTime;
902             return
903 6         39 !defined $_[0] || $_[0] eq '' ? DateTime->now()
904 15 50 100     272672 : ref $_[0] eq 'HASH' ? DateTime->new( %{ $_[0] } )
    50 100        
    100 0        
    100          
    100          
905             : $_[0] =~ m{ \A (\d+ (?: [.] \d+ )? ) (?: [:] (.*) )? \z }xms ? DateTime->from_epoch( 'epoch' => $1, 'time_zone' => ( $2 || 'UTC' ) )
906             : !ref $_[0] ? DateTime->now( 'time_zone' => ( $_[0] || 'UTC' ) )
907             : $_[1] ? $_[0]->clone()
908             : $_[0];
909             }
910              
911             sub current_year {
912 1     1 1 15 $_[0]->datetime( '', 'YYYY' );
913             }
914              
915             sub datetime {
916 15     15 1 101 my ( $lh, $dta, $str ) = @_;
917 15         36 my $dt = __get_dt_obj_from_arg( $dta, 1 );
918              
919 15         3416 $dt->{'locale'} = DateTime::Locale->load( $lh->language_tag() );
920 15 100       6094 my $format = ref $str eq 'CODE' ? $str->($dt) : $str;
921 15 100       171 if ( defined $format ) {
922 13 100       117 if ( $dt->{'locale'}->can($format) ) {
923 3         14 $format = $dt->{'locale'}->$format();
924             }
925             }
926              
927 15 100       75 $format = '' if !defined $format;
928 15   66     74 return $dt->format_cldr( $dt->{'locale'}->format_for($format) || $format || $dt->{'locale'}->date_format_long() );
929             }
930              
931 4     4 0 17 sub output_amp { return $_[0]->output_chr(38) } # TODO: ? make the rest of these embeddable like amp() ?
932 2     2 0 9 sub output_lt { return $_[0]->output_chr(60) }
933 2     2 0 11 sub output_gt { return $_[0]->output_chr(62) }
934 2     2 0 9 sub output_apos { return $_[0]->output_chr(39) }
935 2     2 0 9 sub output_quot { return $_[0]->output_chr(34) }
936 2     2 0 12 sub output_shy { return $_[0]->output_chr(173) }
937              
938             # sub output_codepoint {
939             # my $cp = $_[1];
940             # $cp =~ s/[^0-9a-fA-F]+//g;
941             # return if !$cp;
942             # return "U+$cp";
943             # }
944             #
945             # my %latin = (
946             # 'etc' => 'etc.', # et cetera: And [more|the rest|so on]
947             # 'ie' => 'i.e.', # id est: that is
948             # 'eg' => 'e.g.', # exempli gratia: for the sake of example
949             # 'ps' => 'p.s.', # after what has been written
950             # 'pps' => 'p.p.s.', # post post scriptum
951             # 'etal' => 'et al.', # et alii: and others
952             # 'cf' => 'cf.', # compare to
953             # 'vs' => 'vs', # versus
954             # 'v' => 'v.', # shorter version of vs
955             # 'adhoc' => 'ad hoc', # for this (improvised or made for a specific, immediate purpose)
956             # 'adinf' => 'ad infinitum', # to infinity
957             # 'adint' => 'ad interim', # or the meantime
958             # 're' => 'Re', # by the thing, in the matter of
959             # 'rip' => 'R.I.P.', # requiescat in pace
960             # 'qv' => 'q.v.', # quod vide
961             # );
962             #
963             # sub output_latin {
964             # return if !exists $latin{$_[1]};
965             # return $_[0]->makethis($latin{$_[1]}); # makethis() would allow for [output,abbr,…] and [output,acronym,…]
966             # }
967              
968             sub output_nbsp {
969              
970             # Use grapheme here since the NO-BREAK SPACE is visually ambiguous when typed (e.g. OSX option-space)
971              
972             # The character works the same as the entity so checking the context doesn't gain us much.
973             # Any interest in being able to specify a mode that you might want the entity under HTML mode?
974             # my ($lh, $context_aware) = @_;
975             # if ($context_aware) {
976             # return $lh->context_is_html() ? ' ' : "\xC2\xA0";
977             # }
978             # else {
979             # return "\xC2\xA0";
980             # }
981             # or simply do the entity:
982             # return $_[0]->context_is_html() ? ' ' : "\xC2\xA0";
983              
984 3     3 0 17 return "\xC2\xA0";
985             }
986              
987             my $space;
988              
989             sub format_bytes {
990 10     10 1 3946 my ( $lh, $bytes, $max_decimal_place ) = @_;
991 10   100     46 $bytes ||= 0;
992              
993 10 100       28 if ( !defined $max_decimal_place ) {
994 8         14 $max_decimal_place = 2;
995             }
996             else {
997 2         5 $max_decimal_place = int( abs($max_decimal_place) );
998             }
999              
1000 10         21 my $absnum = abs($bytes);
1001              
1002 10   66     54 $space ||= $lh->output_nbsp(); # avoid method call if we already have it
1003              
1004             # override if you want different behavior or more flexibility, as-is these are the ideas behind it:
1005             # * Calculate via 1024's not 1000's
1006             # * Max decimals set to 2 (this is for human consumption not math operation)
1007             # * Either 'n byte/n bytes' (since there is no good universal suffix for "byte")
1008             # or 'n . non-breaking-space . SI-SUFFIX' (Yes technically MiB is more accurate
1009             # here than MB, but for now it has to remain this way for legacy reasons)
1010             # * simple math/logic is done here so that there is no need to bring in a module
1011 10 100       61 if ( $absnum < 1024 ) {
    50          
    50          
    0          
    0          
    0          
    0          
    0          
1012              
1013             # This is a special, internal-to-format_bytes, phrase: developers will not have to deal with this phrase directly.
1014 7         66 return $lh->maketext( '[quant,_1,%s byte,%s bytes]', [ $bytes, $max_decimal_place ] ); # the space between the '%s' and the 'b' is a non-break space (e.g. option-spacebar, not spacebar)
1015             # We do not use $space or \xC2\xA0 since:
1016             # * parsers would need to know how to interpolate them in order to work with the phrase in the context of the system
1017             # * the non-breaking space character behaves as you'd expect its various representations to.
1018             # Should a second instance of this sort of thing happen we can revisit the idea of adding [comment] in the phrase itself or perhaps supporting an embedded call to [output,nbsp].
1019             }
1020             elsif ( $absnum < 1048576 ) {
1021 0         0 return $lh->numf( ( $bytes / 1024 ), $max_decimal_place ) . $space . 'KB';
1022             }
1023             elsif ( $absnum < 1073741824 ) {
1024 3         11 return $lh->numf( ( $bytes / 1048576 ), $max_decimal_place ) . $space . 'MB';
1025             }
1026             elsif ( $absnum < 1099511627776 ) {
1027 0         0 return $lh->numf( ( $bytes / 1073741824 ), $max_decimal_place ) . $space . 'GB';
1028             }
1029             elsif ( $absnum < 1125899906842624 ) {
1030 0         0 return $lh->numf( ( $bytes / 1099511627776 ), $max_decimal_place ) . $space . 'TB';
1031             }
1032             elsif ( $absnum < ( 1125899906842624 * 1024 ) ) {
1033 0         0 return $lh->numf( ( $bytes / 1125899906842624 ), $max_decimal_place ) . $space . 'PB';
1034             }
1035             elsif ( $absnum < ( 1125899906842624 * 1024 * 1024 ) ) {
1036 0         0 return $lh->numf( ( $bytes / ( 1125899906842624 * 1024 ) ), $max_decimal_place ) . $space . 'EB';
1037             }
1038             elsif ( $absnum < ( 1125899906842624 * 1024 * 1024 * 1024 ) ) {
1039 0         0 return $lh->numf( ( $bytes / ( 1125899906842624 * 1024 * 1024 ) ), $max_decimal_place ) . $space . 'ZB';
1040             }
1041             else {
1042              
1043             # any reason to do the commented out code? if so please rt w/ details!
1044             # elsif ( $absnum < ( 1125899906842624 * 1024 * 1024 * 1024 * 1024 ) ) {
1045 0         0 return $lh->numf( ( $bytes / ( 1125899906842624 * 1024 * 1024 * 1024 ) ), $max_decimal_place ) . $space . 'YB';
1046              
1047             # }
1048             # else {
1049             #
1050             # # This should never happen but just in case lets show something:
1051             # return $lh->maketext( '[quant,_1,%s byte,%s bytes]', $bytes ); # See info about this above/incorporate said info should this ever be uncommented
1052             }
1053             }
1054              
1055             sub convert {
1056 0     0 1 0 shift;
1057 0         0 require Math::Units;
1058 0         0 return Math::Units::convert(@_);
1059             }
1060              
1061             sub is_defined {
1062 0     0 1 0 my ( $lh, $value, $is_defined, $not_defined, $is_defined_but_false ) = @_;
1063              
1064 0 0       0 return __proc_string_with_embedded_under_vars($not_defined) if !defined $value;
1065              
1066 0 0 0     0 if ( defined $is_defined_but_false && !$value ) {
1067 0         0 return __proc_string_with_embedded_under_vars($is_defined_but_false);
1068             }
1069             else {
1070 0         0 return __proc_string_with_embedded_under_vars($is_defined);
1071             }
1072             }
1073              
1074             sub boolean {
1075 6     6 1 41 my ( $lh, $boolean, $true, $false, $null ) = @_;
1076 6 100       14 if ($boolean) {
1077 2         6 return __proc_string_with_embedded_under_vars($true);
1078             }
1079             else {
1080 4 100 100     26 if ( !defined $boolean && defined $null ) {
1081 1         5 return __proc_string_with_embedded_under_vars($null);
1082             }
1083 3         7 return __proc_string_with_embedded_under_vars($false);
1084             }
1085             }
1086              
1087             sub __proc_string_with_embedded_under_vars {
1088 91     91   126 my $str = $_[0];
1089 91 100       202 return if !defined $str;
1090              
1091 84 100       293 return $str if $str !~ m/\_(\-?[0-9]+)/;
1092 5         19 my @args = __caller_args( $_[1] ); # this way be dragons
1093 5         46 $str =~ s/\_(\-?[0-9]+)/$args[$1]/g;
1094 5         25 return $str;
1095             }
1096              
1097             # sweet sweet magic stolen from Devel::Caller
1098             sub __caller_args {
1099              
1100             package DB;
1101 5     5   31 () = caller( $_[0] + 3 );
1102 5         151 return @DB::args;
1103             }
1104              
1105             sub __proc_emb_meth {
1106 31     31   53 my ( $lh, $str ) = @_;
1107              
1108 31 100       79 return if !defined $str;
1109              
1110 24         52 $str =~ s/(su[bp])\(((?:\\\)|[^\)])+?)\)/my $s=$2;my $m="output_$1";$s=~s{\\\)}{\)}g;$lh->$m($s)/eg;
  2         4  
  2         5  
  2         3  
  2         17  
1111 24         69 $str =~ s/chr\(((?:\d+|[\S]))\)/$lh->output_chr($1)/eg;
  7         29  
1112 24         47 $str =~ s/numf\((\d+(?:\.\d+)?)\)/$lh->numf($1)/eg;
  1         9  
1113 24         115 $str =~ s/amp\(\)/$lh->output_amp()/eg;
  2         14  
1114              
1115 24         57 return $str;
1116             }
1117              
1118             sub output {
1119 148     148 1 1061 my ( $lh, $output_function, $string, @output_function_args ) = @_;
1120              
1121 148 100 66     953 if ( defined $string && $string ne '' && $string =~ tr/(// ) {
      66        
1122 5         18 $string = __proc_emb_meth( $lh, $string );
1123             }
1124              
1125 148 100       1532 if ( my $cr = $lh->can( 'output_' . $output_function ) ) {
1126 147         381 return $cr->( $lh, $string, @output_function_args );
1127             }
1128             else {
1129 1         3 my $cur_errno = $!;
1130 1 50       2 if ( eval { require Sub::Todo } ) {
  1         477  
1131 0         0 $! = Sub::Todo::get_errno_func_not_impl();
1132             }
1133             else {
1134 1         5 $! = $cur_errno;
1135             }
1136 1         6 return $string;
1137             }
1138             }
1139              
1140             sub output_encode_puny {
1141 10     10 0 351 my ( $lh, $utf8 ) = @_; # ? TODO or YAGNI ? accept either unicode ot utf8 string (i.e. via String::UnicodeUTF8 instead of utf8::- if so, use in output_decode_puny also)
1142 10 100       70 return $utf8 if $utf8 =~ m/xn--/; # do not encode it if it is already punycode
1143              
1144 6         1147 require Net::IDN::Encode;
1145              
1146 6         163487 my $res;
1147 6 100       84 if ( $utf8 =~ m/(?:\@|\xef\xbc\xa0|\xef\xb9\xab)/ ) { # \x{0040}, \x{FF20}, \x{FE6B} no need for \x{E0040} right?
1148 4         33 my ( $nam, $dom ) = split( /(?:\@|\xef\xbc\xa0|\xef\xb9\xab)/, $utf8, 2 );
1149              
1150             # TODO: ? multiple @ signs ...
1151             # my ($dom,$nam) = split(/\@/,reverse($_[1]),2);
1152             # $dom = reverse($dom);
1153             # $nam = reverse($nam);
1154 4         18 utf8::decode($nam); # turn utf8 bytes into a unicode string
1155 4         15 utf8::decode($dom); # turn utf8 bytes into a unicode string
1156              
1157 4         12 eval { $res = Net::IDN::Encode::domain_to_ascii($nam) . '@' . Net::IDN::Encode::domain_to_ascii($dom); };
  4         27  
1158 4 100       2180 return 'Error: invalid string for punycode' if $@;
1159             }
1160             else {
1161 2         9 utf8::decode($utf8); # turn utf8 bytes into a unicode string
1162 2         4 eval { $res = Net::IDN::Encode::domain_to_ascii($utf8); };
  2         8  
1163 2 100       28447 return 'Error: invalid string for punycode' if $@;
1164             }
1165              
1166 4         44 return $res;
1167             }
1168              
1169             sub output_decode_puny {
1170 8     8 0 17 my ( $lh, $puny ) = @_;
1171 8 100       51 return $puny if $puny !~ m/xn--/; # do not decode it if it isn't punycode
1172              
1173 4         29 require Net::IDN::Encode;
1174              
1175 4         10 my $res;
1176 4 100       18 if ( $puny =~ m/\@/ ) {
1177 3         13 my ( $nam, $dom ) = split( /@/, $puny, 2 );
1178              
1179             # TODO: ? multiple @ signs ...
1180             # my ($dom,$nam) = split(/\@/,reverse($_[1]),2);
1181             # $dom = reverse($dom);
1182             # $nam = reverse($nam);
1183 3         6 eval { $res = Net::IDN::Encode::domain_to_unicode($nam) . '@' . Net::IDN::Encode::domain_to_unicode($dom); };
  3         14  
1184 3 50       2060 return "Error: invalid punycode" if $@;
1185             }
1186             else {
1187 1         2 eval { $res = Net::IDN::Encode::domain_to_unicode($puny); };
  1         7  
1188 1 50       865 return "Error: invalid punycode" if $@;
1189             }
1190              
1191 4         15 utf8::encode($res); # turn unicode string back into utf8 bytes
1192 4         27 return $res;
1193             }
1194              
1195             my $has_encode; # checking for Encode this way facilitates only checking @INC once for the module on systems that do not have Encode
1196              
1197             sub output_chr {
1198 39     39 0 72 my ( $lh, $chr_num ) = @_;
1199              
1200 39 100       168 if ( $chr_num !~ m/\A\d+\z/ ) {
1201 4 50       12 return if length($chr_num) != 1;
1202 4 50       25 return $chr_num if !$lh->context_is_html();
1203              
1204             return
1205 0 0       0 $chr_num eq '"' ? '"'
    0          
    0          
    0          
    0          
1206             : $chr_num eq '&' ? '&'
1207             : $chr_num eq "'" ? '''
1208             : $chr_num eq '<' ? '<'
1209             : $chr_num eq '>' ? '>'
1210             : $chr_num;
1211             }
1212 35 50       128 return if $chr_num !~ m/\A\d+\z/;
1213 35         93 my $chr = chr($chr_num);
1214              
1215             # perldoc chr: Note that characters from 128 to 255 (inclusive) are by default internally not encoded as UTF-8 for backward compatibility reasons.
1216 35 100       76 if ( $chr_num > 127 ) {
1217              
1218             # checking for Encode this way facilitates only checking @INC once for the module on systems that do not have Encode
1219 4 100       12 if ( !defined $has_encode ) {
1220 1         3 $has_encode = 0;
1221 1         2 eval { require Encode; $has_encode = 1; };
  1         44  
  1         3  
1222             }
1223              
1224             # && $chr_num < 256) { # < 256 still needs Encode::encode()d in order to avoid "Wide character" warning
1225 4 50       11 if ($has_encode) {
1226 4         31 $chr = Encode::encode( $lh->encoding(), $chr );
1227             }
1228              
1229             # elsif (defined &utf8::???) { ??? }
1230             else {
1231              
1232             # This binmode trick can cause chr() to render and not have a "Wide character" warning but ... yikes ...:
1233             # eval { binmode(STDOUT, ":utf8") } - eval beacuse perl 5.6 "Unknown discipline ':utf8' at ..." which means this would be pointless in addition to scary
1234              
1235             # warn "Encode.pm is not available so chr($chr_num) may or may not be encoded properly.";
1236              
1237             # chr() has issues (e.g. display problems) on any perl with or without Encode.pm (esspecially when $chr_num is 128 .. 255).
1238             # On 5.6 perl (i.e. no Encode.pm) \x{00AE} works so:
1239             # sprintf('%04X', $chr_num); # e.g. turn '174' into '00AE'
1240             # It could be argued that this only needs done when $chr_num < 256 but it works so leave it like this for consistency and in case it is needed under specific circumstances
1241              
1242 0         0 $chr = eval '"\x{' . sprintf( '%04X', $chr_num ) . '}"';
1243             }
1244             }
1245              
1246 35 100       426 if ( !$lh->context_is_html() ) {
1247 18         80 return $chr;
1248             }
1249             else {
1250             return
1251 17 100 66     229 $chr_num == 34 || $chr_num == 147 || $chr_num == 148 ? '"'
    100 66        
    100          
    100          
    100          
    100          
1252             : $chr_num == 38 ? '&'
1253             : $chr_num == 39 || $chr_num == 145 || $chr_num == 146 ? '''
1254             : $chr_num == 60 ? '<'
1255             : $chr_num == 62 ? '>'
1256             : $chr_num == 173 ? '­'
1257             : $chr;
1258             }
1259             }
1260              
1261             sub output_class {
1262 4     4 0 12 my ( $lh, $string, @classes ) = @_;
1263 4         14 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1264 4 50       19 return $string if $lh->context_is_plain();
1265              
1266             # my $class_str = join(' ', @classes); # in case $" is hosed?
1267             # TODO maybe: use @classes to get ANSI color map of some sort
1268 4 100       18 return $lh->context_is_ansi() ? "\e[1m$string\e[0m" : qq{$string};
1269             }
1270              
1271             sub output_asis_for_tests {
1272 0     0 0 0 my ( $lh, $string ) = @_;
1273 0         0 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1274 0         0 return $string;
1275             }
1276              
1277             sub __make_attr_str_from_ar {
1278 85     85   160 my ( $attr_ar, $strip_hr, $addin ) = @_;
1279 85 50       219 if ( ref($attr_ar) eq 'HASH' ) {
1280 0         0 $strip_hr = $attr_ar;
1281 0         0 $attr_ar = [];
1282             }
1283              
1284 85         120 my $attr = '';
1285 85 100       200 my $general_hr = ref( $attr_ar->[-1] ) eq 'HASH' ? pop( @{$attr_ar} ) : undef;
  46         70  
1286              
1287 85         106 my $idx = 0;
1288 85         84 my $ar_len = @{$attr_ar};
  85         135  
1289              
1290 85 100       197 $idx = 1 if $ar_len % 2; # handle “Odd number of elements” …
1291              
1292 85         96 my $did_addin;
1293              
1294 85         209 while ( $idx < $ar_len ) {
1295 61 100       148 if ( exists $strip_hr->{ $attr_ar->[$idx] } ) {
1296 16         21 $idx += 2;
1297 16         32 next;
1298             }
1299 45         64 my $atr = $attr_ar->[$idx];
1300 45         64 my $val = $attr_ar->[ ++$idx ];
1301 45 100       99 if ( exists $addin->{$atr} ) {
1302 2         6 $val = "$addin->{$atr} $val";
1303 2         7 $did_addin->{$atr}++;
1304             }
1305              
1306 45         115 $attr .= qq{ $atr="$val"};
1307 45         110 $idx++;
1308             }
1309              
1310 85 100       180 if ($general_hr) {
1311 46         62 for my $k ( keys %{$general_hr} ) {
  46         126  
1312 35 100       90 next if exists $strip_hr->{$k};
1313 31 100       68 if ( exists $addin->{$k} ) {
1314 2         7 $general_hr->{$k} = "$addin->{$k} $general_hr->{$k}";
1315 2         4 $did_addin->{$k}++;
1316             }
1317 31         120 $attr .= qq{ $k="$general_hr->{$k}"};
1318             }
1319             }
1320              
1321 85         114 for my $r ( keys %{$addin} ) {
  85         242  
1322 9 100       25 if ( !exists $did_addin->{$r} ) {
1323 6         22 $attr .= qq{ $r="$addin->{$r}"};
1324             }
1325             }
1326              
1327 85         429 return $attr;
1328             }
1329              
1330             sub output_inline {
1331 9     9 0 23 my ( $lh, $string, @attrs ) = @_;
1332 9         18 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1333 9 50       53 return $string if !$lh->context_is_html();
1334              
1335 9         25 my $attr = __make_attr_str_from_ar( \@attrs );
1336 9         42 return qq{$string};
1337             }
1338              
1339             *output_attr = \&output_inline;
1340              
1341             sub output_block {
1342 4     4 0 13 my ( $lh, $string, @attrs ) = @_;
1343 4         10 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1344 4 50       20 return $string if !$lh->context_is_html();
1345              
1346 4         9 my $attr = __make_attr_str_from_ar( \@attrs );
1347 4         20 return qq{$string};
1348             }
1349              
1350             sub output_img {
1351 10     10 0 25 my ( $lh, $src, $alt, @attrs ) = @_;
1352              
1353 10 100 100     46 if ( !defined $alt || $alt eq '' ) {
1354 3         6 $alt = $src;
1355             }
1356             else {
1357 7         19 $alt = __proc_string_with_embedded_under_vars( $alt, 1 );
1358             }
1359              
1360 10 100       46 return $alt if !$lh->context_is_html();
1361              
1362 9         50 my $attr = __make_attr_str_from_ar( \@attrs, { 'alt' => 1, 'src' => 1 } );
1363 9         53 return qq{$alt};
1364             }
1365              
1366             sub output_abbr {
1367 7     7 0 21 my ( $lh, $abbr, $full, @attrs ) = @_;
1368 7 100       34 return !$lh->context_is_html()
1369             ? "$abbr ($full)"
1370             : qq{ 1 } ) . qq{>$abbr};
1371             }
1372              
1373             sub output_acronym {
1374 10     10 0 30 my ( $lh, $acronym, $full, @attrs ) = @_;
1375              
1376             # ala bootstrap: class="initialism"
1377 10 100       40 return !$lh->context_is_html()
1378             ? "$acronym ($full)"
1379             : qq{ 1 }, { 'class' => 'initialism' } ) . qq{>$acronym};
1380             }
1381              
1382             sub output_sup {
1383 5     5 0 12 my ( $lh, $string, @attrs ) = @_;
1384 5         12 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1385 5 50       21 return !$lh->context_is_html() ? $string : qq{$string};
1386             }
1387              
1388             sub output_sub {
1389 5     5 0 13 my ( $lh, $string, @attrs ) = @_;
1390 5         10 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1391 5 50       24 return !$lh->context_is_html() ? $string : qq{$string};
1392             }
1393              
1394             sub output_underline {
1395 5     5 0 14 my ( $lh, $string, @attrs ) = @_;
1396              
1397 5         16 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1398 5 50       30 return $string if $lh->context_is_plain();
1399 5 100       29 return $lh->context_is_ansi() ? "\e[4m$string\e[0m" : qq{$string};
1400             }
1401              
1402             sub output_strong {
1403 14     14 0 31 my ( $lh, $string, @attrs ) = @_;
1404              
1405 14         46 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1406 14 100       69 return $string if $lh->context_is_plain();
1407 12 100       60 return $lh->context_is_ansi() ? "\e[1m$string\e[0m" : '$string";
1408             }
1409              
1410             sub output_em {
1411 6     6 0 51 my ( $lh, $string, @attrs ) = @_;
1412              
1413 6         15 $string = __proc_string_with_embedded_under_vars( $string, 1 );
1414 6 50       25 return $string if $lh->context_is_plain();
1415              
1416             # italic code 3 is specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most displays and emulators, but we can try!
1417 6 100       25 return $lh->context_is_ansi() ? "\e[3m$string\e[0m" : '$string";
1418             }
1419              
1420             # output,del output,strike (ick):
1421             # strike-though code 9 is specified in ANSI X3.64 and ECMA-048 but are not commonly supported by most displays and emulators, but we can try!
1422              
1423             sub output_url {
1424 35     35 0 79 my ( $lh, $url, @args ) = @_;
1425 35   100     102 $url ||= ''; # carp() ?
1426              
1427 35 100       95 my $arb_args_hr = ref $args[-1] eq 'HASH' ? pop(@args) : {};
1428 35 100       154 my ( $url_text, %output_config ) = @args % 2 ? @args : ( undef, @args );
1429              
1430 35         52 my $return = $url;
1431              
1432 35 100       144 if ( !$lh->context_is_html() ) {
1433 16 100       39 if ($url_text) {
1434 1         3 $url_text = __proc_emb_meth( $lh, $url_text );
1435 1         3 $url_text = __proc_string_with_embedded_under_vars( $url_text, 1 );
1436 1         11 return "$url_text ($url)";
1437             }
1438              
1439 15 100       54 if ( exists $output_config{'plain'} ) {
1440 6   33     14 $output_config{'plain'} ||= $url;
1441 6         8 my $orig = $output_config{'plain'};
1442 6         14 $output_config{'plain'} = __proc_emb_meth( $lh, $output_config{'plain'} );
1443 6         14 $output_config{'plain'} = __proc_string_with_embedded_under_vars( $output_config{'plain'}, 1 );
1444              
1445 6 100 100     98 $return = $orig ne $output_config{'plain'} && $output_config{'plain'} =~ m/\Q$url\E/ ? $output_config{'plain'} : "$output_config{'plain'} $url";
1446             }
1447             }
1448             else {
1449 19 100       47 if ( exists $output_config{'html'} ) {
1450 4         11 $output_config{'html'} = __proc_emb_meth( $lh, $output_config{'html'} );
1451 4         12 $output_config{'html'} = __proc_string_with_embedded_under_vars( $output_config{'html'}, 1 );
1452             }
1453              
1454 19 100       44 if ( !$output_config{'html'} ) {
1455 15         31 $url_text = __proc_emb_meth( $lh, $url_text );
1456 15         30 $url_text = __proc_string_with_embedded_under_vars( $url_text, 1 );
1457             }
1458              
1459 19   66     92 $output_config{'html'} ||= $url_text || $url;
      66        
1460              
1461 19         114 my $attr = __make_attr_str_from_ar(
1462             [ @args, $arb_args_hr ],
1463             {
1464             'html' => 1,
1465             'href' => 1,
1466             'plain' => 1,
1467             '_type' => 1,
1468             }
1469             );
1470              
1471 19 100 66     134 $return = exists $output_config{'_type'}
1472             && $output_config{'_type'} eq 'offsite' ? qq{$output_config{'html'}} : qq{$output_config{'html'}};
1473             }
1474              
1475 34         210 return $return;
1476             }
1477              
1478             #### / more BN methods ##
1479              
1480             #### output context methods ##
1481              
1482             sub set_context_html {
1483 3     3 1 584 my ( $lh, $empty ) = @_;
1484 3         15 my $cur = $lh->get_context();
1485 3         16 $lh->set_context('html');
1486 3 50       21 return if !$lh->context_is_html();
1487 3 50       18 return $empty ? '' : $cur;
1488             }
1489              
1490             sub set_context_ansi {
1491 2     2 1 6 my ( $lh, $empty ) = @_;
1492 2         10 my $cur = $lh->get_context();
1493 2         7 $lh->set_context('ansi');
1494 2 50       7 return if !$lh->context_is_ansi();
1495 2 50       10 return $empty ? '' : $cur;
1496             }
1497              
1498             sub set_context_plain {
1499 2     2 1 5 my ( $lh, $empty ) = @_;
1500 2         7 my $cur = $lh->get_context();
1501 2         7 $lh->set_context('plain');
1502 2 50       7 return if !$lh->context_is_plain();
1503 2 50       10 return $empty ? '' : $cur;
1504             }
1505              
1506             my %contexts = (
1507             'plain' => undef(),
1508             'ansi' => 1,
1509             'html' => 0,
1510             );
1511              
1512             sub set_context {
1513 25     25 1 1477 my ( $lh, $context, $empty ) = @_;
1514              
1515 25 100       110 if ( !$context ) {
    100          
1516 5         5551 require Web::Detect;
1517 5 50       4305 if ( Web::Detect::detect_web_fast() ) {
1518 0         0 $lh->{'-t-STDIN'} = 0;
1519             }
1520             else {
1521 5         5697 require IO::Interactive::Tiny;
1522 5 50       61 $lh->{'-t-STDIN'} = IO::Interactive::Tiny::is_interactive() ? 1 : undef();
1523             }
1524             }
1525             elsif ( exists $contexts{$context} ) {
1526 18         42 $lh->{'-t-STDIN'} = $contexts{$context};
1527             }
1528             else {
1529 2         22 require Carp;
1530 2         11 local $Carp::CarpLevel = 1;
1531 2         45 Carp::carp("Given context '$context' is unknown.");
1532 2         4348 $lh->{'-t-STDIN'} = $context;
1533             }
1534              
1535             return
1536 25 100 100     300 $empty ? ''
    100          
1537             : defined $context && exists $contexts{$context} ? $context
1538             : $lh->{'-t-STDIN'};
1539             }
1540              
1541             sub context_is_html {
1542 131     131 1 507 return $_[0]->get_context() eq 'html';
1543             }
1544              
1545             sub context_is_ansi {
1546 33     33 1 1727 return $_[0]->get_context() eq 'ansi';
1547             }
1548              
1549             sub context_is_plain {
1550 35     35 1 1721 return $_[0]->get_context() eq 'plain';
1551             }
1552              
1553             sub context_is {
1554 16     16 1 4818 return $_[0]->get_context() eq $_[1];
1555             }
1556              
1557             sub get_context {
1558 230     230 1 3715 my ($lh) = @_;
1559              
1560 230 100       1065 if ( !exists $lh->{'-t-STDIN'} ) {
1561 5         63 $lh->set_context();
1562             }
1563              
1564 230 100       686 return 'plain' if !defined $lh->{'-t-STDIN'};
1565 198 100       637 return 'ansi' if $lh->{'-t-STDIN'} eq "1";
1566 148 100       832 return 'html' if $lh->{'-t-STDIN'} eq "0";
1567              
1568             # We don't carp "Given context '...' is unknown." here since we assume if they explicitly set it then they have a good reason to.
1569             # If it was an accident the set_contex() will have carp()'d already, if they set the variable directly then they're doing it wrong ;)
1570 9         50 return $lh->{'-t-STDIN'};
1571             }
1572              
1573             sub maketext_html_context {
1574 1     1 1 4 my ( $lh, @mt_args ) = @_;
1575 1         4 my $cur = $lh->set_context_html();
1576 1         12 my $res = $lh->maketext(@mt_args);
1577 1         15 $lh->set_context($cur);
1578 1         6 return $res;
1579             }
1580              
1581             sub maketext_ansi_context {
1582 1     1 1 3 my ( $lh, @mt_args ) = @_;
1583 1         6 my $cur = $lh->set_context_ansi();
1584 1         8 my $res = $lh->maketext(@mt_args);
1585 1         8 $lh->set_context($cur);
1586 1         6 return $res;
1587             }
1588              
1589             sub maketext_plain_context {
1590 1     1 1 4 my ( $lh, @mt_args ) = @_;
1591 1         6 my $cur = $lh->set_context_plain();
1592 1         6 my $res = $lh->maketext(@mt_args);
1593 1         9 $lh->set_context($cur);
1594 1         6 return $res;
1595             }
1596              
1597             # TODO: how crazy do we want to go with context specific versions of maketext()ish methods?
1598             # *makevar_html_context = \&maketext_html_context;
1599             # *makevar_ansi_context = \&maketext_ansi_context;
1600             # *makeavr_plain_context = \&maketext_plain_context;
1601             #
1602             # sub makethis_html_context {};
1603             # sub makethis_ansi_context {};
1604             # sub makethis_plain_context {};
1605             #
1606             # sub makethis_base_html_context {};
1607             # sub makethis_base_ansi_context {};
1608             # sub makethis_base_plain_context {};
1609              
1610             #### / output context methods ###
1611              
1612             1;