lib/Locale/Maketext.pm

   1
   2 # Time-stamp: "2003-04-02 11:04:55 AHST"
   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.04";
  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 sub _http_accept_langs {
 332   # Deal with HTTP "Accept-Language:" stuff.  Hassle.
 333   # This code is more lenient than RFC 3282, which you must read.
 334   # Hm.  Should I just move this into I18N::LangTags at some point?
 335   no integer;
 336
 337   my $in = (@_ > 1) ? $_[1] : $ENV{'HTTP_ACCEPT_LANGUAGE'};
 338   # (always ends up untainting)
 339
 340   return() unless defined $in and length $in;
 341
 342   $in =~ s/\([^\)]*\)//g; # nix just about any comment
 343
 344   if( $in =~ m/^\s*([a-zA-Z][-a-zA-Z]+)\s*$/s ) {
 345     # Very common case: just one language tag
 346     return lc $1;
 347   } elsif( $in =~ m/^\s*[a-zA-Z][-a-zA-Z]+(?:\s*,\s*[a-zA-Z][-a-zA-Z]+)*\s*$/s ) {
 348     # Common case these days: just "foo, bar, baz"
 349     return map lc($_), $in =~ m/([a-zA-Z][-a-zA-Z]+)/g;
 350   }
 351
 352   # Else it's complicated...
 353
 354   $in =~ s/\s+//g;  # Yes, we can just do without the WS!
 355   my @in = $in =~ m/([^,]+)/g;
 356   my %pref;
 357
 358   my $q;
 359   foreach my $tag (@in) {
 360     next unless $tag =~
 361      m/^([a-zA-Z][-a-zA-Z]+)
 362         (?:
 363          ;q=
 364          (
 365           \d*   # a bit too broad of a RE, but so what.
 366           (?:
 367             \.\d+
 368           )?
 369          )
 370         )?
 371        $
 372       /sx
 373     ;
 374     $q = (defined $2 and length $2) ? $2 : 1;
 375     #print "$1 with q=$q\n";
 376     push @{ $pref{$q} }, lc $1;
 377   }
 378
 379   return # Read off %pref, in descending key order...
 380     map @{$pref{$_}},
 381     sort {$b <=> $a}
 382     keys %pref;
 383 }
 384
 385 ###########################################################################
 386
 387 sub _compile {
 388   # This big scarp routine compiles an entry.
 389   # It returns either a coderef if there's brackety bits in this, or
 390   #  otherwise a ref to a scalar.
 391
 392   my $target = ref($_[0]) || $_[0];
 393
 394   my(@code);
 395   my(@c) = (''); # "chunks" -- scratch.
 396   my $call_count = 0;
 397   my $big_pile = '';
 398   {
 399     my $in_group = 0; # start out outside a group
 400     my($m, @params); # scratch
 401
 402     while($_[1] =~  # Iterate over chunks.
 403      m<\G(
 404        [^\~\[\]]+  # non-~[] stuff
 405        |
 406        ~.       # ~[, ~], ~~, ~other
 407        |
 408        \[          # [ presumably opening a group
 409        |
 410        \]          # ] presumably closing a group
 411        |
 412        ~           # terminal ~ ?
 413        |
 414        $
 415      )>xgs
 416     ) {
 417       print "  \"$1\"\n" if DEBUG > 2;
 418
 419       if($1 eq '[' or $1 eq '') {       # "[" or end
 420         # Whether this is "[" or end, force processing of any
 421         #  preceding literal.
 422         if($in_group) {
 423           if($1 eq '') {
 424             $target->_die_pointing($_[1], "Unterminated bracket group");
 425           } else {
 426             $target->_die_pointing($_[1], "You can't nest bracket groups");
 427           }
 428         } else {
 429           if($1 eq '') {
 430             print "   [end-string]\n" if DEBUG > 2;
 431           } else {
 432             $in_group = 1;
 433           }
 434           die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
 435           if(length $c[-1]) {
 436             # Now actually processing the preceding literal
 437             $big_pile .= $c[-1];
 438             if($USE_LITERALS and (
 439               (ord('A') == 65)
 440                ? $c[-1] !~ m<[^\x20-\x7E]>s
 441                   # ASCII very safe chars
 442                : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
 443                   # EBCDIC very safe chars
 444             )) {
 445               # normal case -- all very safe chars
 446               $c[-1] =~ s/'/\\'/g;
 447               push @code, q{ '} . $c[-1] . "',\n";
 448               $c[-1] = ''; # reuse this slot
 449             } else {
 450               push @code, ' $c[' . $#c . "],\n";
 451               push @c, ''; # new chunk
 452             }
 453           }
 454            # else just ignore the empty string.
 455         }
 456
 457       } elsif($1 eq ']') {  # "]"
 458         # close group -- go back in-band
 459         if($in_group) {
 460           $in_group = 0;
 461
 462           print "   --Closing group [$c[-1]]\n" if DEBUG > 2;
 463
 464           # And now process the group...
 465
 466           if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
 467             DEBUG > 2 and print "   -- (Ignoring)\n";
 468             $c[-1] = ''; # reset out chink
 469             next;
 470           }
 471
 472            #$c[-1] =~ s/^\s+//s;
 473            #$c[-1] =~ s/\s+$//s;
 474           ($m,@params) = split(",", $c[-1], -1);  # was /\s*,\s*/
 475
 476           # A bit of a hack -- we've turned "~,"'s into DELs, so turn
 477           #  'em into real commas here.
 478           if (ord('A') == 65) { # ASCII, etc
 479             foreach($m, @params) { tr/\x7F/,/ }
 480           } else {              # EBCDIC (1047, 0037, POSIX-BC)
 481             # Thanks to Peter Prymmer for the EBCDIC handling
 482             foreach($m, @params) { tr/\x07/,/ }
 483           }
 484
 485           # Special-case handling of some method names:
 486           if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
 487             # Treat [_1,...] as [,_1,...], etc.
 488             unshift @params, $m;
 489             $m = '';
 490           } elsif($m eq '*') {
 491             $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
 492           } elsif($m eq '#') {
 493             $m = 'numf';  # "#" for "number": [#,_1] for "the number _1"
 494           }
 495
 496           # Most common case: a simple, legal-looking method name
 497           if($m eq '') {
 498             # 0-length method name means to just interpolate:
 499             push @code, ' (';
 500           } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
 501             and $m !~ m<(?:^|\:)\d>s
 502              # exclude starting a (sub)package or symbol with a digit
 503           ) {
 504             # Yes, it even supports the demented (and undocumented?)
 505             #  $obj->Foo::bar(...) syntax.
 506             $target->_die_pointing(
 507               $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
 508               2 + length($c[-1])
 509             )
 510              if $m =~ m/^SUPER::/s;
 511               # Because for SUPER:: to work, we'd have to compile this into
 512               #  the right package, and that seems just not worth the bother,
 513               #  unless someone convinces me otherwise.
 514
 515             push @code, ' $_[0]->' . $m . '(';
 516           } else {
 517             # TODO: implement something?  or just too icky to consider?
 518             $target->_die_pointing(
 519              $_[1],
 520              "Can't use \"$m\" as a method name in bracket group",
 521              2 + length($c[-1])
 522             );
 523           }
 524
 525           pop @c; # we don't need that chunk anymore
 526           ++$call_count;
 527
 528           foreach my $p (@params) {
 529             if($p eq '_*') {
 530               # Meaning: all parameters except $_[0]
 531               $code[-1] .= ' @_[1 .. $#_], ';
 532                # and yes, that does the right thing for all @_ < 3
 533             } elsif($p =~ m<^_(-?\d+)$>s) {
 534               # _3 meaning $_[3]
 535               $code[-1] .= '$_[' . (0 + $1) . '], ';
 536             } elsif($USE_LITERALS and (
 537               (ord('A') == 65)
 538                ? $p !~ m<[^\x20-\x7E]>s
 539                   # ASCII very safe chars
 540                : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
 541                   # EBCDIC very safe chars
 542             )) {
 543               # Normal case: a literal containing only safe characters
 544               $p =~ s/'/\\'/g;
 545               $code[-1] .= q{'} . $p . q{', };
 546             } else {
 547               # Stow it on the chunk-stack, and just refer to that.
 548               push @c, $p;
 549               push @code, ' $c[' . $#c . "], ";
 550             }
 551           }
 552           $code[-1] .= "),\n";
 553
 554           push @c, '';
 555         } else {
 556           $target->_die_pointing($_[1], "Unbalanced ']'");
 557         }
 558
 559       } elsif(substr($1,0,1) ne '~') {
 560         # it's stuff not containing "~" or "[" or "]"
 561         # i.e., a literal blob
 562         $c[-1] .= $1;
 563
 564       } elsif($1 eq '~~') { # "~~"
 565         $c[-1] .= '~';
 566
 567       } elsif($1 eq '~[') { # "~["
 568         $c[-1] .= '[';
 569
 570       } elsif($1 eq '~]') { # "~]"
 571         $c[-1] .= ']';
 572
 573       } elsif($1 eq '~,') { # "~,"
 574         if($in_group) {
 575           # This is a hack, based on the assumption that no-one will actually
 576           # want a DEL inside a bracket group.  Let's hope that's it's true.
 577           if (ord('A') == 65) { # ASCII etc
 578             $c[-1] .= "\x7F";
 579           } else {              # EBCDIC (cp 1047, 0037, POSIX-BC)
 580             $c[-1] .= "\x07";
 581           }
 582         } else {
 583           $c[-1] .= '~,';
 584         }
 585
 586       } elsif($1 eq '~') { # possible only at string-end, it seems.
 587         $c[-1] .= '~';
 588
 589       } else {
 590         # It's a "~X" where X is not a special character.
 591         # Consider it a literal ~ and X.
 592         $c[-1] .= $1;
 593       }
 594     }
 595   }
 596
 597   if($call_count) {
 598     undef $big_pile; # Well, nevermind that.
 599   } else {
 600     # It's all literals!  Ahwell, that can happen.
 601     # So don't bother with the eval.  Return a SCALAR reference.
 602     return \$big_pile;
 603   }
 604
 605   die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
 606   print scalar(@c), " chunks under closure\n" if DEBUG;
 607   if(@code == 0) { # not possible?
 608     print "Empty code\n" if DEBUG;
 609     return \'';
 610   } elsif(@code > 1) { # most cases, presumably!
 611     unshift @code, "join '',\n";
 612   }
 613   unshift @code, "use strict; sub {\n";
 614   push @code, "}\n";
 615
 616   print @code if DEBUG;
 617   my $sub = eval(join '', @code);
 618   die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
 619   return $sub;
 620 }
 621
 622 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 623
 624 sub _die_pointing {
 625   # This is used by _compile to throw a fatal error
 626   my $target = shift; # class name
 627   # ...leaving $_[0] the error-causing text, and $_[1] the error message
 628
 629   my $i = index($_[0], "\n");
 630
 631   my $pointy;
 632   my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
 633   if($pos < 1) {
 634     $pointy = "^=== near there\n";
 635   } else { # we need to space over
 636     my $first_tab = index($_[0], "\t");
 637     if($pos > 2 and ( -1 == $first_tab  or  $first_tab > pos($_[0]))) {
 638       # No tabs, or the first tab is harmlessly after where we will point to,
 639       # AND we're far enough from the margin that we can draw a proper arrow.
 640       $pointy = ('=' x $pos) . "^ near there\n";
 641     } else {
 642       # tabs screw everything up!
 643       $pointy = substr($_[0],0,$pos);
 644       $pointy =~ tr/\t //cd;
 645        # make everything into whitespace, but preseving tabs
 646       $pointy .= "^=== near there\n";
 647     }
 648   }
 649
 650   my $errmsg = "$_[1], in\:\n$_[0]";
 651
 652   if($i == -1) {
 653     # No newline.
 654     $errmsg .= "\n" . $pointy;
 655   } elsif($i == (length($_[0]) - 1)  ) {
 656     # Already has a newline at end.
 657     $errmsg .= $pointy;
 658   } else {
 659     # don't bother with the pointy bit, I guess.
 660   }
 661   Carp::croak( "$errmsg via $target, as used" );
 662 }
 663
 664 ###########################################################################
 665
 666 my %tried = ();
 667   # memoization of whether we've used this module, or found it unusable.
 668
 669 sub _try_use {   # Basically a wrapper around "require Modulename"
 670   # "Many men have tried..."  "They tried and failed?"  "They tried and died."
 671   return $tried{$_[0]} if exists $tried{$_[0]};  # memoization
 672
 673   my $module = $_[0];   # ASSUME sane module name!
 674   { no strict 'refs';
 675     return($tried{$module} = 1)
 676      if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
 677     # weird case: we never use'd it, but there it is!
 678   }
 679
 680   print " About to use $module ...\n" if DEBUG;
 681   {
 682     local $SIG{'__DIE__'};
 683     eval "require $module"; # used to be "use $module", but no point in that.
 684   }
 685   if($@) {
 686     print "Error using $module \: $@\n" if DEBUG > 1;
 687     return $tried{$module} = 0;
 688   } else {
 689     print " OK, $module is used\n" if DEBUG;
 690     return $tried{$module} = 1;
 691   }
 692 }
 693
 694 #--------------------------------------------------------------------------
 695
 696 sub _lex_refs {  # report the lexicon references for this handle's class
 697   # returns an arrayREF!
 698   no strict 'refs';
 699   my $class = ref($_[0]) || $_[0];
 700   print "Lex refs lookup on $class\n" if DEBUG > 1;
 701   return $isa_scan{$class} if exists $isa_scan{$class};  # memoization!
 702
 703   my @lex_refs;
 704   my $seen_r = ref($_[1]) ? $_[1] : {};
 705
 706   if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
 707     push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
 708     print "%" . $class . "::Lexicon contains ",
 709          scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
 710   }
 711
 712   # Implements depth(height?)-first recursive searching of superclasses.
 713   # In hindsight, I suppose I could have just used Class::ISA!
 714   foreach my $superclass (@{$class . "::ISA"}) {
 715     print " Super-class search into $superclass\n" if DEBUG;
 716     next if $seen_r->{$superclass}++;
 717     push @lex_refs, @{&_lex_refs($superclass, $seen_r)};  # call myself
 718   }
 719
 720   $isa_scan{$class} = \@lex_refs; # save for next time
 721   return \@lex_refs;
 722 }
 723
 724 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
 725
 726 ###########################################################################
 727 1;
 728
 729 __END__
 730
 731 HEY YOU!  You need some FOOD!
 732
 733
 734   ~~ Tangy Moroccan Carrot Salad ~~
 735
 736 * 6 to 8 medium carrots, peeled and then sliced in 1/4-inch rounds
 737 * 1/4 teaspoon chile powder (cayenne, chipotle, ancho, or the like)
 738 * 1 tablespoon ground cumin
 739 * 1 tablespoon honey
 740 * The juice of about a half a big lemon, or of a whole smaller one
 741 * 1/3 cup olive oil
 742 * 1 tablespoon of fresh dill, washed and chopped fine
 743 * Pinch of salt, maybe a pinch of pepper
 744
 745 Cook the carrots in a pot of boiling water until just tender -- roughly
 746 six minutes.  (Just don't let them get mushy!)  Drain the carrots.
 747
 748 In a largish bowl, combine the lemon juice, the cumin, the chile
 749 powder, and the honey.  Mix well.
 750 Add the olive oil and whisk it together well.  Add the dill and stir.
 751
 752 Add the warm carrots to the bowl and toss it all to coat the carrots
 753 well.  Season with salt and pepper, to taste.
 754
 755 Serve warm or at room temperature.
 756
 757 The measurements here are very approximate, and you should feel free to
 758 improvise and experiment.  It's a very forgiving recipe.  For example,
 759 you could easily halve or double the amount of cumin, or use chopped mint
 760 leaves instead of dill, or lime juice instead of lemon, et cetera.
 761
 762 [end]