| 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 | |
projects / p5sagit/p5-mst-13.2.git / blame