Commit | Line | Data |
9378c581 |
1 | |
71457cb8 |
2 | # Time-stamp: "2001-06-21 23:09:33 MDT" |
9378c581 |
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 | |
71457cb8 |
17 | $VERSION = "1.03"; |
9378c581 |
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 | |
ff5ad48a |
289 | push @languages, map I18N::LangTags::super_languages($_), @languages |
9378c581 |
290 | if $MATCH_SUPERS; |
291 | |
ff5ad48a |
292 | @languages = map { $_, I18N::LangTags::alternate_language_tags($_) } |
9378c581 |
293 | @languages; # catch alternation |
294 | |
ff5ad48a |
295 | push @languages, I18N::LangTags::panic_languages(@languages) |
296 | if defined &I18N::LangTags::panic_languages; |
297 | |
9378c581 |
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 | | |
ff5ad48a |
355 | \[ # [ presumably opening a group |
9378c581 |
356 | | |
ff5ad48a |
357 | \] # ] presumably closing a group |
9378c581 |
358 | | |
ff5ad48a |
359 | ~ # terminal ~ ? |
9378c581 |
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]; |
ff5ad48a |
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 | )) { |
9378c581 |
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 | |
ff5ad48a |
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 | } |
9378c581 |
431 | |
ff5ad48a |
432 | # Special-case handling of some method names: |
9378c581 |
433 | if($m eq '_*' or $m =~ m<^_(-?\d+)$>s) { |
434 | # Treat [_1,...] as [,_1,...], etc. |
435 | unshift @params, $m; |
436 | $m = ''; |
ff5ad48a |
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" |
9378c581 |
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) . '], '; |
ff5ad48a |
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 | )) { |
9378c581 |
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) { |
ff5ad48a |
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 | } |
9378c581 |
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 | |
ff5ad48a |
659 | # Implements depth(height?)-first recursive searching of superclasses. |
660 | # In hindsight, I suppose I could have just used Class::ISA! |
9378c581 |
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 | |