lib/Locale/Maketext.pm

   1
   2 # Time-stamp: "2004-03-30 16:33:31 AST"
   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 $MATCH_SUPERS_TIGHTLY);
   9 use Carp ();
  10 use I18N::LangTags 0.30 ();
  11
  12 #--------------------------------------------------------------------------
  13
  14 BEGIN { unless(defined &DEBUG) { *DEBUG = sub () {0} } }
  15  # define the constant 'DEBUG' at compile-time
  16
  17 $VERSION = "1.10_01";
  18 @ISA = ();
  19
  20 $MATCH_SUPERS = 1;
  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.
  27
  28 $USE_LITERALS = 1 unless defined $USE_LITERALS;
  29  # a hint for compiling bracket-notation things.
  30
  31 my %isa_scan = ();
  32
  33 ###########################################################################
  34
  35 sub quant {
  36   my($handle, $num, @forms) = @_;
  37
  38   return $num if @forms == 0; # what should this mean?
  39   return $forms[2] if @forms > 2 and $num == 0; # special zeroth case
  40
  41   # Normal 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.
  45 }
  46
  47
  48 sub numerate {
  49  # return this lexical item in a form appropriate to this number
  50   my($handle, $num, @forms) = @_;
  51   my $s = ($num == 1);
  52
  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];
  58   }
  59 }
  60
  61 #--------------------------------------------------------------------------
  62
  63 sub numf {
  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
  68   } else {
  69     $num = CORE::sprintf("%G", $num);
  70      # "CORE::" is there to avoid confusion with the above sub sprintf.
  71   }
  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.
  76
  77   $num =~ tr<.,><,.> if ref($handle) and $handle->{'numf_comma'};
  78    # This is just a lame hack instead of using Number::Format
  79   return $num;
  80 }
  81
  82 sub sprintf {
  83   no integer;
  84   my($handle, $format, @params) = @_;
  85   return CORE::sprintf($format, @params);
  86     # "CORE::" is there to avoid confusion with myself!
  87 }
  88
  89 #=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#=#
  90
  91 use integer; # vroom vroom... applies to the whole rest of the module
  92
  93 sub language_tag {
  94   my $it = ref($_[0]) || $_[0];
  95   return undef unless $it =~ m/([^':]+)(?:::)?$/s;
  96   $it = lc($1);
  97   $it =~ tr<_><->;
  98   return $it;
  99 }
 100
 101 sub encoding {
 102   my $it = $_[0];
 103   return(
 104    (ref($it) && $it->{'encoding'})
 105    || "iso-8859-1"   # Latin-1
 106   );
 107 }
 108
 109 #--------------------------------------------------------------------------
 110
 111 sub fallback_languages { return('i-default', 'en', 'en-US') }
 112
 113 sub fallback_language_classes { return () }
 114
 115 #--------------------------------------------------------------------------
 116
 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'};
 122 }
 123
 124 #--------------------------------------------------------------------------
 125
 126 sub failure_handler_auto {
 127   # Meant to be used like:
 128   #  $handle->fail_with('failure_handler_auto')
 129
 130   my($handle, $phrase, @params) = @_;
 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   {
 139     local $SIG{'__DIE__'};
 140     eval { $value = &$value($handle, @_) };
 141   }
 142   # If we make it here, there was an exception thrown in the
 143   #  call to $value, and so scream:
 144   if($@) {
 145     my $err = $@;
 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.
 153   } else {
 154     return $value;
 155   }
 156 }
 157
 158 #==========================================================================
 159
 160 sub new {
 161   # Nothing fancy!
 162   my $class = ref($_[0]) || $_[0];
 163   my $handle = bless {}, $class;
 164   $handle->init;
 165   return $handle;
 166 }
 167
 168 sub init { return } # no-op
 169
 170 ###########################################################################
 171
 172 sub maketext {
 173   # Remember, this can fail.  Failure is controllable many ways.
 174   Carp::croak "maketext requires at least one parameter" unless @_ > 1;
 175
 176   my($handle, $phrase) = splice(@_,0,2);
 177
 178   # Don't interefere with $@ in case that's being interpolated into the msg.
 179   local $@;
 180
 181   # Look up the value:
 182
 183   my $value;
 184   foreach my $h_r (
 185     @{  $isa_scan{ref($handle) || $handle} || $handle->_lex_refs  }
 186   ) {
 187     print "* Looking up \"$phrase\" in $h_r\n" if DEBUG;
 188     if(exists $h_r->{$phrase}) {
 189       print "  Found \"$phrase\" in $h_r\n" if DEBUG;
 190       unless(ref($value = $h_r->{$phrase})) {
 191         # Nonref means it's not yet compiled.  Compile and replace.
 192         $value = $h_r->{$phrase} = $handle->_compile($value);
 193       }
 194       last;
 195     } elsif($phrase !~ m/^_/s and $h_r->{'_AUTO'}) {
 196       # it's an auto lex, and this is an autoable key!
 197       print "  Automaking \"$phrase\" into $h_r\n" if DEBUG;
 198
 199       $value = $h_r->{$phrase} = $handle->_compile($phrase);
 200       last;
 201     }
 202     print "  Not found in $h_r, nor automakable\n" if DEBUG > 1;
 203     # else keep looking
 204   }
 205
 206   unless(defined($value)) {
 207     print "! Lookup of \"$phrase\" in/under ", ref($handle) || $handle,
 208       " fails.\n" if DEBUG;
 209     if(ref($handle) and $handle->{'fail'}) {
 210       print "WARNING0: maketext fails looking for <$phrase>\n" if DEBUG;
 211       my $fail;
 212       if(ref($fail = $handle->{'fail'}) eq 'CODE') { # it's a sub reference
 213         return &{$fail}($handle, $phrase, @_);
 214          # If it ever returns, it should return a good value.
 215       } else { # It's a method name
 216         return $handle->$fail($phrase, @_);
 217          # If it ever returns, it should return a good value.
 218       }
 219     } else {
 220       # All we know how to do is this;
 221       Carp::croak("maketext doesn't know how to say:\n$phrase\nas needed");
 222     }
 223   }
 224
 225   return $$value if ref($value) eq 'SCALAR';
 226   return $value unless ref($value) eq 'CODE';
 227
 228   {
 229     local $SIG{'__DIE__'};
 230     eval { $value = &$value($handle, @_) };
 231   }
 232   # If we make it here, there was an exception thrown in the
 233   #  call to $value, and so scream:
 234   if($@) {
 235     my $err = $@;
 236     # pretty up the error message
 237     $err =~ s<\s+at\s+\(eval\s+\d+\)\s+line\s+(\d+)\.?\n?>
 238              <\n in bracket code [compiled line $1],>s;
 239     #$err =~ s/\n?$/\n/s;
 240     Carp::croak "Error in maketexting \"$phrase\":\n$err as used";
 241     # Rather unexpected, but suppose that the sub tried calling
 242     # a method that didn't exist.
 243   } else {
 244     return $value;
 245   }
 246 }
 247
 248 ###########################################################################
 249
 250 sub get_handle {  # This is a constructor and, yes, it CAN FAIL.
 251   # Its class argument has to be the base class for the current
 252   # application's l10n files.
 253
 254   my($base_class, @languages) = @_;
 255   $base_class = ref($base_class) || $base_class;
 256    # Complain if they use __PACKAGE__ as a project base class?
 257
 258   if( @languages ) {
 259     DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 260     if($USING_LANGUAGE_TAGS) {   # An explicit language-list was given!
 261       @languages =
 262        map {; $_, I18N::LangTags::alternate_language_tags($_) }
 263         # Catch alternation
 264        map I18N::LangTags::locale2language_tag($_),
 265         # If it's a lg tag, fine, pass thru (untainted)
 266         # If it's a locale ID, try converting to a lg tag (untainted),
 267         # otherwise nix it.
 268        @languages;
 269       DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 270     }
 271   } else {
 272     @languages = $base_class->_ambient_langprefs;
 273   }
 274
 275   @languages = $base_class->_langtag_munging(@languages);
 276
 277   my %seen;
 278   foreach my $module_name ( map { $base_class . "::" . $_ }  @languages ) {
 279     next unless length $module_name; # sanity
 280     next if $seen{$module_name}++        # Already been here, and it was no-go
 281             || !&_try_use($module_name); # Try to use() it, but can't it.
 282     return($module_name->new); # Make it!
 283   }
 284
 285   return undef; # Fail!
 286 }
 287
 288 ###########################################################################
 289
 290 sub _langtag_munging {
 291   my($base_class, @languages) = @_;
 292
 293   # We have all these DEBUG statements because otherwise it's hard as hell
 294   # to diagnose ifwhen something goes wrong.
 295
 296   DEBUG and print "Lgs1: ", map("<$_>", @languages), "\n";
 297
 298   if($USING_LANGUAGE_TAGS) {
 299     DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 300     @languages     = $base_class->_add_supers( @languages );
 301
 302     push @languages, I18N::LangTags::panic_languages(@languages);
 303     DEBUG and print "After adding panic languages:\n",
 304       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 305
 306     push @languages, $base_class->fallback_languages;
 307      # You are free to override fallback_languages to return empty-list!
 308     DEBUG and print "Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 309
 310     @languages =  # final bit of processing to turn them into classname things
 311       map {
 312         my $it = $_;  # copy
 313         $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
 314         $it =~ tr<_a-z0-9><>cd;  # remove all but a-z0-9_
 315         $it;
 316       } @languages
 317     ;
 318     DEBUG and print "Nearing end of munging:\n",
 319       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 320   } else {
 321     DEBUG and print "Bypassing language-tags.\n",
 322       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 323   }
 324
 325   DEBUG and print "Before adding fallback classes:\n",
 326     " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 327
 328   push @languages, $base_class->fallback_language_classes;
 329    # You are free to override that to return whatever.
 330
 331   DEBUG and print "Finally:\n",
 332     " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 333
 334   return @languages;
 335 }
 336
 337 ###########################################################################
 338
 339 sub _ambient_langprefs {
 340   require I18N::LangTags::Detect;
 341   return  I18N::LangTags::Detect::detect();
 342 }
 343
 344 ###########################################################################
 345
 346 sub _add_supers {
 347   my($base_class, @languages) = @_;
 348
 349   if(!$MATCH_SUPERS) {
 350     # Nothing
 351     DEBUG and print "Bypassing any super-matching.\n",
 352       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 353
 354   } elsif( $MATCH_SUPERS_TIGHTLY ) {
 355     DEBUG and print "Before adding new supers tightly:\n",
 356       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 357     @languages = I18N::LangTags::implicate_supers( @languages );
 358     DEBUG and print "After adding new supers tightly:\n",
 359       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 360
 361   } else {
 362     DEBUG and print "Before adding supers to end:\n",
 363       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 364     @languages = I18N::LangTags::implicate_supers_strictly( @languages );
 365     DEBUG and print "After adding supers to end:\n",
 366       " Lgs\@", __LINE__, ": ", map("<$_>", @languages), "\n";
 367   }
 368
 369   return @languages;
 370 }
 371
 372 ###########################################################################
 373 #
 374 # This is where most people should stop reading.
 375 #
 376 ###########################################################################
 377
 378 use Locale::Maketext::GutsLoader;
 379
 380 ###########################################################################
 381
 382 my %tried = ();
 383   # memoization of whether we've used this module, or found it unusable.
 384
 385 sub _try_use {   # Basically a wrapper around "require Modulename"
 386   # "Many men have tried..."  "They tried and failed?"  "They tried and died."
 387   return $tried{$_[0]} if exists $tried{$_[0]};  # memoization
 388
 389   my $module = $_[0];   # ASSUME sane module name!
 390   { no strict 'refs';
 391     return($tried{$module} = 1)
 392      if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
 393     # weird case: we never use'd it, but there it is!
 394   }
 395
 396   print " About to use $module ...\n" if DEBUG;
 397   {
 398     local $SIG{'__DIE__'};
 399     eval "require $module"; # used to be "use $module", but no point in that.
 400   }
 401   if($@) {
 402     print "Error using $module \: $@\n" if DEBUG > 1;
 403     return $tried{$module} = 0;
 404   } else {
 405     print " OK, $module is used\n" if DEBUG;
 406     return $tried{$module} = 1;
 407   }
 408 }
 409
 410 #--------------------------------------------------------------------------
 411
 412 sub _lex_refs {  # report the lexicon references for this handle's class
 413   # returns an arrayREF!
 414   no strict 'refs';
 415   my $class = ref($_[0]) || $_[0];
 416   print "Lex refs lookup on $class\n" if DEBUG > 1;
 417   return $isa_scan{$class} if exists $isa_scan{$class};  # memoization!
 418
 419   my @lex_refs;
 420   my $seen_r = ref($_[1]) ? $_[1] : {};
 421
 422   if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
 423     push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
 424     print "%" . $class . "::Lexicon contains ",
 425          scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
 426   }
 427
 428   # Implements depth(height?)-first recursive searching of superclasses.
 429   # In hindsight, I suppose I could have just used Class::ISA!
 430   foreach my $superclass (@{$class . "::ISA"}) {
 431     print " Super-class search into $superclass\n" if DEBUG;
 432     next if $seen_r->{$superclass}++;
 433     push @lex_refs, @{&_lex_refs($superclass, $seen_r)};  # call myself
 434   }
 435
 436   $isa_scan{$class} = \@lex_refs; # save for next time
 437   return \@lex_refs;
 438 }
 439
 440 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
 441
 442 ###########################################################################
 443 1;
 444
 445 __END__
 446
 447 HEY YOU!  You need some FOOD!
 448
 449
 450   ~~ Tangy Moroccan Carrot Salad ~~
 451
 452 * 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
 453 * 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
 454 * 1 tablespoon ground cumin
 455 * 1 tablespoon honey
 456 * The juice of about a half a big lemon, or of a whole smaller one
 457 * 1/3 cup olive oil
 458 * 1 tablespoon of fresh dill, washed and chopped fine
 459 * Pinch of salt, maybe a pinch of pepper
 460
 461 Cook the carrots in a pot of boiling water until just tender -- roughly
 462 six minutes.  (Just don't let them get mushy!)  Drain the carrots.
 463
 464 In a largish bowl, combine the lemon juice, the cumin, the chile
 465 powder, and the honey.  Mix well.
 466 Add the olive oil and whisk it together well.  Add the dill and stir.
 467
 468 Add the warm carrots to the bowl and toss it all to coat the carrots
 469 well.  Season with salt and pepper, to taste.
 470
 471 Serve warm or at room temperature.
 472
 473 The measurements here are very approximate, and you should feel free to
 474 improvise and experiment.  It's a very forgiving recipe.  For example,
 475 you could easily halve or double the amount of cumin, or use chopped mint
 476 leaves instead of dill, or lime juice instead of lemon, et cetera.
 477
 478 [end]
 479