lib/Locale/Maketext.pm

   1
   2 # Time-stamp: "2001-06-21 23:09:33 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.03";
  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, I18N::LangTags::panic_languages(@languages)
 296       if defined &I18N::LangTags::panic_languages;
 297
 298     push @languages, $base_class->fallback_languages;
 299      # You are free to override fallback_languages to return empty-list!
 300
 301     @languages =  # final bit of processing:
 302       map {
 303         my $it = $_;  # copy
 304         $it =~ tr<-A-Z><_a-z>; # lc, and turn - to _
 305         $it =~ tr<_a-z0-9><>cd;  # remove all but a-z0-9_
 306         $it;
 307       } @languages
 308     ;
 309   }
 310   print "Lgs2: ", map("<$_>", @languages), "\n" if DEBUG > 1;
 311
 312   push @languages, $base_class->fallback_language_classes;
 313    # You are free to override that to return whatever.
 314
 315
 316   my %seen = ();
 317   foreach my $module_name ( map { $base_class . "::" . $_ }  @languages )
 318   {
 319     next unless length $module_name; # sanity
 320     next if $seen{$module_name}++        # Already been here, and it was no-go
 321             || !&_try_use($module_name); # Try to use() it, but can't it.
 322     return($module_name->new); # Make it!
 323   }
 324
 325   return undef; # Fail!
 326 }
 327
 328 ###########################################################################
 329 #
 330 # This is where most people should stop reading.
 331 #
 332 ###########################################################################
 333
 334 sub _compile {
 335   # This big scarp routine compiles an entry.
 336   # It returns either a coderef if there's brackety bits in this, or
 337   #  otherwise a ref to a scalar.
 338
 339   my $target = ref($_[0]) || $_[0];
 340
 341   my(@code);
 342   my(@c) = (''); # "chunks" -- scratch.
 343   my $call_count = 0;
 344   my $big_pile = '';
 345   {
 346     my $in_group = 0; # start out outside a group
 347     my($m, @params); # scratch
 348
 349     while($_[1] =~  # Iterate over chunks.
 350      m<\G(
 351        [^\~\[\]]+  # non-~[] stuff
 352        |
 353        ~.       # ~[, ~], ~~, ~other
 354        |
 355        \[          # [ presumably opening a group
 356        |
 357        \]          # ] presumably closing a group
 358        |
 359        ~           # terminal ~ ?
 360        |
 361        $
 362      )>xgs
 363     ) {
 364       print "  \"$1\"\n" if DEBUG > 2;
 365
 366       if($1 eq '[' or $1 eq '') {       # "[" or end
 367         # Whether this is "[" or end, force processing of any
 368         #  preceding literal.
 369         if($in_group) {
 370           if($1 eq '') {
 371             $target->_die_pointing($_[1], "Unterminated bracket group");
 372           } else {
 373             $target->_die_pointing($_[1], "You can't nest bracket groups");
 374           }
 375         } else {
 376           if($1 eq '') {
 377             print "   [end-string]\n" if DEBUG > 2;
 378           } else {
 379             $in_group = 1;
 380           }
 381           die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
 382           if(length $c[-1]) {
 383             # Now actually processing the preceding literal
 384             $big_pile .= $c[-1];
 385             if($USE_LITERALS and (
 386               (ord('A') == 65)
 387                ? $c[-1] !~ m<[^\x20-\x7E]>s
 388                   # ASCII very safe chars
 389                : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
 390                   # EBCDIC very safe chars
 391             )) {
 392               # normal case -- all very safe chars
 393               $c[-1] =~ s/'/\\'/g;
 394               push @code, q{ '} . $c[-1] . "',\n";
 395               $c[-1] = ''; # reuse this slot
 396             } else {
 397               push @code, ' $c[' . $#c . "],\n";
 398               push @c, ''; # new chunk
 399             }
 400           }
 401            # else just ignore the empty string.
 402         }
 403
 404       } elsif($1 eq ']') {  # "]"
 405         # close group -- go back in-band
 406         if($in_group) {
 407           $in_group = 0;
 408
 409           print "   --Closing group [$c[-1]]\n" if DEBUG > 2;
 410
 411           # And now process the group...
 412
 413           if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
 414             DEBUG > 2 and print "   -- (Ignoring)\n";
 415             $c[-1] = ''; # reset out chink
 416             next;
 417           }
 418
 419            #$c[-1] =~ s/^\s+//s;
 420            #$c[-1] =~ s/\s+$//s;
 421           ($m,@params) = split(",", $c[-1], -1);  # was /\s*,\s*/
 422
 423           # A bit of a hack -- we've turned "~,"'s into DELs, so turn
 424           #  'em into real commas here.
 425           if (ord('A') == 65) { # ASCII, etc
 426             foreach($m, @params) { tr/\x7F/,/ }
 427           } else {              # EBCDIC (1047, 0037, POSIX-BC)
 428             # Thanks to Peter Prymmer for the EBCDIC handling
 429             foreach($m, @params) { tr/\x07/,/ }
 430           }
 431
 432           # Special-case handling of some method names:
 433           if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) {
 434             # Treat [_1,...] as [,_1,...], etc.
 435             unshift @params, $m;
 436             $m = '';
 437           } elsif($m eq '*') {
 438             $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
 439           } elsif($m eq '#') {
 440             $m = 'numf';  # "#" for "number": [#,_1] for "the number _1"
 441           }
 442
 443           # Most common case: a simple, legal-looking method name
 444           if($m eq '') {
 445             # 0-length method name means to just interpolate:
 446             push @code, ' (';
 447           } elsif($m =~ m<^\w+(?:\:\:\w+)*$>s
 448             and $m !~ m<(?:^|\:)\d>s
 449              # exclude starting a (sub)package or symbol with a digit
 450           ) {
 451             # Yes, it even supports the demented (and undocumented?)
 452             #  $obj->Foo::bar(...) syntax.
 453             $target->_die_pointing(
 454               $_[1], "Can't (yet?) use \"SUPER::\" in a bracket-group method",
 455               2 + length($c[-1])
 456             )
 457              if $m =~ m/^SUPER::/s;
 458               # Because for SUPER:: to work, we'd have to compile this into
 459               #  the right package, and that seems just not worth the bother,
 460               #  unless someone convinces me otherwise.
 461
 462             push @code, ' $_[0]->' . $m . '(';
 463           } else {
 464             # TODO: implement something?  or just too icky to consider?
 465             $target->_die_pointing(
 466              $_[1],
 467              "Can't use \"$m\" as a method name in bracket group",
 468              2 + length($c[-1])
 469             );
 470           }
 471
 472           pop @c; # we don't need that chunk anymore
 473           ++$call_count;
 474
 475           foreach my $p (@params) {
 476             if($p eq '_*') {
 477               # Meaning: all parameters except $_[0]
 478               $code[-1] .= ' @_[1 .. $#_], ';
 479                # and yes, that does the right thing for all @_ < 3
 480             } elsif($p =~ m<^_(-?\d+)$>s) {
 481               # _3 meaning $_[3]
 482               $code[-1] .= '$_[' . (0 + $1) . '], ';
 483             } elsif($USE_LITERALS and (
 484               (ord('A') == 65)
 485                ? $p !~ m<[^\x20-\x7E]>s
 486                   # ASCII very safe chars
 487                : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
 488                   # EBCDIC very safe chars
 489             )) {
 490               # Normal case: a literal containing only safe characters
 491               $p =~ s/'/\\'/g;
 492               $code[-1] .= q{'} . $p . q{', };
 493             } else {
 494               # Stow it on the chunk-stack, and just refer to that.
 495               push @c, $p;
 496               push @code, ' $c[' . $#c . "], ";
 497             }
 498           }
 499           $code[-1] .= "),\n";
 500
 501           push @c, '';
 502         } else {
 503           $target->_die_pointing($_[1], "Unbalanced ']'");
 504         }
 505
 506       } elsif(substr($1,0,1) ne '~') {
 507         # it's stuff not containing "~" or "[" or "]"
 508         # i.e., a literal blob
 509         $c[-1] .= $1;
 510
 511       } elsif($1 eq '~~') { # "~~"
 512         $c[-1] .= '~';
 513
 514       } elsif($1 eq '~[') { # "~["
 515         $c[-1] .= '[';
 516
 517       } elsif($1 eq '~]') { # "~]"
 518         $c[-1] .= ']';
 519
 520       } elsif($1 eq '~,') { # "~,"
 521         if($in_group) {
 522           # This is a hack, based on the assumption that no-one will actually
 523           # want a DEL inside a bracket group.  Let's hope that's it's true.
 524           if (ord('A') == 65) { # ASCII etc
 525             $c[-1] .= "\x7F";
 526           } else {              # EBCDIC (cp 1047, 0037, POSIX-BC)
 527             $c[-1] .= "\x07";
 528           }
 529         } else {
 530           $c[-1] .= '~,';
 531         }
 532
 533       } elsif($1 eq '~') { # possible only at string-end, it seems.
 534         $c[-1] .= '~';
 535
 536       } else {
 537         # It's a "~X" where X is not a special character.
 538         # Consider it a literal ~ and X.
 539         $c[-1] .= $1;
 540       }
 541     }
 542   }
 543
 544   if($call_count) {
 545     undef $big_pile; # Well, nevermind that.
 546   } else {
 547     # It's all literals!  Ahwell, that can happen.
 548     # So don't bother with the eval.  Return a SCALAR reference.
 549     return \$big_pile;
 550   }
 551
 552   die "Last chunk isn't null??" if @c and length $c[-1]; # sanity
 553   print scalar(@c), " chunks under closure\n" if DEBUG;
 554   if(@code == 0) { # not possible?
 555     print "Empty code\n" if DEBUG;
 556     return \'';
 557   } elsif(@code > 1) { # most cases, presumably!
 558     unshift @code, "join '',\n";
 559   }
 560   unshift @code, "use strict; sub {\n";
 561   push @code, "}\n";
 562
 563   print @code if DEBUG;
 564   my $sub = eval(join '', @code);
 565   die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
 566   return $sub;
 567 }
 568
 569 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 570
 571 sub _die_pointing {
 572   # This is used by _compile to throw a fatal error
 573   my $target = shift; # class name
 574   # ...leaving $_[0] the error-causing text, and $_[1] the error message
 575
 576   my $i = index($_[0], "\n");
 577
 578   my $pointy;
 579   my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
 580   if($pos < 1) {
 581     $pointy = "^=== near there\n";
 582   } else { # we need to space over
 583     my $first_tab = index($_[0], "\t");
 584     if($pos > 2 and ( -1 == $first_tab  or  $first_tab > pos($_[0]))) {
 585       # No tabs, or the first tab is harmlessly after where we will point to,
 586       # AND we're far enough from the margin that we can draw a proper arrow.
 587       $pointy = ('=' x $pos) . "^ near there\n";
 588     } else {
 589       # tabs screw everything up!
 590       $pointy = substr($_[0],0,$pos);
 591       $pointy =~ tr/\t //cd;
 592        # make everything into whitespace, but preseving tabs
 593       $pointy .= "^=== near there\n";
 594     }
 595   }
 596
 597   my $errmsg = "$_[1], in\:\n$_[0]";
 598
 599   if($i == -1) {
 600     # No newline.
 601     $errmsg .= "\n" . $pointy;
 602   } elsif($i == (length($_[0]) - 1)  ) {
 603     # Already has a newline at end.
 604     $errmsg .= $pointy;
 605   } else {
 606     # don't bother with the pointy bit, I guess.
 607   }
 608   Carp::croak( "$errmsg via $target, as used" );
 609 }
 610
 611 ###########################################################################
 612
 613 my %tried = ();
 614   # memoization of whether we've used this module, or found it unusable.
 615
 616 sub _try_use {   # Basically a wrapper around "require Modulename"
 617   # "Many men have tried..."  "They tried and failed?"  "They tried and died."
 618   return $tried{$_[0]} if exists $tried{$_[0]};  # memoization
 619
 620   my $module = $_[0];   # ASSUME sane module name!
 621   { no strict 'refs';
 622     return($tried{$module} = 1)
 623      if defined(%{$module . "::Lexicon"}) or defined(@{$module . "::ISA"});
 624     # weird case: we never use'd it, but there it is!
 625   }
 626
 627   print " About to use $module ...\n" if DEBUG;
 628   {
 629     local $SIG{'__DIE__'};
 630     eval "require $module"; # used to be "use $module", but no point in that.
 631   }
 632   if($@) {
 633     print "Error using $module \: $@\n" if DEBUG > 1;
 634     return $tried{$module} = 0;
 635   } else {
 636     print " OK, $module is used\n" if DEBUG;
 637     return $tried{$module} = 1;
 638   }
 639 }
 640
 641 #--------------------------------------------------------------------------
 642
 643 sub _lex_refs {  # report the lexicon references for this handle's class
 644   # returns an arrayREF!
 645   no strict 'refs';
 646   my $class = ref($_[0]) || $_[0];
 647   print "Lex refs lookup on $class\n" if DEBUG > 1;
 648   return $isa_scan{$class} if exists $isa_scan{$class};  # memoization!
 649
 650   my @lex_refs;
 651   my $seen_r = ref($_[1]) ? $_[1] : {};
 652
 653   if( defined( *{$class . '::Lexicon'}{'HASH'} )) {
 654     push @lex_refs, *{$class . '::Lexicon'}{'HASH'};
 655     print "%" . $class . "::Lexicon contains ",
 656          scalar(keys %{$class . '::Lexicon'}), " entries\n" if DEBUG;
 657   }
 658
 659   # Implements depth(height?)-first recursive searching of superclasses.
 660   # In hindsight, I suppose I could have just used Class::ISA!
 661   foreach my $superclass (@{$class . "::ISA"}) {
 662     print " Super-class search into $superclass\n" if DEBUG;
 663     next if $seen_r->{$superclass}++;
 664     push @lex_refs, @{&_lex_refs($superclass, $seen_r)};  # call myself
 665   }
 666
 667   $isa_scan{$class} = \@lex_refs; # save for next time
 668   return \@lex_refs;
 669 }
 670
 671 sub clear_isa_scan { %isa_scan = (); return; } # end on a note of simplicity!
 672
 673 ###########################################################################
 674 1;
 675