Commit | Line | Data |
9378c581 |
1 | package Locale::Maketext; |
2 | use strict; |
3 | use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS |
f666394a |
4 | $USE_LITERALS $MATCH_SUPERS_TIGHTLY); |
9378c581 |
5 | use Carp (); |
1189c245 |
6 | use I18N::LangTags 0.30 (); |
9378c581 |
7 | |
8 | #-------------------------------------------------------------------------- |
9 | |
10 | BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } } |
f666394a |
11 | # define the constant 'DEBUG' at compile-time |
9378c581 |
12 | |
ad56049d |
13 | $VERSION = '1.13'; |
9378c581 |
14 | @ISA = (); |
15 | |
16 | $MATCH_SUPERS = 1; |
14be35aa |
17 | $MATCH_SUPERS_TIGHTLY = 1; |
18 | $USING_LANGUAGE_TAGS = 1; |
f666394a |
19 | # Turning this off is somewhat of a security risk in that little or no |
20 | # checking will be done on the legality of tokens passed to the |
21 | # eval("use $module_name") in _try_use. If you turn this off, you have |
22 | # to do your own taint checking. |
9378c581 |
23 | |
24 | $USE_LITERALS = 1 unless defined $USE_LITERALS; |
f666394a |
25 | # a hint for compiling bracket-notation things. |
9378c581 |
26 | |
27 | my %isa_scan = (); |
28 | |
29 | ########################################################################### |
30 | |
31 | sub quant { |
f666394a |
32 | my($handle, $num, @forms) = @_; |
9378c581 |
33 | |
f666394a |
34 | return $num if @forms == 0; # what should this mean? |
35 | return $forms[2] if @forms > 2 and $num == 0; # special zeroth case |
9378c581 |
36 | |
f666394a |
37 | # Normal case: |
38 | # Note that the formatting of $num is preserved. |
39 | return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) ); |
40 | # Most human languages put the number phrase before the qualified phrase. |
9378c581 |
41 | } |
42 | |
43 | |
44 | sub numerate { |
f666394a |
45 | # return this lexical item in a form appropriate to this number |
46 | my($handle, $num, @forms) = @_; |
47 | my $s = ($num == 1); |
48 | |
49 | return '' unless @forms; |
50 | if(@forms == 1) { # only the headword form specified |
51 | return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack. |
52 | } |
53 | else { # sing and plural were specified |
54 | return $s ? $forms[0] : $forms[1]; |
55 | } |
9378c581 |
56 | } |
57 | |
58 | #-------------------------------------------------------------------------- |
59 | |
60 | sub numf { |
f666394a |
61 | my($handle, $num) = @_[0,1]; |
62 | if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) { |
63 | $num += 0; # Just use normal integer stringification. |
64 | # Specifically, don't let %G turn ten million into 1E+007 |
65 | } |
66 | else { |
67 | $num = CORE::sprintf('%G', $num); |
68 | # "CORE::" is there to avoid confusion with the above sub sprintf. |
69 | } |
70 | while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5 |
71 | # The initial \d+ gobbles as many digits as it can, and then we |
72 | # backtrack so it un-eats the rightmost three, and then we |
73 | # insert the comma there. |
74 | |
75 | $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'}; |
76 | # This is just a lame hack instead of using Number::Format |
77 | return $num; |
9378c581 |
78 | } |
79 | |
80 | sub sprintf { |
f666394a |
81 | no integer; |
82 | my($handle, $format, @params) = @_; |
83 | return CORE::sprintf($format, @params); |
9378c581 |
84 | # "CORE::" is there to avoid confusion with myself! |
85 | } |
86 | |
87 | #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=# |
88 | |
89 | use integer; # vroom vroom... applies to the whole rest of the module |
90 | |
91 | sub language_tag { |
f666394a |
92 | my $it = ref($_[0]) || $_[0]; |
93 | return undef unless $it =~ m/([^':]+)(?:::)?$/s; |
94 | $it = lc($1); |
95 | $it =~ tr<_><->; |
96 | return $it; |
9378c581 |
97 | } |
98 | |
99 | sub encoding { |
f666394a |
100 | my $it = $_[0]; |
101 | return( |
102 | (ref($it) && $it->{'encoding'}) |
103 | || 'iso-8859-1' # Latin-1 |
104 | ); |
105 | } |
9378c581 |
106 | |
107 | #-------------------------------------------------------------------------- |
108 | |
109 | sub fallback_languages { return('i-default', 'en', 'en-US') } |
110 | |
111 | sub fallback_language_classes { return () } |
112 | |
113 | #-------------------------------------------------------------------------- |
114 | |
115 | sub fail_with { # an actual attribute method! |
f666394a |
116 | my($handle, @params) = @_; |
117 | return unless ref($handle); |
118 | $handle->{'fail'} = $params[0] if @params; |
119 | return $handle->{'fail'}; |
9378c581 |
120 | } |
121 | |
122 | #-------------------------------------------------------------------------- |
123 | |
124 | sub failure_handler_auto { |
f666394a |
125 | # Meant to be used like: |
126 | # $handle->fail_with('failure_handler_auto') |
127 | |
128 | my $handle = shift; |
129 | my $phrase = shift; |
130 | |
131 | $handle->{'failure_lex'} ||= {}; |
132 | my $lex = $handle->{'failure_lex'}; |
133 | |
134 | my $value; |
135 | $lex->{$phrase} ||= ($value = $handle->_compile($phrase)); |
136 | |
137 | # Dumbly copied from sub maketext: |
138 | return ${$value} if ref($value) eq 'SCALAR'; |
139 | return $value if ref($value) ne 'CODE'; |
140 | { |
141 | local $SIG{'__DIE__'}; |
142 | eval { $value = &$value($handle, @_) }; |
143 | } |
144 | # If we make it here, there was an exception thrown in the |
145 | # call to $value, and so scream: |
146 | if($@) { |
147 | my $err = $@; |
148 | # pretty up the error message |
149 | $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} |
150 | {\n in bracket code [compiled line $1],}s; |
151 | #$err =~ s/\n?$/\n/s; |
152 | Carp::croak "Error in maketexting \"$phrase\":\n$err as used"; |
153 | # Rather unexpected, but suppose that the sub tried calling |
154 | # a method that didn't exist. |
155 | } |
156 | else { |
157 | return $value; |
158 | } |
9378c581 |
159 | } |
160 | |
161 | #========================================================================== |
162 | |
163 | sub new { |
f666394a |
164 | # Nothing fancy! |
165 | my $class = ref($_[0]) || $_[0]; |
166 | my $handle = bless {}, $class; |
167 | $handle->init; |
168 | return $handle; |
9378c581 |
169 | } |
170 | |
171 | sub init { return } # no-op |
172 | |
173 | ########################################################################### |
174 | |
175 | sub maketext { |
f666394a |
176 | # Remember, this can fail. Failure is controllable many ways. |
177 | Carp::croak 'maketext requires at least one parameter' unless @_ > 1; |
178 | |
179 | my($handle, $phrase) = splice(@_,0,2); |
180 | Carp::confess('No handle/phrase') unless (defined($handle) && defined($phrase)); |
181 | |
182 | |
183 | # Don't interefere with $@ in case that's being interpolated into the msg. |
184 | local $@; |
185 | |
186 | # Look up the value: |
187 | |
188 | my $value; |
189 | foreach my $h_r ( |
190 | @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs } |
191 | ) { |
ad56049d |
192 | DEBUG and warn "* Looking up \"$phrase\" in $h_r\n"; |
f666394a |
193 | if(exists $h_r->{$phrase}) { |
ad56049d |
194 | DEBUG and warn " Found \"$phrase\" in $h_r\n"; |
f666394a |
195 | unless(ref($value = $h_r->{$phrase})) { |
196 | # Nonref means it's not yet compiled. Compile and replace. |
197 | $value = $h_r->{$phrase} = $handle->_compile($value); |
198 | } |
199 | last; |
200 | } |
201 | elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) { |
202 | # it's an auto lex, and this is an autoable key! |
ad56049d |
203 | DEBUG and warn " Automaking \"$phrase\" into $h_r\n"; |
f666394a |
204 | |
205 | $value = $h_r->{$phrase} = $handle->_compile($phrase); |
206 | last; |
207 | } |
208 | DEBUG>1 and print " Not found in $h_r, nor automakable\n"; |
209 | # else keep looking |
9378c581 |
210 | } |
f666394a |
211 | |
212 | unless(defined($value)) { |
ad56049d |
213 | DEBUG and warn "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle, " fails.\n"; |
f666394a |
214 | if(ref($handle) and $handle->{'fail'}) { |
ad56049d |
215 | DEBUG and warn "WARNING0: maketext fails looking for <$phrase>\n"; |
f666394a |
216 | my $fail; |
217 | if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference |
218 | return &{$fail}($handle, $phrase, @_); |
219 | # If it ever returns, it should return a good value. |
220 | } |
221 | else { # It's a method name |
222 | return $handle->$fail($phrase, @_); |
223 | # If it ever returns, it should return a good value. |
224 | } |
225 | } |
226 | else { |
227 | # All we know how to do is this; |
228 | Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed"); |
229 | } |
230 | } |
231 | |
232 | return $$value if ref($value) eq 'SCALAR'; |
233 | return $value unless ref($value) eq 'CODE'; |
234 | |
235 | { |
236 | local $SIG{'__DIE__'}; |
237 | eval { $value = &$value($handle, @_) }; |
238 | } |
239 | # If we make it here, there was an exception thrown in the |
240 | # call to $value, and so scream: |
241 | if ($@) { |
242 | my $err = $@; |
243 | # pretty up the error message |
244 | $err =~ s{\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?} |
245 | {\n in bracket code [compiled line $1],}s; |
246 | #$err =~ s/\n?$/\n/s; |
247 | Carp::croak "Error in maketexting \"$phrase\":\n$err as used"; |
248 | # Rather unexpected, but suppose that the sub tried calling |
249 | # a method that didn't exist. |
250 | } |
251 | else { |
252 | return $value; |
9378c581 |
253 | } |
9378c581 |
254 | } |
255 | |
256 | ########################################################################### |
257 | |
258 | sub get_handle { # This is a constructor and, yes, it CAN FAIL. |
f666394a |
259 | # Its class argument has to be the base class for the current |
260 | # application's l10n files. |
261 | |
262 | my($base_class, @languages) = @_; |
263 | $base_class = ref($base_class) || $base_class; |
264 | # Complain if they use __PACKAGE__ as a project base class? |
265 | |
266 | if( @languages ) { |
ad56049d |
267 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
f666394a |
268 | if($USING_LANGUAGE_TAGS) { # An explicit language-list was given! |
269 | @languages = |
270 | map {; $_, I18N::LangTags::alternate_language_tags($_) } |
271 | # Catch alternation |
272 | map I18N::LangTags::locale2language_tag($_), |
273 | # If it's a lg tag, fine, pass thru (untainted) |
274 | # If it's a locale ID, try converting to a lg tag (untainted), |
275 | # otherwise nix it. |
276 | @languages; |
ad56049d |
277 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
f666394a |
278 | } |
279 | } |
280 | else { |
281 | @languages = $base_class->_ambient_langprefs; |
1189c245 |
282 | } |
f666394a |
283 | |
284 | @languages = $base_class->_langtag_munging(@languages); |
285 | |
286 | my %seen; |
287 | foreach my $module_name ( map { $base_class . '::' . $_ } @languages ) { |
288 | next unless length $module_name; # sanity |
289 | next if $seen{$module_name}++ # Already been here, and it was no-go |
290 | || !&_try_use($module_name); # Try to use() it, but can't it. |
291 | return($module_name->new); # Make it! |
292 | } |
293 | |
294 | return undef; # Fail! |
14be35aa |
295 | } |
296 | |
297 | ########################################################################### |
298 | |
299 | sub _langtag_munging { |
f666394a |
300 | my($base_class, @languages) = @_; |
301 | |
302 | # We have all these DEBUG statements because otherwise it's hard as hell |
303 | # to diagnose ifwhen something goes wrong. |
304 | |
ad56049d |
305 | DEBUG and warn 'Lgs1: ', map("<$_>", @languages), "\n"; |
f666394a |
306 | |
307 | if($USING_LANGUAGE_TAGS) { |
ad56049d |
308 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
f666394a |
309 | @languages = $base_class->_add_supers( @languages ); |
310 | |
311 | push @languages, I18N::LangTags::panic_languages(@languages); |
ad56049d |
312 | DEBUG and warn "After adding panic languages:\n", |
f666394a |
313 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
314 | |
315 | push @languages, $base_class->fallback_languages; |
316 | # You are free to override fallback_languages to return empty-list! |
ad56049d |
317 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
f666394a |
318 | |
319 | @languages = # final bit of processing to turn them into classname things |
320 | map { |
321 | my $it = $_; # copy |
322 | $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _ |
323 | $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_ |
324 | $it; |
325 | } @languages |
326 | ; |
ad56049d |
327 | DEBUG and warn "Nearing end of munging:\n", |
f666394a |
328 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
329 | } |
330 | else { |
ad56049d |
331 | DEBUG and warn "Bypassing language-tags.\n", |
f666394a |
332 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
333 | } |
334 | |
ad56049d |
335 | DEBUG and warn "Before adding fallback classes:\n", |
f666394a |
336 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
337 | |
338 | push @languages, $base_class->fallback_language_classes; |
339 | # You are free to override that to return whatever. |
340 | |
ad56049d |
341 | DEBUG and warn "Finally:\n", |
f666394a |
342 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
343 | |
344 | return @languages; |
14be35aa |
345 | } |
346 | |
347 | ########################################################################### |
348 | |
349 | sub _ambient_langprefs { |
f666394a |
350 | require I18N::LangTags::Detect; |
351 | return I18N::LangTags::Detect::detect(); |
14be35aa |
352 | } |
353 | |
354 | ########################################################################### |
355 | |
356 | sub _add_supers { |
f666394a |
357 | my($base_class, @languages) = @_; |
358 | |
359 | if (!$MATCH_SUPERS) { |
360 | # Nothing |
ad56049d |
361 | DEBUG and warn "Bypassing any super-matching.\n", |
f666394a |
362 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
363 | |
364 | } |
365 | elsif( $MATCH_SUPERS_TIGHTLY ) { |
ad56049d |
366 | DEBUG and warn "Before adding new supers tightly:\n", |
f666394a |
367 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
368 | @languages = I18N::LangTags::implicate_supers( @languages ); |
ad56049d |
369 | DEBUG and warn "After adding new supers tightly:\n", |
f666394a |
370 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
371 | |
372 | } |
373 | else { |
ad56049d |
374 | DEBUG and warn "Before adding supers to end:\n", |
f666394a |
375 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
376 | @languages = I18N::LangTags::implicate_supers_strictly( @languages ); |
ad56049d |
377 | DEBUG and warn "After adding supers to end:\n", |
f666394a |
378 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
379 | } |
380 | |
381 | return @languages; |
9378c581 |
382 | } |
383 | |
384 | ########################################################################### |
385 | # |
386 | # This is where most people should stop reading. |
387 | # |
388 | ########################################################################### |
389 | |
f600d105 |
390 | use Locale::Maketext::GutsLoader; |
391 | |
f918d677 |
392 | ########################################################################### |
393 | |
9378c581 |
394 | my %tried = (); |
f666394a |
395 | # memoization of whether we've used this module, or found it unusable. |
9378c581 |
396 | |
397 | sub _try_use { # Basically a wrapper around "require Modulename" |
f666394a |
398 | # "Many men have tried..." "They tried and failed?" "They tried and died." |
399 | return $tried{$_[0]} if exists $tried{$_[0]}; # memoization |
400 | |
401 | my $module = $_[0]; # ASSUME sane module name! |
402 | { no strict 'refs'; |
403 | return($tried{$module} = 1) |
404 | if defined(%{$module . '::Lexicon'}) or defined(@{$module . '::ISA'}); |
405 | # weird case: we never use'd it, but there it is! |
406 | } |
407 | |
ad56049d |
408 | DEBUG and warn " About to use $module ...\n"; |
f666394a |
409 | { |
410 | local $SIG{'__DIE__'}; |
411 | eval "require $module"; # used to be "use $module", but no point in that. |
412 | } |
413 | if($@) { |
ad56049d |
414 | DEBUG and warn "Error using $module \: $@\n"; |
f666394a |
415 | return $tried{$module} = 0; |
416 | } |
417 | else { |
ad56049d |
418 | DEBUG and warn " OK, $module is used\n"; |
f666394a |
419 | return $tried{$module} = 1; |
420 | } |
9378c581 |
421 | } |
422 | |
423 | #-------------------------------------------------------------------------- |
424 | |
425 | sub _lex_refs { # report the lexicon references for this handle's class |
f666394a |
426 | # returns an arrayREF! |
427 | no strict 'refs'; |
428 | no warnings 'once'; |
429 | my $class = ref($_[0]) || $_[0]; |
ad56049d |
430 | DEBUG and warn "Lex refs lookup on $class\n"; |
f666394a |
431 | return $isa_scan{$class} if exists $isa_scan{$class}; # memoization! |
432 | |
433 | my @lex_refs; |
434 | my $seen_r = ref($_[1]) ? $_[1] : {}; |
435 | |
436 | if( defined( *{$class . '::Lexicon'}{'HASH'} )) { |
437 | push @lex_refs, *{$class . '::Lexicon'}{'HASH'}; |
ad56049d |
438 | DEBUG and warn '%' . $class . '::Lexicon contains ', |
f666394a |
439 | scalar(keys %{$class . '::Lexicon'}), " entries\n"; |
440 | } |
441 | |
442 | # Implements depth(height?)-first recursive searching of superclasses. |
443 | # In hindsight, I suppose I could have just used Class::ISA! |
444 | foreach my $superclass (@{$class . '::ISA'}) { |
ad56049d |
445 | DEBUG and warn " Super-class search into $superclass\n"; |
f666394a |
446 | next if $seen_r->{$superclass}++; |
447 | push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself |
448 | } |
449 | |
450 | $isa_scan{$class} = \@lex_refs; # save for next time |
451 | return \@lex_refs; |
9378c581 |
452 | } |
453 | |
454 | sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity! |
455 | |
9378c581 |
456 | 1; |