Commit | Line | Data |
---|---|---|
86530b38 AT |
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 |