home *** CD-ROM | disk | FTP | other *** search
/ PC World 2003 March / PCWorld_2003-03_cd.bin / Software / Topware / activeperl / ActivePerl / Perl / lib / Locale / Maketext.pm < prev    next >
Encoding:
Text File  |  2002-06-19  |  22.2 KB  |  676 lines
  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.  
  676.