Commit | Line | Data |
9378c581 |
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 | |