Filename | /usr/share/perl5/vendor_perl/Locale/Maketext.pm |
Statements | Executed 35 statements in 8.18ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 4.43ms | 4.63ms | BEGIN@7 | Locale::Maketext::
1 | 1 | 1 | 1.99ms | 2.47ms | BEGIN@8 | Locale::Maketext::
1 | 1 | 1 | 32µs | 172µs | BEGIN@4 | Locale::Maketext::
1 | 1 | 1 | 31µs | 61µs | BEGIN@3 | Locale::Maketext::
1 | 1 | 1 | 29µs | 42µs | BEGIN@17 | Locale::Maketext::
1 | 1 | 1 | 28µs | 33µs | BEGIN@98 | Locale::Maketext::
1 | 1 | 1 | 19µs | 27µs | BEGIN@106 | Locale::Maketext::
1 | 1 | 1 | 19µs | 44µs | BEGIN@441 | Locale::Maketext::
1 | 1 | 1 | 19µs | 36µs | BEGIN@442 | Locale::Maketext::
1 | 1 | 1 | 18µs | 50µs | BEGIN@468 | Locale::Maketext::
1 | 1 | 1 | 18µs | 35µs | BEGIN@469 | Locale::Maketext::
1 | 1 | 1 | 11µs | 11µs | BEGIN@6 | Locale::Maketext::
1 | 1 | 1 | 6µs | 6µs | BEGIN@12 | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _add_supers | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _ambient_langprefs | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _compile | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _die_pointing | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _langtag_munging | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _lex_refs | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | _try_use | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | clear_isa_scan | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | encoding | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | fail_with | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | failure_handler_auto | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | fallback_language_classes | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | fallback_languages | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | get_handle | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | init | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | language_tag | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | maketext | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | new | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | numerate | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | numf | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | quant | Locale::Maketext::
0 | 0 | 0 | 0s | 0s | sprintf | Locale::Maketext::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | |||||
2 | package Locale::Maketext; | ||||
3 | 2 | 87µs | 2 | 90µs | # spent 61µs (31+29) within Locale::Maketext::BEGIN@3 which was called:
# once (31µs+29µs) by Foswiki::BEGIN@7 at line 3 # spent 61µs making 1 call to Locale::Maketext::BEGIN@3
# spent 29µs making 1 call to strict::import |
4 | 1 | 23µs | 1 | 139µs | # spent 172µs (32+139) within Locale::Maketext::BEGIN@4 which was called:
# once (32µs+139µs) by Foswiki::BEGIN@7 at line 5 # spent 139µs making 1 call to vars::import |
5 | 1 | 50µs | 1 | 172µs | $USE_LITERALS $MATCH_SUPERS_TIGHTLY); # spent 172µs making 1 call to Locale::Maketext::BEGIN@4 |
6 | 2 | 45µs | 1 | 11µs | # spent 11µs within Locale::Maketext::BEGIN@6 which was called:
# once (11µs+0s) by Foswiki::BEGIN@7 at line 6 # spent 11µs making 1 call to Locale::Maketext::BEGIN@6 |
7 | 2 | 247µs | 1 | 4.63ms | # spent 4.63ms (4.43+199µs) within Locale::Maketext::BEGIN@7 which was called:
# once (4.43ms+199µs) by Foswiki::BEGIN@7 at line 7 # spent 4.63ms making 1 call to Locale::Maketext::BEGIN@7 |
8 | 2 | 282µs | 1 | 2.47ms | # spent 2.47ms (1.99+474µs) within Locale::Maketext::BEGIN@8 which was called:
# once (1.99ms+474µs) by Foswiki::BEGIN@7 at line 8 # spent 2.47ms making 1 call to Locale::Maketext::BEGIN@8 |
9 | |||||
10 | #-------------------------------------------------------------------------- | ||||
11 | |||||
12 | 1 | 141µs | 1 | 6µs | # spent 6µs within Locale::Maketext::BEGIN@12 which was called:
# once (6µs+0s) by Foswiki::BEGIN@7 at line 12 # spent 6µs making 1 call to Locale::Maketext::BEGIN@12 |
13 | # define the constant 'DEBUG' at compile-time | ||||
14 | |||||
15 | # turn on utf8 if we have it (this is what GutsLoader.pm used to do essentially ) | ||||
16 | # use if (exists $INC{'utf8.pm'} || eval 'use utf8'), 'utf8'; | ||||
17 | # spent 42µs (29+13) within Locale::Maketext::BEGIN@17 which was called:
# once (29µs+13µs) by Foswiki::BEGIN@7 at line 27 | ||||
18 | |||||
19 | # if we have it || we can load it | ||||
20 | 1 | 8µs | if ( exists $INC{'utf8.pm'} || eval { local $SIG{'__DIE__'};require utf8; } ) { | ||
21 | 1 | 17µs | 1 | 13µs | utf8->import(); # spent 13µs making 1 call to utf8::import |
22 | 1 | 600ns | DEBUG and warn " utf8 on for _compile()\n"; | ||
23 | } | ||||
24 | else { | ||||
25 | DEBUG and warn " utf8 not available for _compile() ($INC{'utf8.pm'})\n$@\n"; | ||||
26 | } | ||||
27 | 1 | 634µs | 1 | 42µs | } # spent 42µs making 1 call to Locale::Maketext::BEGIN@17 |
28 | |||||
29 | |||||
30 | 1 | 1µs | $VERSION = '1.23'; | ||
31 | 1 | 9µs | @ISA = (); | ||
32 | |||||
33 | 1 | 500ns | $MATCH_SUPERS = 1; | ||
34 | 1 | 300ns | $MATCH_SUPERS_TIGHTLY = 1; | ||
35 | 1 | 200ns | $USING_LANGUAGE_TAGS = 1; | ||
36 | # Turning this off is somewhat of a security risk in that little or no | ||||
37 | # checking will be done on the legality of tokens passed to the | ||||
38 | # eval("use $module_name") in _try_use. If you turn this off, you have | ||||
39 | # to do your own taint checking. | ||||
40 | |||||
41 | 1 | 700ns | $USE_LITERALS = 1 unless defined $USE_LITERALS; | ||
42 | # a hint for compiling bracket-notation things. | ||||
43 | |||||
44 | 1 | 1µs | my %isa_scan = (); | ||
45 | |||||
46 | ########################################################################### | ||||
47 | |||||
48 | sub quant { | ||||
49 | my($handle, $num, @forms) = @_; | ||||
50 | |||||
51 | return $num if @forms == 0; # what should this mean? | ||||
52 | return $forms[2] if @forms > 2 and $num == 0; # special zeroth case | ||||
53 | |||||
54 | # Normal case: | ||||
55 | # Note that the formatting of $num is preserved. | ||||
56 | return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) ); | ||||
57 | # Most human languages put the number phrase before the qualified phrase. | ||||
58 | } | ||||
59 | |||||
60 | |||||
61 | sub numerate { | ||||
62 | # return this lexical item in a form appropriate to this number | ||||
63 | my($handle, $num, @forms) = @_; | ||||
64 | my $s = ($num == 1); | ||||
65 | |||||
66 | return '' unless @forms; | ||||
67 | if(@forms == 1) { # only the headword form specified | ||||
68 | return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack. | ||||
69 | } | ||||
70 | else { # sing and plural were specified | ||||
71 | return $s ? $forms[0] : $forms[1]; | ||||
72 | } | ||||
73 | } | ||||
74 | |||||
75 | #-------------------------------------------------------------------------- | ||||
76 | |||||
77 | sub numf { | ||||
78 | my($handle, $num) = @_[0,1]; | ||||
79 | if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) { | ||||
80 | $num += 0; # Just use normal integer stringification. | ||||
81 | # Specifically, don't let %G turn ten million into 1E+007 | ||||
82 | } | ||||
83 | else { | ||||
84 | $num = CORE::sprintf('%G', $num); | ||||
85 | # "CORE::" is there to avoid confusion with the above sub sprintf. | ||||
86 | } | ||||
87 | while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5 | ||||
88 | # The initial \d+ gobbles as many digits as it can, and then we | ||||
89 | # backtrack so it un-eats the rightmost three, and then we | ||||
90 | # insert the comma there. | ||||
91 | |||||
92 | $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'}; | ||||
93 | # This is just a lame hack instead of using Number::Format | ||||
94 | return $num; | ||||
95 | } | ||||
96 | |||||
97 | sub sprintf { | ||||
98 | 2 | 114µs | 2 | 38µs | # spent 33µs (28+5) within Locale::Maketext::BEGIN@98 which was called:
# once (28µs+5µs) by Foswiki::BEGIN@7 at line 98 # spent 33µs making 1 call to Locale::Maketext::BEGIN@98
# spent 5µs making 1 call to integer::unimport |
99 | my($handle, $format, @params) = @_; | ||||
100 | return CORE::sprintf($format, @params); | ||||
101 | # "CORE::" is there to avoid confusion with myself! | ||||
102 | } | ||||
103 | |||||
104 | #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# | ||||
105 | |||||
106 | 2 | 3.29ms | 2 | 34µs | # spent 27µs (19+8) within Locale::Maketext::BEGIN@106 which was called:
# once (19µs+8µs) by Foswiki::BEGIN@7 at line 106 # spent 27µs making 1 call to Locale::Maketext::BEGIN@106
# spent 8µs making 1 call to integer::import |
107 | |||||
108 | sub language_tag { | ||||
109 | my $it = ref($_[0]) || $_[0]; | ||||
110 | return undef unless $it =~ m/([^':]+)(?:::)?$/s; | ||||
111 | $it = lc($1); | ||||
112 | $it =~ tr<_><->; | ||||
113 | return $it; | ||||
114 | } | ||||
115 | |||||
116 | sub encoding { | ||||
117 | my $it = $_[0]; | ||||
118 | return( | ||||
119 | (ref($it) && $it->{'encoding'}) | ||||
120 | || 'iso-8859-1' # Latin-1 | ||||
121 | ); | ||||
122 | } | ||||
123 | |||||
124 | #-------------------------------------------------------------------------- | ||||
125 | |||||
126 | sub fallback_languages { return('i-default', 'en', 'en-US') } | ||||
127 | |||||
128 | sub fallback_language_classes { return () } | ||||
129 | |||||
130 | #-------------------------------------------------------------------------- | ||||
131 | |||||
132 | sub fail_with { # an actual attribute method! | ||||
133 | my($handle, @params) = @_; | ||||
134 | return unless ref($handle); | ||||
135 | $handle->{'fail'} = $params[0] if @params; | ||||
136 | return $handle->{'fail'}; | ||||
137 | } | ||||
138 | |||||
139 | #-------------------------------------------------------------------------- | ||||
140 | |||||
141 | sub failure_handler_auto { | ||||
142 | # Meant to be used like: | ||||
143 | # $handle->fail_with('failure_handler_auto') | ||||
144 | |||||
145 | my $handle = shift; | ||||
146 | my $phrase = shift; | ||||
147 | |||||
148 | $handle->{'failure_lex'} ||= {}; | ||||
149 | my $lex = $handle->{'failure_lex'}; | ||||
150 | |||||
151 | my $value ||= ($lex->{$phrase} ||= $handle->_compile($phrase)); | ||||
152 | |||||
153 | # Dumbly copied from sub maketext: | ||||
154 | return ${$value} if ref($value) eq 'SCALAR'; | ||||
155 | return $value if ref($value) ne 'CODE'; | ||||
156 | { | ||||
157 | local $SIG{'__DIE__'}; | ||||
158 | eval { $value = &$value($handle, @_) }; | ||||
159 | } | ||||
160 | # If we make it here, there was an exception thrown in the | ||||
161 | # call to $value, and so scream: | ||||
162 | if($@) { | ||||
163 | # pretty up the error message | ||||
164 | $@ =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} | ||||
165 | {\n in bracket code [compiled line $1],}s; | ||||
166 | #$err =~ s/\n?$/\n/s; | ||||
167 | Carp::croak "Error in maketexting \"$phrase\":\n$@ as used"; | ||||
168 | # Rather unexpected, but suppose that the sub tried calling | ||||
169 | # a method that didn't exist. | ||||
170 | } | ||||
171 | else { | ||||
172 | return $value; | ||||
173 | } | ||||
174 | } | ||||
175 | |||||
176 | #========================================================================== | ||||
177 | |||||
178 | sub new { | ||||
179 | # Nothing fancy! | ||||
180 | my $class = ref($_[0]) || $_[0]; | ||||
181 | my $handle = bless {}, $class; | ||||
182 | $handle->init; | ||||
183 | return $handle; | ||||
184 | } | ||||
185 | |||||
186 | sub init { return } # no-op | ||||
187 | |||||
188 | ########################################################################### | ||||
189 | |||||
190 | sub maketext { | ||||
191 | # Remember, this can fail. Failure is controllable many ways. | ||||
192 | Carp::croak 'maketext requires at least one parameter' unless @_ > 1; | ||||
193 | |||||
194 | my($handle, $phrase) = splice(@_,0,2); | ||||
195 | Carp::confess('No handle/phrase') unless (defined($handle) && defined($phrase)); | ||||
196 | |||||
197 | # backup $@ in case it it's still being used in the calling code. | ||||
198 | # If no failures, we'll re-set it back to what it was later. | ||||
199 | my $at = $@; | ||||
200 | |||||
201 | # Copy @_ case one of its elements is $@. | ||||
202 | @_ = @_; | ||||
203 | |||||
204 | # Look up the value: | ||||
205 | |||||
206 | my $value; | ||||
207 | if (exists $handle->{'_external_lex_cache'}{$phrase}) { | ||||
208 | DEBUG and warn "* Using external lex cache version of \"$phrase\"\n"; | ||||
209 | $value = $handle->{'_external_lex_cache'}{$phrase}; | ||||
210 | } | ||||
211 | else { | ||||
212 | foreach my $h_r ( | ||||
213 | @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs } | ||||
214 | ) { | ||||
215 | DEBUG and warn "* Looking up \"$phrase\" in $h_r\n"; | ||||
216 | if(exists $h_r->{$phrase}) { | ||||
217 | DEBUG and warn " Found \"$phrase\" in $h_r\n"; | ||||
218 | unless(ref($value = $h_r->{$phrase})) { | ||||
219 | # Nonref means it's not yet compiled. Compile and replace. | ||||
220 | if ($handle->{'use_external_lex_cache'}) { | ||||
221 | $value = $handle->{'_external_lex_cache'}{$phrase} = $handle->_compile($value); | ||||
222 | } | ||||
223 | else { | ||||
224 | $value = $h_r->{$phrase} = $handle->_compile($value); | ||||
225 | } | ||||
226 | } | ||||
227 | last; | ||||
228 | } | ||||
229 | # extending packages need to be able to localize _AUTO and if readonly can't "local $h_r->{'_AUTO'} = 1;" | ||||
230 | # but they can "local $handle->{'_external_lex_cache'}{'_AUTO'} = 1;" | ||||
231 | elsif($phrase !~ m/^_/s and ($handle->{'use_external_lex_cache'} ? ( exists $handle->{'_external_lex_cache'}{'_AUTO'} ? $handle->{'_external_lex_cache'}{'_AUTO'} : $h_r->{'_AUTO'} ) : $h_r->{'_AUTO'})) { | ||||
232 | # it's an auto lex, and this is an autoable key! | ||||
233 | DEBUG and warn " Automaking \"$phrase\" into $h_r\n"; | ||||
234 | if ($handle->{'use_external_lex_cache'}) { | ||||
235 | $value = $handle->{'_external_lex_cache'}{$phrase} = $handle->_compile($phrase); | ||||
236 | } | ||||
237 | else { | ||||
238 | $value = $h_r->{$phrase} = $handle->_compile($phrase); | ||||
239 | } | ||||
240 | last; | ||||
241 | } | ||||
242 | DEBUG>1 and print " Not found in $h_r, nor automakable\n"; | ||||
243 | # else keep looking | ||||
244 | } | ||||
245 | } | ||||
246 | |||||
247 | unless(defined($value)) { | ||||
248 | DEBUG and warn "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, " fails.\n"; | ||||
249 | if(ref($handle) and $handle->{'fail'}) { | ||||
250 | DEBUG and warn "WARNING0: maketext fails looking for <$phrase>\n"; | ||||
251 | my $fail; | ||||
252 | if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference | ||||
253 | $@ = $at; # Put $@ back in case we altered it along the way. | ||||
254 | return &{$fail}($handle, $phrase, @_); | ||||
255 | # If it ever returns, it should return a good value. | ||||
256 | } | ||||
257 | else { # It's a method name | ||||
258 | $@ = $at; # Put $@ back in case we altered it along the way. | ||||
259 | return $handle->$fail($phrase, @_); | ||||
260 | # If it ever returns, it should return a good value. | ||||
261 | } | ||||
262 | } | ||||
263 | else { | ||||
264 | # All we know how to do is this; | ||||
265 | Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed"); | ||||
266 | } | ||||
267 | } | ||||
268 | |||||
269 | if(ref($value) eq 'SCALAR'){ | ||||
270 | $@ = $at; # Put $@ back in case we altered it along the way. | ||||
271 | return $$value ; | ||||
272 | } | ||||
273 | if(ref($value) ne 'CODE'){ | ||||
274 | $@ = $at; # Put $@ back in case we altered it along the way. | ||||
275 | return $value ; | ||||
276 | } | ||||
277 | |||||
278 | { | ||||
279 | local $SIG{'__DIE__'}; | ||||
280 | eval { $value = &$value($handle, @_) }; | ||||
281 | } | ||||
282 | # If we make it here, there was an exception thrown in the | ||||
283 | # call to $value, and so scream: | ||||
284 | if ($@) { | ||||
285 | # pretty up the error message | ||||
286 | $@ =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} | ||||
287 | {\n in bracket code [compiled line $1],}s; | ||||
288 | #$err =~ s/\n?$/\n/s; | ||||
289 | Carp::croak "Error in maketexting \"$phrase\":\n$@ as used"; | ||||
290 | # Rather unexpected, but suppose that the sub tried calling | ||||
291 | # a method that didn't exist. | ||||
292 | } | ||||
293 | else { | ||||
294 | $@ = $at; # Put $@ back in case we altered it along the way. | ||||
295 | return $value; | ||||
296 | } | ||||
297 | $@ = $at; # Put $@ back in case we altered it along the way. | ||||
298 | } | ||||
299 | |||||
300 | ########################################################################### | ||||
301 | |||||
302 | sub get_handle { # This is a constructor and, yes, it CAN FAIL. | ||||
303 | # Its class argument has to be the base class for the current | ||||
304 | # application's l10n files. | ||||
305 | |||||
306 | my($base_class, @languages) = @_; | ||||
307 | $base_class = ref($base_class) || $base_class; | ||||
308 | # Complain if they use __PACKAGE__ as a project base class? | ||||
309 | |||||
310 | if( @languages ) { | ||||
311 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
312 | if($USING_LANGUAGE_TAGS) { # An explicit language-list was given! | ||||
313 | @languages = | ||||
314 | map {; $_, I18N::LangTags::alternate_language_tags($_) } | ||||
315 | # Catch alternation | ||||
316 | map I18N::LangTags::locale2language_tag($_), | ||||
317 | # If it's a lg tag, fine, pass thru (untainted) | ||||
318 | # If it's a locale ID, try converting to a lg tag (untainted), | ||||
319 | # otherwise nix it. | ||||
320 | @languages; | ||||
321 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
322 | } | ||||
323 | } | ||||
324 | else { | ||||
325 | @languages = $base_class->_ambient_langprefs; | ||||
326 | } | ||||
327 | |||||
328 | @languages = $base_class->_langtag_munging(@languages); | ||||
329 | |||||
330 | my %seen; | ||||
331 | foreach my $module_name ( map { $base_class . '::' . $_ } @languages ) { | ||||
332 | next unless length $module_name; # sanity | ||||
333 | next if $seen{$module_name}++ # Already been here, and it was no-go | ||||
334 | || !&_try_use($module_name); # Try to use() it, but can't it. | ||||
335 | return($module_name->new); # Make it! | ||||
336 | } | ||||
337 | |||||
338 | return undef; # Fail! | ||||
339 | } | ||||
340 | |||||
341 | ########################################################################### | ||||
342 | |||||
343 | sub _langtag_munging { | ||||
344 | my($base_class, @languages) = @_; | ||||
345 | |||||
346 | # We have all these DEBUG statements because otherwise it's hard as hell | ||||
347 | # to diagnose ifwhen something goes wrong. | ||||
348 | |||||
349 | DEBUG and warn 'Lgs1: ', map("<$_>", @languages), "\n"; | ||||
350 | |||||
351 | if($USING_LANGUAGE_TAGS) { | ||||
352 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
353 | @languages = $base_class->_add_supers( @languages ); | ||||
354 | |||||
355 | push @languages, I18N::LangTags::panic_languages(@languages); | ||||
356 | DEBUG and warn "After adding panic languages:\n", | ||||
357 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
358 | |||||
359 | push @languages, $base_class->fallback_languages; | ||||
360 | # You are free to override fallback_languages to return empty-list! | ||||
361 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
362 | |||||
363 | @languages = # final bit of processing to turn them into classname things | ||||
364 | map { | ||||
365 | my $it = $_; # copy | ||||
366 | $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _ | ||||
367 | $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_ | ||||
368 | $it; | ||||
369 | } @languages | ||||
370 | ; | ||||
371 | DEBUG and warn "Nearing end of munging:\n", | ||||
372 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
373 | } | ||||
374 | else { | ||||
375 | DEBUG and warn "Bypassing language-tags.\n", | ||||
376 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
377 | } | ||||
378 | |||||
379 | DEBUG and warn "Before adding fallback classes:\n", | ||||
380 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
381 | |||||
382 | push @languages, $base_class->fallback_language_classes; | ||||
383 | # You are free to override that to return whatever. | ||||
384 | |||||
385 | DEBUG and warn "Finally:\n", | ||||
386 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
387 | |||||
388 | return @languages; | ||||
389 | } | ||||
390 | |||||
391 | ########################################################################### | ||||
392 | |||||
393 | sub _ambient_langprefs { | ||||
394 | return I18N::LangTags::Detect::detect(); | ||||
395 | } | ||||
396 | |||||
397 | ########################################################################### | ||||
398 | |||||
399 | sub _add_supers { | ||||
400 | my($base_class, @languages) = @_; | ||||
401 | |||||
402 | if (!$MATCH_SUPERS) { | ||||
403 | # Nothing | ||||
404 | DEBUG and warn "Bypassing any super-matching.\n", | ||||
405 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
406 | |||||
407 | } | ||||
408 | elsif( $MATCH_SUPERS_TIGHTLY ) { | ||||
409 | DEBUG and warn "Before adding new supers tightly:\n", | ||||
410 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
411 | @languages = I18N::LangTags::implicate_supers( @languages ); | ||||
412 | DEBUG and warn "After adding new supers tightly:\n", | ||||
413 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
414 | |||||
415 | } | ||||
416 | else { | ||||
417 | DEBUG and warn "Before adding supers to end:\n", | ||||
418 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
419 | @languages = I18N::LangTags::implicate_supers_strictly( @languages ); | ||||
420 | DEBUG and warn "After adding supers to end:\n", | ||||
421 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; | ||||
422 | } | ||||
423 | |||||
424 | return @languages; | ||||
425 | } | ||||
426 | |||||
427 | ########################################################################### | ||||
428 | # | ||||
429 | # This is where most people should stop reading. | ||||
430 | # | ||||
431 | ########################################################################### | ||||
432 | |||||
433 | 1 | 500ns | my %tried = (); | ||
434 | # memoization of whether we've used this module, or found it unusable. | ||||
435 | |||||
436 | sub _try_use { # Basically a wrapper around "require Modulename" | ||||
437 | # "Many men have tried..." "They tried and failed?" "They tried and died." | ||||
438 | return $tried{$_[0]} if exists $tried{$_[0]}; # memoization | ||||
439 | |||||
440 | my $module = $_[0]; # ASSUME sane module name! | ||||
441 | 2 | 62µs | 2 | 68µs | # spent 44µs (19+25) within Locale::Maketext::BEGIN@441 which was called:
# once (19µs+25µs) by Foswiki::BEGIN@7 at line 441 # spent 44µs making 1 call to Locale::Maketext::BEGIN@441
# spent 25µs making 1 call to strict::unimport |
442 | 2 | 276µs | 2 | 54µs | # spent 36µs (19+18) within Locale::Maketext::BEGIN@442 which was called:
# once (19µs+18µs) by Foswiki::BEGIN@7 at line 442 # spent 36µs making 1 call to Locale::Maketext::BEGIN@442
# spent 18µs making 1 call to warnings::unimport |
443 | return($tried{$module} = 1) | ||||
444 | if %{$module . '::Lexicon'} or @{$module . '::ISA'}; | ||||
445 | # weird case: we never use'd it, but there it is! | ||||
446 | } | ||||
447 | |||||
448 | DEBUG and warn " About to use $module ...\n"; | ||||
449 | |||||
450 | local $SIG{'__DIE__'}; | ||||
451 | local $@; | ||||
452 | eval "require $module"; # used to be "use $module", but no point in that. | ||||
453 | |||||
454 | if($@) { | ||||
455 | DEBUG and warn "Error using $module \: $@\n"; | ||||
456 | return $tried{$module} = 0; | ||||
457 | } | ||||
458 | else { | ||||
459 | DEBUG and warn " OK, $module is used\n"; | ||||
460 | return $tried{$module} = 1; | ||||
461 | } | ||||
462 | } | ||||
463 | |||||
464 | #-------------------------------------------------------------------------- | ||||
465 | |||||
466 | sub _lex_refs { # report the lexicon references for this handle's class | ||||
467 | # returns an arrayREF! | ||||
468 | 2 | 59µs | 2 | 82µs | # spent 50µs (18+32) within Locale::Maketext::BEGIN@468 which was called:
# once (18µs+32µs) by Foswiki::BEGIN@7 at line 468 # spent 50µs making 1 call to Locale::Maketext::BEGIN@468
# spent 32µs making 1 call to strict::unimport |
469 | 2 | 2.82ms | 2 | 52µs | # spent 35µs (18+17) within Locale::Maketext::BEGIN@469 which was called:
# once (18µs+17µs) by Foswiki::BEGIN@7 at line 469 # spent 35µs making 1 call to Locale::Maketext::BEGIN@469
# spent 17µs making 1 call to warnings::unimport |
470 | my $class = ref($_[0]) || $_[0]; | ||||
471 | DEBUG and warn "Lex refs lookup on $class\n"; | ||||
472 | return $isa_scan{$class} if exists $isa_scan{$class}; # memoization! | ||||
473 | |||||
474 | my @lex_refs; | ||||
475 | my $seen_r = ref($_[1]) ? $_[1] : {}; | ||||
476 | |||||
477 | if( defined( *{$class . '::Lexicon'}{'HASH'} )) { | ||||
478 | push @lex_refs, *{$class . '::Lexicon'}{'HASH'}; | ||||
479 | DEBUG and warn '%' . $class . '::Lexicon contains ', | ||||
480 | scalar(keys %{$class . '::Lexicon'}), " entries\n"; | ||||
481 | } | ||||
482 | |||||
483 | # Implements depth(height?)-first recursive searching of superclasses. | ||||
484 | # In hindsight, I suppose I could have just used Class::ISA! | ||||
485 | foreach my $superclass (@{$class . '::ISA'}) { | ||||
486 | DEBUG and warn " Super-class search into $superclass\n"; | ||||
487 | next if $seen_r->{$superclass}++; | ||||
488 | push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself | ||||
489 | } | ||||
490 | |||||
491 | $isa_scan{$class} = \@lex_refs; # save for next time | ||||
492 | return \@lex_refs; | ||||
493 | } | ||||
494 | |||||
495 | sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity! | ||||
496 | |||||
497 | #-------------------------------------------------------------------------- | ||||
498 | |||||
499 | sub _compile { | ||||
500 | # This big scary routine compiles an entry. | ||||
501 | # It returns either a coderef if there's brackety bits in this, or | ||||
502 | # otherwise a ref to a scalar. | ||||
503 | |||||
504 | my $string_to_compile = $_[1]; # There are taint issues using regex on @_ - perlbug 60378,27344 | ||||
505 | |||||
506 | # The while() regex is more expensive than this check on strings that don't need a compile. | ||||
507 | # this op causes a ~2% speed hit for strings that need compile and a 250% speed improvement | ||||
508 | # on strings that don't need compiling. | ||||
509 | return \"$string_to_compile" if($string_to_compile !~ m/[\[~\]]/ms); # return a string ref if chars [~] are not in the string | ||||
510 | |||||
511 | my $target = ref($_[0]) || $_[0]; | ||||
512 | |||||
513 | my(@code); | ||||
514 | my(@c) = (''); # "chunks" -- scratch. | ||||
515 | my $call_count = 0; | ||||
516 | my $big_pile = ''; | ||||
517 | { | ||||
518 | my $in_group = 0; # start out outside a group | ||||
519 | my($m, @params); # scratch | ||||
520 | |||||
521 | while($string_to_compile =~ # Iterate over chunks. | ||||
522 | m/( | ||||
523 | [^\~\[\]]+ # non-~[] stuff (Capture everything else here) | ||||
524 | | | ||||
525 | ~. # ~[, ~], ~~, ~other | ||||
526 | | | ||||
527 | \[ # [ presumably opening a group | ||||
528 | | | ||||
529 | \] # ] presumably closing a group | ||||
530 | | | ||||
531 | ~ # terminal ~ ? | ||||
532 | | | ||||
533 | $ | ||||
534 | )/xgs | ||||
535 | ) { | ||||
536 | DEBUG>2 and warn qq{ "$1"\n}; | ||||
537 | |||||
538 | if($1 eq '[' or $1 eq '') { # "[" or end | ||||
539 | # Whether this is "[" or end, force processing of any | ||||
540 | # preceding literal. | ||||
541 | if($in_group) { | ||||
542 | if($1 eq '') { | ||||
543 | $target->_die_pointing($string_to_compile, 'Unterminated bracket group'); | ||||
544 | } | ||||
545 | else { | ||||
546 | $target->_die_pointing($string_to_compile, 'You can\'t nest bracket groups'); | ||||
547 | } | ||||
548 | } | ||||
549 | else { | ||||
550 | if ($1 eq '') { | ||||
551 | DEBUG>2 and warn " [end-string]\n"; | ||||
552 | } | ||||
553 | else { | ||||
554 | $in_group = 1; | ||||
555 | } | ||||
556 | die "How come \@c is empty?? in <$string_to_compile>" unless @c; # sanity | ||||
557 | if(length $c[-1]) { | ||||
558 | # Now actually processing the preceding literal | ||||
559 | $big_pile .= $c[-1]; | ||||
560 | if($USE_LITERALS and ( | ||||
561 | (ord('A') == 65) | ||||
562 | ? $c[-1] !~ m/[^\x20-\x7E]/s | ||||
563 | # ASCII very safe chars | ||||
564 | : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s | ||||
565 | # EBCDIC very safe chars | ||||
566 | )) { | ||||
567 | # normal case -- all very safe chars | ||||
568 | $c[-1] =~ s/'/\\'/g; | ||||
569 | push @code, q{ '} . $c[-1] . "',\n"; | ||||
570 | $c[-1] = ''; # reuse this slot | ||||
571 | } | ||||
572 | else { | ||||
573 | $c[-1] =~ s/\\\\/\\/g; | ||||
574 | push @code, ' $c[' . $#c . "],\n"; | ||||
575 | push @c, ''; # new chunk | ||||
576 | } | ||||
577 | } | ||||
578 | # else just ignore the empty string. | ||||
579 | } | ||||
580 | |||||
581 | } | ||||
582 | elsif($1 eq ']') { # "]" | ||||
583 | # close group -- go back in-band | ||||
584 | if($in_group) { | ||||
585 | $in_group = 0; | ||||
586 | |||||
587 | DEBUG>2 and warn " --Closing group [$c[-1]]\n"; | ||||
588 | |||||
589 | # And now process the group... | ||||
590 | |||||
591 | if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) { | ||||
592 | DEBUG>2 and warn " -- (Ignoring)\n"; | ||||
593 | $c[-1] = ''; # reset out chink | ||||
594 | next; | ||||
595 | } | ||||
596 | |||||
597 | #$c[-1] =~ s/^\s+//s; | ||||
598 | #$c[-1] =~ s/\s+$//s; | ||||
599 | ($m,@params) = split(/,/, $c[-1], -1); # was /\s*,\s*/ | ||||
600 | |||||
601 | # A bit of a hack -- we've turned "~,"'s into DELs, so turn | ||||
602 | # 'em into real commas here. | ||||
603 | if (ord('A') == 65) { # ASCII, etc | ||||
604 | foreach($m, @params) { tr/\x7F/,/ } | ||||
605 | } | ||||
606 | else { # EBCDIC (1047, 0037, POSIX-BC) | ||||
607 | # Thanks to Peter Prymmer for the EBCDIC handling | ||||
608 | foreach($m, @params) { tr/\x07/,/ } | ||||
609 | } | ||||
610 | |||||
611 | # Special-case handling of some method names: | ||||
612 | if($m eq '_*' or $m =~ m/^_(-?\d+)$/s) { | ||||
613 | # Treat [_1,...] as [,_1,...], etc. | ||||
614 | unshift @params, $m; | ||||
615 | $m = ''; | ||||
616 | } | ||||
617 | elsif($m eq '*') { | ||||
618 | $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars" | ||||
619 | } | ||||
620 | elsif($m eq '#') { | ||||
621 | $m = 'numf'; # "#" for "number": [#,_1] for "the number _1" | ||||
622 | } | ||||
623 | |||||
624 | # Most common case: a simple, legal-looking method name | ||||
625 | if($m eq '') { | ||||
626 | # 0-length method name means to just interpolate: | ||||
627 | push @code, ' ('; | ||||
628 | } | ||||
629 | elsif($m =~ /^\w+$/s | ||||
630 | # exclude anything fancy, especially fully-qualified module names | ||||
631 | ) { | ||||
632 | push @code, ' $_[0]->' . $m . '('; | ||||
633 | } | ||||
634 | else { | ||||
635 | # TODO: implement something? or just too icky to consider? | ||||
636 | $target->_die_pointing( | ||||
637 | $string_to_compile, | ||||
638 | "Can't use \"$m\" as a method name in bracket group", | ||||
639 | 2 + length($c[-1]) | ||||
640 | ); | ||||
641 | } | ||||
642 | |||||
643 | pop @c; # we don't need that chunk anymore | ||||
644 | ++$call_count; | ||||
645 | |||||
646 | foreach my $p (@params) { | ||||
647 | if($p eq '_*') { | ||||
648 | # Meaning: all parameters except $_[0] | ||||
649 | $code[-1] .= ' @_[1 .. $#_], '; | ||||
650 | # and yes, that does the right thing for all @_ < 3 | ||||
651 | } | ||||
652 | elsif($p =~ m/^_(-?\d+)$/s) { | ||||
653 | # _3 meaning $_[3] | ||||
654 | $code[-1] .= '$_[' . (0 + $1) . '], '; | ||||
655 | } | ||||
656 | elsif($USE_LITERALS and ( | ||||
657 | (ord('A') == 65) | ||||
658 | ? $p !~ m/[^\x20-\x7E]/s | ||||
659 | # ASCII very safe chars | ||||
660 | : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s | ||||
661 | # EBCDIC very safe chars | ||||
662 | )) { | ||||
663 | # Normal case: a literal containing only safe characters | ||||
664 | $p =~ s/'/\\'/g; | ||||
665 | $code[-1] .= q{'} . $p . q{', }; | ||||
666 | } | ||||
667 | else { | ||||
668 | # Stow it on the chunk-stack, and just refer to that. | ||||
669 | push @c, $p; | ||||
670 | push @code, ' $c[' . $#c . '], '; | ||||
671 | } | ||||
672 | } | ||||
673 | $code[-1] .= "),\n"; | ||||
674 | |||||
675 | push @c, ''; | ||||
676 | } | ||||
677 | else { | ||||
678 | $target->_die_pointing($string_to_compile, q{Unbalanced ']'}); | ||||
679 | } | ||||
680 | |||||
681 | } | ||||
682 | elsif(substr($1,0,1) ne '~') { | ||||
683 | # it's stuff not containing "~" or "[" or "]" | ||||
684 | # i.e., a literal blob | ||||
685 | my $text = $1; | ||||
686 | $text =~ s/\\/\\\\/g; | ||||
687 | $c[-1] .= $text; | ||||
688 | |||||
689 | } | ||||
690 | elsif($1 eq '~~') { # "~~" | ||||
691 | $c[-1] .= '~'; | ||||
692 | |||||
693 | } | ||||
694 | elsif($1 eq '~[') { # "~[" | ||||
695 | $c[-1] .= '['; | ||||
696 | |||||
697 | } | ||||
698 | elsif($1 eq '~]') { # "~]" | ||||
699 | $c[-1] .= ']'; | ||||
700 | |||||
701 | } | ||||
702 | elsif($1 eq '~,') { # "~," | ||||
703 | if($in_group) { | ||||
704 | # This is a hack, based on the assumption that no-one will actually | ||||
705 | # want a DEL inside a bracket group. Let's hope that's it's true. | ||||
706 | if (ord('A') == 65) { # ASCII etc | ||||
707 | $c[-1] .= "\x7F"; | ||||
708 | } | ||||
709 | else { # EBCDIC (cp 1047, 0037, POSIX-BC) | ||||
710 | $c[-1] .= "\x07"; | ||||
711 | } | ||||
712 | } | ||||
713 | else { | ||||
714 | $c[-1] .= '~,'; | ||||
715 | } | ||||
716 | |||||
717 | } | ||||
718 | elsif($1 eq '~') { # possible only at string-end, it seems. | ||||
719 | $c[-1] .= '~'; | ||||
720 | |||||
721 | } | ||||
722 | else { | ||||
723 | # It's a "~X" where X is not a special character. | ||||
724 | # Consider it a literal ~ and X. | ||||
725 | my $text = $1; | ||||
726 | $text =~ s/\\/\\\\/g; | ||||
727 | $c[-1] .= $text; | ||||
728 | } | ||||
729 | } | ||||
730 | } | ||||
731 | |||||
732 | if($call_count) { | ||||
733 | undef $big_pile; # Well, nevermind that. | ||||
734 | } | ||||
735 | else { | ||||
736 | # It's all literals! Ahwell, that can happen. | ||||
737 | # So don't bother with the eval. Return a SCALAR reference. | ||||
738 | return \$big_pile; | ||||
739 | } | ||||
740 | |||||
741 | die q{Last chunk isn't null??} if @c and length $c[-1]; # sanity | ||||
742 | DEBUG and warn scalar(@c), " chunks under closure\n"; | ||||
743 | if(@code == 0) { # not possible? | ||||
744 | DEBUG and warn "Empty code\n"; | ||||
745 | return \''; | ||||
746 | } | ||||
747 | elsif(@code > 1) { # most cases, presumably! | ||||
748 | unshift @code, "join '',\n"; | ||||
749 | } | ||||
750 | unshift @code, "use strict; sub {\n"; | ||||
751 | push @code, "}\n"; | ||||
752 | |||||
753 | DEBUG and warn @code; | ||||
754 | my $sub = eval(join '', @code); | ||||
755 | die "$@ while evalling" . join('', @code) if $@; # Should be impossible. | ||||
756 | return $sub; | ||||
757 | } | ||||
758 | |||||
759 | #-------------------------------------------------------------------------- | ||||
760 | |||||
761 | sub _die_pointing { | ||||
762 | # This is used by _compile to throw a fatal error | ||||
763 | my $target = shift; # class name | ||||
764 | # ...leaving $_[0] the error-causing text, and $_[1] the error message | ||||
765 | |||||
766 | my $i = index($_[0], "\n"); | ||||
767 | |||||
768 | my $pointy; | ||||
769 | my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1; | ||||
770 | if($pos < 1) { | ||||
771 | $pointy = "^=== near there\n"; | ||||
772 | } | ||||
773 | else { # we need to space over | ||||
774 | my $first_tab = index($_[0], "\t"); | ||||
775 | if($pos > 2 and ( -1 == $first_tab or $first_tab > pos($_[0]))) { | ||||
776 | # No tabs, or the first tab is harmlessly after where we will point to, | ||||
777 | # AND we're far enough from the margin that we can draw a proper arrow. | ||||
778 | $pointy = ('=' x $pos) . "^ near there\n"; | ||||
779 | } | ||||
780 | else { | ||||
781 | # tabs screw everything up! | ||||
782 | $pointy = substr($_[0],0,$pos); | ||||
783 | $pointy =~ tr/\t //cd; | ||||
784 | # make everything into whitespace, but preserving tabs | ||||
785 | $pointy .= "^=== near there\n"; | ||||
786 | } | ||||
787 | } | ||||
788 | |||||
789 | my $errmsg = "$_[1], in\:\n$_[0]"; | ||||
790 | |||||
791 | if($i == -1) { | ||||
792 | # No newline. | ||||
793 | $errmsg .= "\n" . $pointy; | ||||
794 | } | ||||
795 | elsif($i == (length($_[0]) - 1) ) { | ||||
796 | # Already has a newline at end. | ||||
797 | $errmsg .= $pointy; | ||||
798 | } | ||||
799 | else { | ||||
800 | # don't bother with the pointy bit, I guess. | ||||
801 | } | ||||
802 | Carp::croak( "$errmsg via $target, as used" ); | ||||
803 | } | ||||
804 | |||||
805 | 1 | 11µs | 1; |