2 # Time-stamp: "2003-06-21 23:41:57 AHDT"
5 package Locale::Maketext;
7 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
10 use I18N::LangTags 0.21 ();
12 #--------------------------------------------------------------------------
14 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
15 # define the constant 'DEBUG' at compile-time
21 $USING_LANGUAGE_TAGS = 1;
22 # Turning this off is somewhat of a security risk in that little or no
23 # checking will be done on the legality of tokens passed to the
24 # eval("use $module_name") in _try_use. If you turn this off, you have
25 # to do your own taint checking.
27 $USE_LITERALS = 1 unless defined $USE_LITERALS;
28 # a hint for compiling bracket-notation things.
32 ###########################################################################
35 my($handle, $num, @forms) = @_;
37 return $num if @forms == 0; # what should this mean?
38 return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
41 # Note that the formatting of $num is preserved.
42 return( $handle->numf($num) . ' ' . $handle->numerate($num, @forms) );
43 # Most human languages put the number phrase before the qualified phrase.
48 # return this lexical item in a form appropriate to this number
49 my($handle, $num, @forms) = @_;
52 return '' unless @forms;
53 if(@forms == 1) { # only the headword form specified
54 return $s ? $forms[0] : ($forms[0] . 's'); # very cheap hack.
55 } else { # sing and plural were specified
56 return $s ? $forms[0] : $forms[1];
60 #--------------------------------------------------------------------------
63 my($handle, $num) = @_[0,1];
64 if($num < 10_000_000_000 and $num > -10_000_000_000 and $num == int($num)) {
65 $num += 0; # Just use normal integer stringification.
66 # Specifically, don't let %G turn ten million into 1E+007
68 $num = CORE::sprintf("%G", $num);
69 # "CORE::" is there to avoid confusion with the above sub sprintf.
71 while( $num =~ s/^([-+]?\d+)(\d{3})/$1,$2/s ) {1} # right from perlfaq5
72 # The initial \d+ gobbles as many digits as it can, and then we
73 # backtrack so it un-eats the rightmost three, and then we
74 # insert the comma there.
76 $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
77 # This is just a lame hack instead of using Number::Format
83 my($handle, $format, @params) = @_;
84 return CORE::sprintf($format, @params);
85 # "CORE::" is there to avoid confusion with myself!
88 #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
90 use integer; # vroom vroom... applies to the whole rest of the module
93 my $it = ref($_[0]) || $_[0];
94 return undef unless $it =~ m/([^':]+)(?:::)?$/s;
103 (ref($it) && $it->{'encoding'})
104 || "iso-8859-1" # Latin-1
108 #--------------------------------------------------------------------------
110 sub fallback_languages { return('i-default', 'en', 'en-US') }
112 sub fallback_language_classes { return () }
114 #--------------------------------------------------------------------------
116 sub fail_with { # an actual attribute method!
117 my($handle, @params) = @_;
118 return unless ref($handle);
119 $handle->{'fail'} = $params[0] if @params;
120 return $handle->{'fail'};
123 #--------------------------------------------------------------------------
125 sub failure_handler_auto {
126 # Meant to be used like:
127 # $handle->fail_with('failure_handler_auto')
129 my($handle, $phrase, @params) = @_;
130 $handle->{'failure_lex'} ||= {};
131 my $lex = $handle->{'failure_lex'};
134 $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
136 # Dumbly copied from sub maketext:
138 local $SIG{'__DIE__'};
139 eval { $value = &$value($handle, @_) };
141 # If we make it here, there was an exception thrown in the
142 # call to $value, and so scream:
145 # pretty up the error message
146 $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
147 <\n in bracket code [compiled line $1],>s;
148 #$err =~ s/\n?$/\n/s;
149 Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
150 # Rather unexpected, but suppose that the sub tried calling
151 # a method that didn't exist.
157 #==========================================================================
161 my $class = ref($_[0]) || $_[0];
162 my $handle = bless {}, $class;
167 sub init { return } # no-op
169 ###########################################################################
172 # Remember, this can fail. Failure is controllable many ways.
173 Carp::croak "maketext requires at least one parameter" unless @_ > 1;
175 my($handle, $phrase) = splice(@_,0,2);
181 @{ $isa_scan{ref($handle) || $handle} || $handle->_lex_refs }
183 print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
184 if(exists $h_r->{$phrase}) {
185 print " Found \"$phrase\" in $h_r\n" if DEBUG;
186 unless(ref($value = $h_r->{$phrase})) {
187 # Nonref means it's not yet compiled. Compile and replace.
188 $value = $h_r->{$phrase} = $handle->_compile($value);
191 } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
192 # it's an auto lex, and this is an autoable key!
193 print " Automaking \"$phrase\" into $h_r\n" if DEBUG;
195 $value = $h_r->{$phrase} = $handle->_compile($phrase);
198 print " Not found in $h_r, nor automakable\n" if DEBUG > 1;
202 unless(defined($value)) {
203 print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
204 " fails.\n" if DEBUG;
205 if(ref($handle) and $handle->{'fail'}) {
206 print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
208 if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
209 return &{$fail}($handle, $phrase, @_);
210 # If it ever returns, it should return a good value.
211 } else { # It's a method name
212 return $handle->$fail($phrase, @_);
213 # If it ever returns, it should return a good value.
216 # All we know how to do is this;
217 Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
221 return $$value if ref($value) eq 'SCALAR';
222 return $value unless ref($value) eq 'CODE';
225 local $SIG{'__DIE__'};
226 eval { $value = &$value($handle, @_) };
228 # If we make it here, there was an exception thrown in the
229 # call to $value, and so scream:
232 # pretty up the error message
233 $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
234 <\n in bracket code [compiled line $1],>s;
235 #$err =~ s/\n?$/\n/s;
236 Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
237 # Rather unexpected, but suppose that the sub tried calling
238 # a method that didn't exist.
244 ###########################################################################
246 sub get_handle { # This is a constructor and, yes, it CAN FAIL.
247 # Its class argument has to be the base class for the current
248 # application's l10n files.
249 my($base_class, @languages) = @_;
250 $base_class = ref($base_class) || $base_class;
251 # Complain if they use __PACKAGE__ as a project base class?
253 unless(@languages) { # Calling with no args is magical! wooo, magic!
254 if(length( $ENV{'REQUEST_METHOD'} || '' )) { # I'm a CGI
255 @languages = $base_class->_http_accept_langs;
256 # it's off in its own routine because it's complicated
258 } else { # Not running as a CGI: try to puzzle out from the environment
259 if(length( $ENV{'LANG'} || '' )) {
260 push @languages, split m/[,:]/, $ENV{'LANG'};
261 # LANG can be only /one/ locale as far as I know, but what the hey.
263 if(length( $ENV{'LANGUAGE'} || '' )) {
264 push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
266 print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
267 # Those are really locale IDs, but they get xlated a few lines down.
269 if(&_try_use('Win32::Locale')) {
270 # If we have that module installed...
271 push @languages, Win32::Locale::get_language()
272 if defined &Win32::Locale::get_language;
277 #------------------------------------------------------------------------
278 print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;
280 if($USING_LANGUAGE_TAGS) {
281 @languages = map &I18N::LangTags::locale2language_tag($_), @languages;
282 # if it's a lg tag, fine, pass thru (untainted)
283 # if it's a locale ID, try converting to a lg tag (untainted),
286 push @languages, map I18N::LangTags::super_languages($_), @languages
289 @languages = map { $_, I18N::LangTags::alternate_language_tags($_) }
290 @languages; # catch alternation
292 push @languages, I18N::LangTags::panic_languages(@languages)
293 if defined &I18N::LangTags::panic_languages;
295 push @languages, $base_class->fallback_languages;
296 # You are free to override fallback_languages to return empty-list!
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_
307 print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;
309 push @languages, $base_class->fallback_language_classes;
310 # You are free to override that to return whatever.
314 foreach my $module_name ( map { $base_class . "::" . $_ } @languages )
316 next unless length $module_name; # sanity
317 next if $seen{$module_name}++ # Already been here, and it was no-go
318 || !&_try_use($module_name); # Try to use() it, but can't it.
319 return($module_name->new); # Make it!
322 return undef; # Fail!
325 ###########################################################################
327 # This is where most people should stop reading.
329 ###########################################################################
331 use Locale::Maketext::GutsLoader;
333 sub _http_accept_langs {
334 # Deal with HTTP "Accept-Language:" stuff. Hassle.
335 # This code is more lenient than RFC 3282, which you must read.
336 # Hm. Should I just move this into I18N::LangTags at some point?
339 my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
340 # (always ends up untainting)
342 return() unless defined $in and length $in;
344 $in =~ s/\([^\)]*\)//g; # nix just about any comment
346 if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
347 # Very common case: just one language tag
349 } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
350 # Common case these days: just "foo, bar, baz"
351 return map lc($_), $in =~ m/([a-zA-Z][-a-zA-Z]+)/g;
354 # Else it's complicated...
356 $in =~ s/\s+//g; # Yes, we can just do without the WS!
357 my @in = $in =~ m/([^,]+)/g;
361 foreach my $tag (@in) {
363 m/^([a-zA-Z][-a-zA-Z]+)
367 \d* # a bit too broad of a RE, but so what.
376 $q = (defined $2 and length $2) ? $2 : 1;
377 #print "$1 with q=$q\n";
378 push @{ $pref{$q} }, lc $1;
381 return # Read off %pref, in descending key order...
387 ###########################################################################
390 # memoization of whether we've used this module, or found it unusable.
392 sub _try_use { # Basically a wrapper around "require Modulename"
393 # "Many men have tried..." "They tried and failed?" "They tried and died."
394 return $tried{$_[0]} if exists $tried{$_[0]}; # memoization
396 my $module = $_[0]; # ASSUME sane module name!
398 return($tried{$module} = 1)
399 if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
400 # weird case: we never use'd it, but there it is!
403 print " About to use $module ...\n" if DEBUG;
405 local $SIG{'__DIE__'};
406 eval "require $module"; # used to be "use $module", but no point in that.
409 print "Error using $module \: $@\n" if DEBUG > 1;
410 return $tried{$module} = 0;
412 print " OK, $module is used\n" if DEBUG;
413 return $tried{$module} = 1;
417 #--------------------------------------------------------------------------
419 sub _lex_refs { # report the lexicon references for this handle's class
420 # returns an arrayREF!
422 my $class = ref($_[0]) || $_[0];
423 print "Lex refs lookup on $class\n" if DEBUG > 1;
424 return $isa_scan{$class} if exists $isa_scan{$class}; # memoization!
427 my $seen_r = ref($_[1]) ? $_[1] : {};
429 if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
430 push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
431 print "%" . $class . "::Lexicon contains ",
432 scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
435 # Implements depth(height?)-first recursive searching of superclasses.
436 # In hindsight, I suppose I could have just used Class::ISA!
437 foreach my $superclass (@{$class . "::ISA"}) {
438 print " Super-class search into $superclass\n" if DEBUG;
439 next if $seen_r->{$superclass}++;
440 push @lex_refs, @{&_lex_refs($superclass, $seen_r)}; # call myself
443 $isa_scan{$class} = \@lex_refs; # save for next time
447 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
449 ###########################################################################
454 HEY YOU! You need some FOOD!
457 ~~ Tangy Moroccan Carrot Salad ~~
459 * 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
460 * 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
461 * 1 tablespoon ground cumin
463 * The juice of about a half a big lemon, or of a whole smaller one
465 * 1 tablespoon of fresh dill, washed and chopped fine
466 * Pinch of salt, maybe a pinch of pepper
468 Cook the carrots in a pot of boiling water until just tender -- roughly
469 six minutes. (Just don't let them get mushy!) Drain the carrots.
471 In a largish bowl, combine the lemon juice, the cumin, the chile
472 powder, and the honey. Mix well.
473 Add the olive oil and whisk it together well. Add the dill and stir.
475 Add the warm carrots to the bowl and toss it all to coat the carrots
476 well. Season with salt and pepper, to taste.
478 Serve warm or at room temperature.
480 The measurements here are very approximate, and you should feel free to
481 improvise and experiment. It's a very forgiving recipe. For example,
482 you could easily halve or double the amount of cumin, or use chopped mint
483 leaves instead of dill, or lime juice instead of lemon, et cetera.