2 # Time-stamp: "2004-01-11 19:02:37 AST"
5 package Locale::Maketext;
7 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
8 $USE_LITERALS $MATCH_SUPERS_TIGHTLY);
10 use I18N::LangTags 0.21 ();
12 #--------------------------------------------------------------------------
14 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
15 # define the constant 'DEBUG' at compile-time
21 $MATCH_SUPERS_TIGHTLY = 1;
22 $USING_LANGUAGE_TAGS = 1;
23 # Turning this off is somewhat of a security risk in that little or no
24 # checking will be done on the legality of tokens passed to the
25 # eval("use $module_name") in _try_use. If you turn this off, you have
26 # to do your own taint checking.
28 $USE_LITERALS = 1 unless defined $USE_LITERALS;
29 # a hint for compiling bracket-notation things.
33 ###########################################################################
36 my($handle, $num, @forms) = @_;
38 return $num if @forms == 0; # what should this mean?
39 return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
42 # Note that the formatting of $num is preserved.
43 return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
44 # Most human languages put the number phrase before the qualified phrase.
49 # return this lexical item in a form appropriate to this number
50 my($handle, $num, @forms) = @_;
53 return '' unless @forms;
54 if(@forms == 1) { # only the headword form specified
55 return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
56 } else { # sing and plural were specified
57 return $s ? $forms[0] : $forms[1];
61 #--------------------------------------------------------------------------
64 my($handle, $num) = @_[0,1];
65 if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
66 $num += 0; # Just use normal integer stringification.
67 # Specifically, don't let %G turn ten million into 1E+007
69 $num = CORE::sprintf("%G", $num);
70 # "CORE::" is there to avoid confusion with the above sub sprintf.
72 while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
73 # The initial \d+ gobbles as many digits as it can, and then we
74 # backtrack so it un-eats the rightmost three, and then we
75 # insert the comma there.
77 $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
78 # This is just a lame hack instead of using Number::Format
84 my($handle, $format, @params) = @_;
85 return CORE::sprintf($format, @params);
86 # "CORE::" is there to avoid confusion with myself!
89 #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
91 use integer; # vroom vroom... applies to the whole rest of the module
94 my $it = ref($_[0]) || $_[0];
95 return undef unless $it =~ m/([^':]+)(?:::)?$/s;
104 (ref($it) && $it->{'encoding'})
105 || "iso-8859-1" # Latin-1
109 #--------------------------------------------------------------------------
111 sub fallback_languages { return('i-default', 'en', 'en-US') }
113 sub fallback_language_classes { return () }
115 #--------------------------------------------------------------------------
117 sub fail_with { # an actual attribute method!
118 my($handle, @params) = @_;
119 return unless ref($handle);
120 $handle->{'fail'} = $params[0] if @params;
121 return $handle->{'fail'};
124 #--------------------------------------------------------------------------
126 sub failure_handler_auto {
127 # Meant to be used like:
128 # $handle->fail_with('failure_handler_auto')
130 my($handle, $phrase, @params) = @_;
131 $handle->{'failure_lex'} ||= {};
132 my $lex = $handle->{'failure_lex'};
135 $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
137 # Dumbly copied from sub maketext:
139 local $SIG{'__DIE__'};
140 eval { $value = &$value($handle, @_) };
142 # If we make it here, there was an exception thrown in the
143 # call to $value, and so scream:
146 # pretty up the error message
147 $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
148 <\n in bracket code [compiled line $1],>s;
149 #$err =~ s/\n?$/\n/s;
150 Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
151 # Rather unexpected, but suppose that the sub tried calling
152 # a method that didn't exist.
158 #==========================================================================
162 my $class = ref($_[0]) || $_[0];
163 my $handle = bless {}, $class;
168 sub init { return } # no-op
170 ###########################################################################
173 # Remember, this can fail. Failure is controllable many ways.
174 Carp::croak "maketext requires at least one parameter" unless @_ > 1;
176 my($handle, $phrase) = splice(@_,0,2);
182 @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
184 print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
185 if(exists $h_r->{$phrase}) {
186 print " Found \"$phrase\" in $h_r\n" if DEBUG;
187 unless(ref($value = $h_r->{$phrase})) {
188 # Nonref means it's not yet compiled. Compile and replace.
189 $value = $h_r->{$phrase} = $handle->_compile($value);
192 } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
193 # it's an auto lex, and this is an autoable key!
194 print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
196 $value = $h_r->{$phrase} = $handle->_compile($phrase);
199 print " Not found in $h_r, nor automakable\n" if DEBUG > 1;
203 unless(defined($value)) {
204 print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
205 " fails.\n" if DEBUG;
206 if(ref($handle) and $handle->{'fail'}) {
207 print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
209 if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
210 return &{$fail}($handle, $phrase, @_);
211 # If it ever returns, it should return a good value.
212 } else { # It's a method name
213 return $handle->$fail($phrase, @_);
214 # If it ever returns, it should return a good value.
217 # All we know how to do is this;
218 Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
222 return $$value if ref($value) eq 'SCALAR';
223 return $value unless ref($value) eq 'CODE';
226 local $SIG{'__DIE__'};
227 eval { $value = &$value($handle, @_) };
229 # If we make it here, there was an exception thrown in the
230 # call to $value, and so scream:
233 # pretty up the error message
234 $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
235 <\n in bracket code [compiled line $1],>s;
236 #$err =~ s/\n?$/\n/s;
237 Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
238 # Rather unexpected, but suppose that the sub tried calling
239 # a method that didn't exist.
245 ###########################################################################
247 sub get_handle { # This is a constructor and, yes, it CAN FAIL.
248 # Its class argument has to be the base class for the current
249 # application's l10n files.
251 my($base_class, @languages) = @_;
252 $base_class = ref($base_class) || $base_class;
253 # Complain if they use __PACKAGE__ as a project base class?
255 @languages = $base_class->_ambient_langprefs() unless @languages;
256 @languages = $base_class->_langtag_munging(@languages);
259 foreach my $module_name ( map { $base_class . "::" . $_ } @languages ) {
260 next unless length $module_name; # sanity
261 next if $seen{$module_name}++ # Already been here, and it was no-go
262 || !&_try_use($module_name); # Try to use() it, but can't it.
263 return($module_name->new); # Make it!
266 return undef; # Fail!
269 ###########################################################################
271 sub _langtag_munging {
272 my($base_class, @languages) = @_;
274 DEBUG and print "Lgs1: ", map("<$_>", @languages), "\n";
276 if($USING_LANGUAGE_TAGS) {
277 @languages = map &I18N::LangTags::locale2language_tag($_), @languages;
278 # if it's a lg tag, fine, pass thru (untainted)
279 # if it's a locale ID, try converting to a lg tag (untainted),
282 @languages = map {; $_, I18N::LangTags::alternate_language_tags($_) }
283 @languages; # catch alternation
284 DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
286 if( defined &I18N::LangTags::panic_languages ) {
287 push @languages, I18N::LangTags::panic_languages(@languages);
288 DEBUG and print "After adding panic languages:\n",
289 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
292 @languages = $base_class->_add_supers( @languages );
294 push @languages, $base_class->fallback_languages;
295 # You are free to override fallback_languages to return empty-list!
296 DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
298 @languages = # final bit of processing:
301 $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
302 $it =~ tr<_a-z0-9><>cd; # remove all but a-z0-9_
306 DEBUG and print "Nearing end of munging:\n",
307 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
309 DEBUG and print "Bypassing language-tags.\n",
310 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
313 DEBUG and print "Before adding fallback classes:\n",
314 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
316 push @languages, $base_class->fallback_language_classes;
317 # You are free to override that to return whatever.
319 DEBUG and print "Finally:\n",
320 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
325 ###########################################################################
327 sub _ambient_langprefs {
328 my $base_class = $_[0];
330 return $base_class->_http_accept_langs
331 if length( $ENV{'REQUEST_METHOD'} || '' ); # I'm a CGI
332 # it's off in its own routine because it's complicated
334 # Not running as a CGI: try to puzzle out from the environment
337 if(length( $ENV{'LANG'} || '' )) {
338 push @languages, split m/[,:]/, $ENV{'LANG'};
339 # LANG can be only /one/ locale as far as I know, but what the hey.
342 if(length( $ENV{'LANGUAGE'} || '' )) {
343 push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
346 print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
347 # Those are really locale IDs, but they get xlated a few lines down.
349 if(&_try_use('Win32::Locale')) {
350 # If we have that module installed...
351 push @languages, Win32::Locale::get_language() || ''
352 if defined &Win32::Locale::get_language;
358 ###########################################################################
361 my($base_class, @languages) = @_;
365 DEBUG and print "Bypassing any super-matching.\n",
366 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
368 } elsif( $MATCH_SUPERS_TIGHTLY ) {
369 DEBUG and print "Before adding new supers tightly:\n",
370 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
373 foreach my $lang (@languages) {
374 $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
377 my(@output_languages);
378 foreach my $lang (@languages) {
379 push @output_languages, $lang;
380 foreach my $s ( I18N::LangTags::super_languages($lang) ) {
381 # Note that super_languages returns the longest first.
382 last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
383 push @output_languages, $s;
386 @languages = @output_languages;
388 DEBUG and print "After adding new supers tightly:\n",
389 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
393 push @languages, map I18N::LangTags::super_languages($_), @languages;
394 DEBUG and print "After adding supers to end:\n",
395 " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
401 ###########################################################################
403 # This is where most people should stop reading.
405 ###########################################################################
407 use Locale::Maketext::GutsLoader;
409 sub _http_accept_langs {
410 # Deal with HTTP "Accept-Language:" stuff. Hassle.
411 # This code is more lenient than RFC 3282, which you must read.
412 # Hm. Should I just move this into I18N::LangTags at some point?
415 my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
416 # (always ends up untainting)
418 return() unless defined $in and length $in;
420 $in =~ s/\([^\)]*\)//g; # nix just about any comment
422 if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
423 # Very common case: just one language tag
425 } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
426 # Common case these days: just "foo, bar, baz"
427 return map lc($_), $in =~ m/([a-zA-Z][-a-zA-Z]+)/g;
430 # Else it's complicated...
432 $in =~ s/\s+//g; # Yes, we can just do without the WS!
433 my @in = $in =~ m/([^,]+)/g;
437 foreach my $tag (@in) {
439 m/^([a-zA-Z][-a-zA-Z]+)
443 \d* # a bit too broad of a RE, but so what.
452 $q = (defined $2 and length $2) ? $2 : 1;
453 #print "$1 with q=$q\n";
454 push @{ $pref{$q} }, lc $1;
457 return # Read off %pref, in descending key order...
463 ###########################################################################
466 # memoization of whether we've used this module, or found it unusable.
468 sub _try_use { # Basically a wrapper around "require Modulename"
469 # "Many men have tried..." "They tried and failed?" "They tried and died."
470 return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
472 my $module = $_[0]; # ASSUME sane module name!
474 return($tried{$module} = 1)
475 if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
476 # weird case: we never use'd it, but there it is!
479 print " About to use $module ...\n" if DEBUG;
481 local $SIG{'__DIE__'};
482 eval "require $module"; # used to be "use $module", but no point in that.
485 print "Error using $module \: $@\n" if DEBUG > 1;
486 return $tried{$module} = 0;
488 print " OK, $module is used\n" if DEBUG;
489 return $tried{$module} = 1;
493 #--------------------------------------------------------------------------
495 sub _lex_refs { # report the lexicon references for this handle's class
496 # returns an arrayREF!
498 my $class = ref($_[0]) || $_[0];
499 print "Lex refs lookup on $class\n" if DEBUG > 1;
500 return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
503 my $seen_r = ref($_[1]) ? $_[1] : {};
505 if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
506 push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
507 print "%" . $class . "::Lexicon contains ",
508 scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
511 # Implements depth(height?)-first recursive searching of superclasses.
512 # In hindsight, I suppose I could have just used Class::ISA!
513 foreach my $superclass (@{$class . "::ISA"}) {
514 print " Super-class search into $superclass\n" if DEBUG;
515 next if $seen_r->{$superclass}++;
516 push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
519 $isa_scan{$class} = \@lex_refs; # save for next time
523 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
525 ###########################################################################
530 HEY YOU! You need some FOOD!
533 ~~ Tangy Moroccan Carrot Salad ~~
535 * 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
536 * 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
537 * 1 tablespoon ground cumin
539 * The juice of about a half a big lemon, or of a whole smaller one
541 * 1 tablespoon of fresh dill, washed and chopped fine
542 * Pinch of salt, maybe a pinch of pepper
544 Cook the carrots in a pot of boiling water until just tender -- roughly
545 six minutes. (Just don't let them get mushy!) Drain the carrots.
547 In a largish bowl, combine the lemon juice, the cumin, the chile
548 powder, and the honey. Mix well.
549 Add the olive oil and whisk it together well. Add the dill and stir.
551 Add the warm carrots to the bowl and toss it all to coat the carrots
552 well. Season with salt and pepper, to taste.
554 Serve warm or at room temperature.
556 The measurements here are very approximate, and you should feel free to
557 improvise and experiment. It's a very forgiving recipe. For example,
558 you could easily halve or double the amount of cumin, or use chopped mint
559 leaves instead of dill, or lime juice instead of lemon, et cetera.