Commit | Line | Data |
---|---|---|
9378c581 JH |
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 JH |
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 JH |
14 | @ISA = (); |
15 | ||
16 | $MATCH_SUPERS = 1; | |
14be35aa AMS |
17 | $MATCH_SUPERS_TIGHTLY = 1; |
18 | $USING_LANGUAGE_TAGS = 1; | |
f666394a RGS |
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 JH |
23 | |
24 | $USE_LITERALS = 1 unless defined $USE_LITERALS; | |
f666394a | 25 | # a hint for compiling bracket-notation things. |
9378c581 JH |
26 | |
27 | my %isa_scan = (); | |
28 | ||
29 | ########################################################################### | |
30 | ||
31 | sub quant { | |
f666394a | 32 | my($handle, $num, @forms) = @_; |
9378c581 | 33 | |
f666394a RGS |
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 RGS |
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 JH |
41 | } |
42 | ||
43 | ||
44 | sub numerate { | |
f666394a RGS |
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 JH |
56 | } |
57 | ||
58 | #-------------------------------------------------------------------------- | |
59 | ||
60 | sub numf { | |
f666394a RGS |
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 JH |
78 | } |
79 | ||
80 | sub sprintf { | |
f666394a RGS |
81 | no integer; |
82 | my($handle, $format, @params) = @_; | |
83 | return CORE::sprintf($format, @params); | |
9378c581 JH |
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 RGS |
92 | my $it = ref($_[0]) || $_[0]; |
93 | return undef unless $it =~ m/([^':]+)(?:::)?$/s; | |
94 | $it = lc($1); | |
95 | $it =~ tr<_><->; | |
96 | return $it; | |
9378c581 JH |
97 | } |
98 | ||
99 | sub encoding { | |
f666394a RGS |
100 | my $it = $_[0]; |
101 | return( | |
102 | (ref($it) && $it->{'encoding'}) | |
103 | || 'iso-8859-1' # Latin-1 | |
104 | ); | |
105 | } | |
9378c581 JH |
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 RGS |
116 | my($handle, @params) = @_; |
117 | return unless ref($handle); | |
118 | $handle->{'fail'} = $params[0] if @params; | |
119 | return $handle->{'fail'}; | |
9378c581 JH |
120 | } |
121 | ||
122 | #-------------------------------------------------------------------------- | |
123 | ||
124 | sub failure_handler_auto { | |
f666394a RGS |
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 JH |
159 | } |
160 | ||
161 | #========================================================================== | |
162 | ||
163 | sub new { | |
f666394a RGS |
164 | # Nothing fancy! |
165 | my $class = ref($_[0]) || $_[0]; | |
166 | my $handle = bless {}, $class; | |
167 | $handle->init; | |
168 | return $handle; | |
9378c581 JH |
169 | } |
170 | ||
171 | sub init { return } # no-op | |
172 | ||
173 | ########################################################################### | |
174 | ||
175 | sub maketext { | |
f666394a RGS |
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 RGS |
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 RGS |
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 RGS |
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 RGS |
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 JH |
254 | } |
255 | ||
256 | ########################################################################### | |
257 | ||
258 | sub get_handle { # This is a constructor and, yes, it CAN FAIL. | |
f666394a RGS |
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 RGS |
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 RGS |
278 | } |
279 | } | |
280 | else { | |
281 | @languages = $base_class->_ambient_langprefs; | |
1189c245 | 282 | } |
f666394a RGS |
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 AMS |
295 | } |
296 | ||
297 | ########################################################################### | |
298 | ||
299 | sub _langtag_munging { | |
f666394a RGS |
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 RGS |
306 | |
307 | if($USING_LANGUAGE_TAGS) { | |
ad56049d | 308 | DEBUG and warn 'Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
f666394a RGS |
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 RGS |
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 RGS |
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 RGS |
328 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
329 | } | |
330 | else { | |
ad56049d | 331 | DEBUG and warn "Bypassing language-tags.\n", |
f666394a RGS |
332 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
333 | } | |
334 | ||
ad56049d | 335 | DEBUG and warn "Before adding fallback classes:\n", |
f666394a RGS |
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 RGS |
342 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
343 | ||
344 | return @languages; | |
14be35aa AMS |
345 | } |
346 | ||
347 | ########################################################################### | |
348 | ||
349 | sub _ambient_langprefs { | |
f666394a RGS |
350 | require I18N::LangTags::Detect; |
351 | return I18N::LangTags::Detect::detect(); | |
14be35aa AMS |
352 | } |
353 | ||
354 | ########################################################################### | |
355 | ||
356 | sub _add_supers { | |
f666394a RGS |
357 | my($base_class, @languages) = @_; |
358 | ||
359 | if (!$MATCH_SUPERS) { | |
360 | # Nothing | |
ad56049d | 361 | DEBUG and warn "Bypassing any super-matching.\n", |
f666394a RGS |
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 RGS |
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 RGS |
370 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
371 | ||
372 | } | |
373 | else { | |
ad56049d | 374 | DEBUG and warn "Before adding supers to end:\n", |
f666394a RGS |
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 RGS |
378 | ' Lgs@', __LINE__, ': ', map("<$_>", @languages), "\n"; |
379 | } | |
380 | ||
381 | return @languages; | |
9378c581 JH |
382 | } |
383 | ||
384 | ########################################################################### | |
385 | # | |
386 | # This is where most people should stop reading. | |
387 | # | |
388 | ########################################################################### | |
389 | ||
f600d105 JH |
390 | use Locale::Maketext::GutsLoader; |
391 | ||
f918d677 JH |
392 | ########################################################################### |
393 | ||
9378c581 | 394 | my %tried = (); |
f666394a | 395 | # memoization of whether we've used this module, or found it unusable. |
9378c581 JH |
396 | |
397 | sub _try_use { # Basically a wrapper around "require Modulename" | |
f666394a RGS |
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 RGS |
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 RGS |
415 | return $tried{$module} = 0; |
416 | } | |
417 | else { | |
ad56049d | 418 | DEBUG and warn " OK, $module is used\n"; |
f666394a RGS |
419 | return $tried{$module} = 1; |
420 | } | |
9378c581 JH |
421 | } |
422 | ||
423 | #-------------------------------------------------------------------------- | |
424 | ||
425 | sub _lex_refs { # report the lexicon references for this handle's class | |
f666394a RGS |
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 RGS |
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 RGS |
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 RGS |
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 JH |
452 | } |
453 | ||
454 | sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity! | |
455 | ||
9378c581 | 456 | 1; |