lib/Locale/Maketext.pm

   1
   2 # Time-stamp: "2001-05-25 07:49:06 MDT"
   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.01";
  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       my $in = $ENV{'HTTP_ACCEPT_LANGUAGE'} || '';
 256         # supposedly that works under mod_perl, too.
 257       $in =~ s<\([\)]*\)><>g; # Kill parens'd things -- just a hack.
 258       @languages = &I18N::LangTags::extract_language_tags($in) if length $in;
 259         # ...which untaints, incidentally.
 260
 261     } else { # Not running as a CGI: try to puzzle out from the environment
 262       if(length( $ENV{'LANG'} || '' )) {
 263         push @languages, split m/[,:]/, $ENV{'LANG'};
 264          # LANG can be only /one/ locale as far as I know, but what the hey.
 265       }
 266       if(length( $ENV{'LANGUAGE'} || '' )) {
 267         push @languages, split m/[,:]/, $ENV{'LANGUAGE'};
 268       }
 269       print "Noting ENV LANG ", join(',', @languages),"\n" if DEBUG;
 270       # Those are really locale IDs, but they get xlated a few lines down.
 271
 272       if(&_try_use('Win32::Locale')) {
 273         # If we have that module installed...
 274         push @languages, Win32::Locale::get_language()
 275          if defined &Win32::Locale::get_language;
 276       }
 277     }
 278   }
 279
 280   #------------------------------------------------------------------------
 281   print "Lgs1: ", map("<$_>", @languages), "\n" if DEBUG;
 282
 283   if($USING_LANGUAGE_TAGS) {
 284     @languages = map &I18N::LangTags::locale2language_tag($_), @languages;
 285      # if it's a lg tag, fine, pass thru (untainted)
 286      # if it's a locale ID, try converting to a lg tag (untainted),
 287      # otherwise nix it.
 288
 289     push @languages, map &I18N::LangTags::super_languages($_), @languages
 290      if $MATCH_SUPERS;
 291
 292     @languages =  map { $_, &I18N::LangTags::alternate_language_tags($_) }
 293                       @languages;    # catch alternation
 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 sub _compile {
 332   # This big scarp routine compiles an entry.
 333   # It returns either a coderef if there's brackety bits in this, or
 334   #  otherwise a ref to a scalar.
 335
 336   my $target = ref($_[0]) || $_[0];
 337
 338   my(@code);
 339   my(@c) = (''); # "chunks" -- scratch.
 340   my $call_count = 0;
 341   my $big_pile = '';
 342   {
 343     my $in_group = 0; # start out outside a group
 344     my($m, @params); # scratch
 345
 346     while($_[1] =~  # Iterate over chunks.
 347      m<\G(
 348        [^\~\[\]]+  # non-~[] stuff
 349        |
 350        ~.       # ~[, ~], ~~, ~other
 351        |
 352        \x5B        # [
 353        |
 354        \x5D        # ]
 355        |
 356        ~           # terminal ~?
 357        |
 358        $
 359      )>xgs
 360     ) {
 361       print "  \"$1\"\n" if DEBUG > 2;
 362
 363       if($1 eq '[' or $1 eq '') {       # "[" or end
 364         # Whether this is "[" or end, force processing of any
 365         #  preceding literal.
 366         if($in_group) {
 367           if($1 eq '') {
 368             $target->_die_pointing($_[1], "Unterminated bracket group");
 369           } else {
 370             $target->_die_pointing($_[1], "You can't nest bracket groups");
 371           }
 372         } else {
 373           if($1 eq '') {
 374             print "   [end-string]\n" if DEBUG > 2;
 375           } else {
 376             $in_group = 1;
 377           }
 378           die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
 379           if(length $c[-1]) {
 380             # Now actually processing the preceding literal
 381             $big_pile .= $c[-1];
 382             if($USE_LITERALS and $c[-1] !~ m<[^\x20-\x7E]>s) {
 383               # normal case -- all very safe chars
 384               $c[-1] =~ s/'/\\'/g;
 385               push @code, q{ '} . $c[-1] . "',\n";
 386               $c[-1] = ''; # reuse this slot
 387             } else {
 388               push @code, ' $c[' . $#c . "],\n";
 389               push @c, ''; # new chunk
 390             }
 391           }
 392            # else just ignore the empty string.
 393         }
 394
 395       } elsif($1 eq ']') {  # "]"
 396         # close group -- go back in-band
 397         if($in_group) {
 398           $in_group = 0;
 399
 400           print "   --Closing group [$c[-1]]\n" if DEBUG > 2;
 401
 402           # And now process the group...
 403
 404           if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
 405             DEBUG > 2 and print "   -- (Ignoring)\n";
 406             $c[-1] = ''; # reset out chink
 407             next;
 408           }
 409
 410            #$c[-1] =~ s/^\s+//s;
 411            #$c[-1] =~ s/\s+$//s;
 412           ($m,@params) = split(",", $c[-1], -1);  # was /\s*,\s*/
 413
 414           foreach($m, @params) { tr/\x7F/,/ }
 415            # A bit of a hack -- we've turned "~,"'s into \x7F's, so turn
 416            #  'em into real commas here.
 417
 418           if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
 419             # Treat [_1,...] as [,_1,...], etc.
 420             unshift @params, $m;
 421             $m = '';
 422           }
 423
 424           # Most common case: a simple, legal-looking method name
 425           if($m eq '') {
 426             # 0-length method name means to just interpolate:
 427             push @code, ' (';
 428           } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
 429             and $m !~ m<(?:^|\:)\d>s
 430              # exclude starting a (sub)package or symbol with a digit
 431           ) {
 432             # Yes, it even supports the demented (and undocumented?)
 433             #  $obj->Foo::bar(...) syntax.
 434             $target->_die_pointing(
 435               $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
 436               2 + length($c[-1])
 437             )
 438              if $m =~ m/^SUPER::/s;
 439               # Because for SUPER:: to work, we'd have to compile this into
 440               #  the right package, and that seems just not worth the bother,
 441               #  unless someone convinces me otherwise.
 442
 443             push @code, ' $_[0]->' . $m . '(';
 444           } else {
 445             # TODO: implement something?  or just too icky to consider?
 446             $target->_die_pointing(
 447              $_[1],
 448              "Can't use \"$m\" as a method name in bracket group",
 449              2 + length($c[-1])
 450             );
 451           }
 452
 453           pop @c; # we don't need that chunk anymore
 454           ++$call_count;
 455
 456           foreach my $p (@params) {
 457             if($p eq '_*') {
 458               # Meaning: all parameters except $_[0]
 459               $code[-1] .= ' @_[1 .. $#_], ';
 460                # and yes, that does the right thing for all @_ < 3
 461             } elsif($p =~ m<^_(-?\d+)$>s) {
 462               # _3 meaning $_[3]
 463               $code[-1] .= '$_[' . (0 + $1) . '], ';
 464             } elsif($USE_LITERALS and $p !~ m<[^\x20-\x7E]>s) {
 465               # Normal case: a literal containing only safe characters
 466               $p =~ s/'/\\'/g;
 467               $code[-1] .= q{'} . $p . q{', };
 468             } else {
 469               # Stow it on the chunk-stack, and just refer to that.
 470               push @c, $p;
 471               push @code, ' $c[' . $#c . "], ";
 472             }
 473           }
 474           $code[-1] .= "),\n";
 475
 476           push @c, '';
 477         } else {
 478           $target->_die_pointing($_[1], "Unbalanced ']'");
 479         }
 480
 481       } elsif(substr($1,0,1) ne '~') {
 482         # it's stuff not containing "~" or "[" or "]"
 483         # i.e., a literal blob
 484         $c[-1] .= $1;
 485
 486       } elsif($1 eq '~~') { # "~~"
 487         $c[-1] .= '~';
 488
 489       } elsif($1 eq '~[') { # "~["
 490         $c[-1] .= '[';
 491
 492       } elsif($1 eq '~]') { # "~]"
 493         $c[-1] .= ']';
 494
 495       } elsif($1 eq '~,') { # "~,"
 496         if($in_group) {
 497           $c[-1] .= "\x7F";
 498            # This is a hack, based on the assumption that no-one will actually
 499            # want a \x7f inside a bracket group.  Let's hope that's it's true.
 500         } else {
 501           $c[-1] .= '~,';
 502         }
 503
 504       } elsif($1 eq '~') { # possible only at string-end, it seems.
 505         $c[-1] .= '~';
 506
 507       } else {
 508         # It's a "~X" where X is not a special character.
 509         # Consider it a literal ~ and X.
 510         $c[-1] .= $1;
 511       }
 512     }
 513   }
 514
 515   if($call_count) {
 516     undef $big_pile; # Well, nevermind that.
 517   } else {
 518     # It's all literals!  Ahwell, that can happen.
 519     # So don't bother with the eval.  Return a SCALAR reference.
 520     return \$big_pile;
 521   }
 522
 523   die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
 524   print scalar(@c), " chunks under closure\n" if DEBUG;
 525   if(@code == 0) { # not possible?
 526     print "Empty code\n" if DEBUG;
 527     return \'';
 528   } elsif(@code > 1) { # most cases, presumably!
 529     unshift @code, "join '',\n";
 530   }
 531   unshift @code, "use strict; sub {\n";
 532   push @code, "}\n";
 533
 534   print @code if DEBUG;
 535   my $sub = eval(join '', @code);
 536   die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
 537   return $sub;
 538 }
 539
 540 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 541
 542 sub _die_pointing {
 543   # This is used by _compile to throw a fatal error
 544   my $target = shift; # class name
 545   # ...leaving $_[0] the error-causing text, and $_[1] the error message
 546
 547   my $i = index($_[0], "\n");
 548
 549   my $pointy;
 550   my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
 551   if($pos < 1) {
 552     $pointy = "^=== near there\n";
 553   } else { # we need to space over
 554     my $first_tab = index($_[0], "\t");
 555     if($pos > 2 and ( -1 == $first_tab  or  $first_tab > pos($_[0]))) {
 556       # No tabs, or the first tab is harmlessly after where we will point to,
 557       # AND we're far enough from the margin that we can draw a proper arrow.
 558       $pointy = ('=' x $pos) . "^ near there\n";
 559     } else {
 560       # tabs screw everything up!
 561       $pointy = substr($_[0],0,$pos);
 562       $pointy =~ tr/\t //cd;
 563        # make everything into whitespace, but preseving tabs
 564       $pointy .= "^=== near there\n";
 565     }
 566   }
 567
 568   my $errmsg = "$_[1], in\:\n$_[0]";
 569
 570   if($i == -1) {
 571     # No newline.
 572     $errmsg .= "\n" . $pointy;
 573   } elsif($i == (length($_[0]) - 1)  ) {
 574     # Already has a newline at end.
 575     $errmsg .= $pointy;
 576   } else {
 577     # don't bother with the pointy bit, I guess.
 578   }
 579   Carp::croak( "$errmsg via $target, as used" );
 580 }
 581
 582 ###########################################################################
 583
 584 my %tried = ();
 585   # memoization of whether we've used this module, or found it unusable.
 586
 587 sub _try_use {   # Basically a wrapper around "require Modulename"
 588   # "Many men have tried..."  "They tried and failed?"  "They tried and died."
 589   return $tried{$_[0]} if exists $tried{$_[0]};  # memoization
 590
 591   my $module = $_[0];   # ASSUME sane module name!
 592   { no strict 'refs';
 593     return($tried{$module} = 1)
 594      if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
 595     # weird case: we never use'd it, but there it is!
 596   }
 597
 598   print " About to use $module ...\n" if DEBUG;
 599   {
 600     local $SIG{'__DIE__'};
 601     eval "require $module"; # used to be "use $module", but no point in that.
 602   }
 603   if($@) {
 604     print "Error using $module \: $@\n" if DEBUG > 1;
 605     return $tried{$module} = 0;
 606   } else {
 607     print " OK, $module is used\n" if DEBUG;
 608     return $tried{$module} = 1;
 609   }
 610 }
 611
 612 #--------------------------------------------------------------------------
 613
 614 sub _lex_refs {  # report the lexicon references for this handle's class
 615   # returns an arrayREF!
 616   no strict 'refs';
 617   my $class = ref($_[0]) || $_[0];
 618   print "Lex refs lookup on $class\n" if DEBUG > 1;
 619   return $isa_scan{$class} if exists $isa_scan{$class};  # memoization!
 620
 621   my @lex_refs;
 622   my $seen_r = ref($_[1]) ? $_[1] : {};
 623
 624   if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
 625     push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
 626     print "%" . $class . "::Lexicon contains ",
 627          scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
 628   }
 629
 630   # Implements depth(height?)-first recursive searching of superclasses
 631   foreach my $superclass (@{$class . "::ISA"}) {
 632     print " Super-class search into $superclass\n" if DEBUG;
 633     next if $seen_r->{$superclass}++;
 634     push @lex_refs, @{&_lex_refs($superclass, $seen_r)};  # call myself
 635   }
 636
 637   $isa_scan{$class} = \@lex_refs; # save for next time
 638   return \@lex_refs;
 639 }
 640
 641 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
 642
 643 ###########################################################################
 644 1;
 645
 646