lib/Locale/Maketext.pm

   1
   2 # Time-stamp: "2003-06-21 23:41:57 AHDT"
   3
   4 require 5;
   5 package Locale::Maketext;
   6 use strict;
   7 use vars qw( @ISA $VERSION $MATCH_SUPERS $USING_LANGUAGE_TAGS
   8              $USE_LITERALS);
   9 use Carp ();
  10 use I18N::LangTags 0.21 ();
  11
  12 #--------------------------------------------------------------------------
  13
  14 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
  15  # define the constant 'DEBUG' at compile-time
  16
  17 $VERSION = "1.06";
  18 @ISA = ();
  19
  20 $MATCH_SUPERS = 1;
  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.
  26
  27 $USE_LITERALS = 1 unless defined $USE_LITERALS;
  28  # a hint for compiling bracket-notation things.
  29
  30 my %isa_scan = ();
  31
  32 ###########################################################################
  33
  34 sub quant {
  35   my($handle, $num, @forms) = @_;
  36
  37   return $num if @forms == 0; # what should this mean?
  38   return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
  39
  40   # Normal 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.
  44 }
  45
  46
  47 sub numerate {
  48  # return this lexical item in a form appropriate to this number
  49   my($handle, $num, @forms) = @_;
  50   my $s = ($num == 1);
  51
  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];
  57   }
  58 }
  59
  60 #--------------------------------------------------------------------------
  61
  62 sub numf {
  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
  67   } else {
  68     $num = CORE::sprintf("%G", $num);
  69      # "CORE::" is there to avoid confusion with the above sub sprintf.
  70   }
  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.
  75
  76   $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
  77    # This is just a lame hack instead of using Number::Format
  78   return $num;
  79 }
  80
  81 sub sprintf {
  82   no integer;
  83   my($handle, $format, @params) = @_;
  84   return CORE::sprintf($format, @params);
  85     # "CORE::" is there to avoid confusion with myself!
  86 }
  87
  88 #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
  89
  90 use integer; # vroom vroom... applies to the whole rest of the module
  91
  92 sub language_tag {
  93   my $it = ref($_[0]) || $_[0];
  94   return undef unless $it =~ m/([^':]+)(?:::)?$/s;
  95   $it = lc($1);
  96   $it =~ tr<_><->;
  97   return $it;
  98 }
  99
 100 sub encoding {
 101   my $it = $_[0];
 102   return(
 103    (ref($it) && $it->{'encoding'})
 104    || "iso-8859-1"   # Latin-1
 105   );
 106 }
 107
 108 #--------------------------------------------------------------------------
 109
 110 sub fallback_languages { return('i-default', 'en', 'en-US') }
 111
 112 sub fallback_language_classes { return () }
 113
 114 #--------------------------------------------------------------------------
 115
 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'};
 121 }
 122
 123 #--------------------------------------------------------------------------
 124
 125 sub failure_handler_auto {
 126   # Meant to be used like:
 127   #  $handle->fail_with('failure_handler_auto')
 128
 129   my($handle, $phrase, @params) = @_;
 130   $handle->{'failure_lex'} ||= {};
 131   my $lex = $handle->{'failure_lex'};
 132
 133   my $value;
 134   $lex->{$phrase} ||= ($value = $handle->_compile($phrase));
 135
 136   # Dumbly copied from sub maketext:
 137   {
 138     local $SIG{'__DIE__'};
 139     eval { $value = &$value($handle, @_) };
 140   }
 141   # If we make it here, there was an exception thrown in the
 142   #  call to $value, and so scream:
 143   if($@) {
 144     my $err = $@;
 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.
 152   } else {
 153     return $value;
 154   }
 155 }
 156
 157 #==========================================================================
 158
 159 sub new {
 160   # Nothing fancy!
 161   my $class = ref($_[0]) || $_[0];
 162   my $handle = bless {}, $class;
 163   $handle->init;
 164   return $handle;
 165 }
 166
 167 sub init { return } # no-op
 168
 169 ###########################################################################
 170
 171 sub maketext {
 172   # Remember, this can fail.  Failure is controllable many ways.
 173   Carp::croak "maketext requires at least one parameter" unless @_ > 1;
 174
 175   my($handle, $phrase) = splice(@_,0,2);
 176
 177   # Look up the value:
 178
 179   my $value;
 180   foreach my $h_r (
 181     @{  $isa_scan{ref($handle) || $handle} || $handle->_lex_refs  }
 182   ) {
 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);
 189       }
 190       last;
 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;
 194
 195       $value = $h_r->{$phrase} = $handle->_compile($phrase);
 196       last;
 197     }
 198     print "  Not found in $h_r, nor automakable\n" if DEBUG > 1;
 199     # else keep looking
 200   }
 201
 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;
 207       my $fail;
 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.
 214       }
 215     } else {
 216       # All we know how to do is this;
 217       Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
 218     }
 219   }
 220
 221   return $$value if ref($value) eq 'SCALAR';
 222   return $value unless ref($value) eq 'CODE';
 223
 224   {
 225     local $SIG{'__DIE__'};
 226     eval { $value = &$value($handle, @_) };
 227   }
 228   # If we make it here, there was an exception thrown in the
 229   #  call to $value, and so scream:
 230   if($@) {
 231     my $err = $@;
 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.
 239   } else {
 240     return $value;
 241   }
 242 }
 243
 244 ###########################################################################
 245
 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?
 252
 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
 257
 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.
 262       }
 263       if(length( $ENV{'LANGUAGE'} || '' )) {
 264         push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
 265       }
 266       print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
 267       # Those are really locale IDs, but they get xlated a few lines down.
 268
 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;
 273       }
 274     }
 275   }
 276
 277   #------------------------------------------------------------------------
 278   print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;
 279
 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),
 284      # otherwise nix it.
 285
 286     push @languages, map I18N::LangTags::super_languages($_), @languages
 287      if $MATCH_SUPERS;
 288
 289     @languages =  map { $_, I18N::LangTags::alternate_language_tags($_) }
 290                       @languages;    # catch alternation
 291
 292     push @languages, I18N::LangTags::panic_languages(@languages)
 293       if defined &I18N::LangTags::panic_languages;
 294
 295     push @languages, $base_class->fallback_languages;
 296      # You are free to override fallback_languages to return empty-list!
 297
 298     @languages =  # final bit of processing:
 299       map {
 300         my $it = $_;  # copy
 301         $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
 302         $it =~ tr<_a-z0-9><>cd;  # remove all but a-z0-9_
 303         $it;
 304       } @languages
 305     ;
 306   }
 307   print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;
 308
 309   push @languages, $base_class->fallback_language_classes;
 310    # You are free to override that to return whatever.
 311
 312
 313   my %seen = ();
 314   foreach my $module_name ( map { $base_class . "::" . $_ }  @languages )
 315   {
 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!
 320   }
 321
 322   return undef; # Fail!
 323 }
 324
 325 ###########################################################################
 326 #
 327 # This is where most people should stop reading.
 328 #
 329 ###########################################################################
 330
 331 use Locale::Maketext::GutsLoader;
 332
 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?
 337   no integer;
 338
 339   my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
 340   # (always ends up untainting)
 341
 342   return() unless defined $in and length $in;
 343
 344   $in =~ s/\([^\)]*\)//g; # nix just about any comment
 345
 346   if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
 347     # Very common case: just one language tag
 348     return lc $1;
 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;
 352   }
 353
 354   # Else it's complicated...
 355
 356   $in =~ s/\s+//g;  # Yes, we can just do without the WS!
 357   my @in = $in =~ m/([^,]+)/g;
 358   my %pref;
 359
 360   my $q;
 361   foreach my $tag (@in) {
 362     next unless $tag =~
 363      m/^([a-zA-Z][-a-zA-Z]+)
 364         (?:
 365          ;q=
 366          (
 367           \d*   # a bit too broad of a RE, but so what.
 368           (?:
 369             \.\d+
 370           )?
 371          )
 372         )?
 373        $
 374       /sx
 375     ;
 376     $q = (defined $2 and length $2) ? $2 : 1;
 377     #print "$1 with q=$q\n";
 378     push @{ $pref{$q} }, lc $1;
 379   }
 380
 381   return # Read off %pref, in descending key order...
 382     map @{$pref{$_}},
 383     sort {$b <=> $a}
 384     keys %pref;
 385 }
 386
 387 ###########################################################################
 388
 389 my %tried = ();
 390   # memoization of whether we've used this module, or found it unusable.
 391
 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
 395
 396   my $module = $_[0];   # ASSUME sane module name!
 397   { no strict 'refs';
 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!
 401   }
 402
 403   print " About to use $module ...\n" if DEBUG;
 404   {
 405     local $SIG{'__DIE__'};
 406     eval "require $module"; # used to be "use $module", but no point in that.
 407   }
 408   if($@) {
 409     print "Error using $module \: $@\n" if DEBUG > 1;
 410     return $tried{$module} = 0;
 411   } else {
 412     print " OK, $module is used\n" if DEBUG;
 413     return $tried{$module} = 1;
 414   }
 415 }
 416
 417 #--------------------------------------------------------------------------
 418
 419 sub _lex_refs {  # report the lexicon references for this handle's class
 420   # returns an arrayREF!
 421   no strict 'refs';
 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!
 425
 426   my @lex_refs;
 427   my $seen_r = ref($_[1]) ? $_[1] : {};
 428
 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;
 433   }
 434
 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
 441   }
 442
 443   $isa_scan{$class} = \@lex_refs; # save for next time
 444   return \@lex_refs;
 445 }
 446
 447 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
 448
 449 ###########################################################################
 450 1;
 451
 452 __END__
 453
 454 HEY YOU!  You need some FOOD!
 455
 456
 457   ~~ Tangy Moroccan Carrot Salad ~~
 458
 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
 462 * 1 tablespoon honey
 463 * The juice of about a half a big lemon, or of a whole smaller one
 464 * 1/3 cup olive oil
 465 * 1 tablespoon of fresh dill, washed and chopped fine
 466 * Pinch of salt, maybe a pinch of pepper
 467
 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.
 470
 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.
 474
 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.
 477
 478 Serve warm or at room temperature.
 479
 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.
 484
 485 [end]