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{}; |
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; |