File Coverage

lib/Locale/Maketext/Utils.pm
Criterion Covered Total %
statement 607 732 82.9
branch 296 448 66.0
condition 84 165 50.9
subroutine 99 113 87.6
pod 61 89 68.5
total 1147 1547 74.1


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