home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / Locale / Maketext / Guts.pm next >
Encoding:
Perl POD Document  |  2009-06-26  |  11.5 KB  |  327 lines
  1. package Locale::Maketext::Guts;
  2.  
  3. BEGIN {
  4.     # Just so we're nice and define SOMETHING in "our" package.
  5.     *zorp = sub { return scalar @_ } unless defined &zorp;
  6. }
  7.  
  8. package Locale::Maketext;
  9. use strict;
  10. use vars qw($USE_LITERALS $GUTSPATH);
  11.  
  12. BEGIN {
  13.     $GUTSPATH = __FILE__;
  14.     *DEBUG = sub () {0} unless defined &DEBUG;
  15. }
  16.  
  17. use utf8;
  18.  
  19. sub _compile {
  20.     # This big scary routine compiles an entry.
  21.     # It returns either a coderef if there's brackety bits in this, or
  22.     #  otherwise a ref to a scalar.
  23.  
  24.     my $target = ref($_[0]) || $_[0];
  25.  
  26.     my(@code);
  27.     my(@c) = (''); # "chunks" -- scratch.
  28.     my $call_count = 0;
  29.     my $big_pile = '';
  30.     {
  31.         my $in_group = 0; # start out outside a group
  32.         my($m, @params); # scratch
  33.  
  34.         while($_[1] =~  # Iterate over chunks.
  35.             m/\G(
  36.                 [^\~\[\]]+  # non-~[] stuff
  37.                 |
  38.                 ~.       # ~[, ~], ~~, ~other
  39.                 |
  40.                 \[          # [ presumably opening a group
  41.                 |
  42.                 \]          # ] presumably closing a group
  43.                 |
  44.                 ~           # terminal ~ ?
  45.                 |
  46.                 $
  47.             )/xgs
  48.         ) {
  49.             DEBUG>2 and print qq{  "$1"\n};
  50.  
  51.             if($1 eq '[' or $1 eq '') {       # "[" or end
  52.                 # Whether this is "[" or end, force processing of any
  53.                 #  preceding literal.
  54.                 if($in_group) {
  55.                     if($1 eq '') {
  56.                         $target->_die_pointing($_[1], 'Unterminated bracket group');
  57.                     }
  58.                     else {
  59.                         $target->_die_pointing($_[1], 'You can\'t nest bracket groups');
  60.                     }
  61.                 }
  62.                 else {
  63.                     if ($1 eq '') {
  64.                         DEBUG>2 and print "   [end-string]\n";
  65.                     }
  66.                     else {
  67.                         $in_group = 1;
  68.                     }
  69.                     die "How come \@c is empty?? in <$_[1]>" unless @c; # sanity
  70.                     if(length $c[-1]) {
  71.                         # Now actually processing the preceding literal
  72.                         $big_pile .= $c[-1];
  73.                         if($USE_LITERALS and (
  74.                                 (ord('A') == 65)
  75.                                 ? $c[-1] !~ m/[^\x20-\x7E]/s
  76.                                 # ASCII very safe chars
  77.                                 : $c[-1] !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
  78.                                 # EBCDIC very safe chars
  79.                             )) {
  80.                             # normal case -- all very safe chars
  81.                             $c[-1] =~ s/'/\\'/g;
  82.                             push @code, q{ '} . $c[-1] . "',\n";
  83.                             $c[-1] = ''; # reuse this slot
  84.                         }
  85.                         else {
  86.                             push @code, ' $c[' . $#c . "],\n";
  87.                             push @c, ''; # new chunk
  88.                         }
  89.                     }
  90.                     # else just ignore the empty string.
  91.                 }
  92.  
  93.             }
  94.             elsif($1 eq ']') {  # "]"
  95.                 # close group -- go back in-band
  96.                 if($in_group) {
  97.                     $in_group = 0;
  98.  
  99.                     DEBUG>2 and print "   --Closing group [$c[-1]]\n";
  100.  
  101.                     # And now process the group...
  102.  
  103.                     if(!length($c[-1]) or $c[-1] =~ m/^\s+$/s) {
  104.                         DEBUG > 2 and print "   -- (Ignoring)\n";
  105.                         $c[-1] = ''; # reset out chink
  106.                         next;
  107.                     }
  108.  
  109.                     #$c[-1] =~ s/^\s+//s;
  110.                     #$c[-1] =~ s/\s+$//s;
  111.                     ($m,@params) = split(/,/, $c[-1], -1);  # was /\s*,\s*/
  112.  
  113.                     # A bit of a hack -- we've turned "~,"'s into DELs, so turn
  114.                     #  'em into real commas here.
  115.                     if (ord('A') == 65) { # ASCII, etc
  116.                         foreach($m, @params) { tr/\x7F/,/ }
  117.                     }
  118.                     else {              # EBCDIC (1047, 0037, POSIX-BC)
  119.                         # Thanks to Peter Prymmer for the EBCDIC handling
  120.                         foreach($m, @params) { tr/\x07/,/ }
  121.                     }
  122.  
  123.                     # Special-case handling of some method names:
  124.                     if($m eq '_*' or $m =~ m/^_(-?\d+)$/s) {
  125.                         # Treat [_1,...] as [,_1,...], etc.
  126.                         unshift @params, $m;
  127.                         $m = '';
  128.                     }
  129.                     elsif($m eq '*') {
  130.                         $m = 'quant'; # "*" for "times": "4 cars" is 4 times "cars"
  131.                     }
  132.                     elsif($m eq '#') {
  133.                         $m = 'numf';  # "#" for "number": [#,_1] for "the number _1"
  134.                     }
  135.  
  136.                     # Most common case: a simple, legal-looking method name
  137.                     if($m eq '') {
  138.                         # 0-length method name means to just interpolate:
  139.                         push @code, ' (';
  140.                     }
  141.                     elsif($m =~ /^\w+(?:\:\:\w+)*$/s
  142.                             and $m !~ m/(?:^|\:)\d/s
  143.                         # exclude starting a (sub)package or symbol with a digit
  144.                     ) {
  145.                         # Yes, it even supports the demented (and undocumented?)
  146.                         #  $obj->Foo::bar(...) syntax.
  147.                         $target->_die_pointing(
  148.                             $_[1], q{Can't use "SUPER::" in a bracket-group method},
  149.                             2 + length($c[-1])
  150.                         )
  151.                         if $m =~ m/^SUPER::/s;
  152.                         # Because for SUPER:: to work, we'd have to compile this into
  153.                         #  the right package, and that seems just not worth the bother,
  154.                         #  unless someone convinces me otherwise.
  155.  
  156.                         push @code, ' $_[0]->' . $m . '(';
  157.                     }
  158.                     else {
  159.                         # TODO: implement something?  or just too icky to consider?
  160.                         $target->_die_pointing(
  161.                             $_[1],
  162.                             "Can't use \"$m\" as a method name in bracket group",
  163.                             2 + length($c[-1])
  164.                         );
  165.                     }
  166.  
  167.                     pop @c; # we don't need that chunk anymore
  168.                     ++$call_count;
  169.  
  170.                     foreach my $p (@params) {
  171.                         if($p eq '_*') {
  172.                             # Meaning: all parameters except $_[0]
  173.                             $code[-1] .= ' @_[1 .. $#_], ';
  174.                             # and yes, that does the right thing for all @_ < 3
  175.                         }
  176.                         elsif($p =~ m/^_(-?\d+)$/s) {
  177.                             # _3 meaning $_[3]
  178.                             $code[-1] .= '$_[' . (0 + $1) . '], ';
  179.                         }
  180.                         elsif($USE_LITERALS and (
  181.                                 (ord('A') == 65)
  182.                                 ? $p !~ m/[^\x20-\x7E]/s
  183.                                 # ASCII very safe chars
  184.                                 : $p !~ m/[^ !"\#\$%&'()*+,\-.\/0-9:;<=>?\@A-Z[\\\]^_`a-z{|}~\x07]/s
  185.                                 # EBCDIC very safe chars
  186.                             )) {
  187.                             # Normal case: a literal containing only safe characters
  188.                             $p =~ s/'/\\'/g;
  189.                             $code[-1] .= q{'} . $p . q{', };
  190.                         }
  191.                         else {
  192.                             # Stow it on the chunk-stack, and just refer to that.
  193.                             push @c, $p;
  194.                             push @code, ' $c[' . $#c . '], ';
  195.                         }
  196.                     }
  197.                     $code[-1] .= "),\n";
  198.  
  199.                     push @c, '';
  200.                 }
  201.                 else {
  202.                     $target->_die_pointing($_[1], q{Unbalanced ']'});
  203.                 }
  204.  
  205.             }
  206.             elsif(substr($1,0,1) ne '~') {
  207.                 # it's stuff not containing "~" or "[" or "]"
  208.                 # i.e., a literal blob
  209.                 $c[-1] .= $1;
  210.  
  211.             }
  212.             elsif($1 eq '~~') { # "~~"
  213.                 $c[-1] .= '~';
  214.  
  215.             }
  216.             elsif($1 eq '~[') { # "~["
  217.                 $c[-1] .= '[';
  218.  
  219.             }
  220.             elsif($1 eq '~]') { # "~]"
  221.                 $c[-1] .= ']';
  222.  
  223.             }
  224.             elsif($1 eq '~,') { # "~,"
  225.                 if($in_group) {
  226.                     # This is a hack, based on the assumption that no-one will actually
  227.                     # want a DEL inside a bracket group.  Let's hope that's it's true.
  228.                     if (ord('A') == 65) { # ASCII etc
  229.                         $c[-1] .= "\x7F";
  230.                     }
  231.                     else {              # EBCDIC (cp 1047, 0037, POSIX-BC)
  232.                         $c[-1] .= "\x07";
  233.                     }
  234.                 }
  235.                 else {
  236.                     $c[-1] .= '~,';
  237.                 }
  238.  
  239.             }
  240.             elsif($1 eq '~') { # possible only at string-end, it seems.
  241.                 $c[-1] .= '~';
  242.  
  243.             }
  244.             else {
  245.                 # It's a "~X" where X is not a special character.
  246.                 # Consider it a literal ~ and X.
  247.                 $c[-1] .= $1;
  248.             }
  249.         }
  250.     }
  251.  
  252.     if($call_count) {
  253.         undef $big_pile; # Well, nevermind that.
  254.     }
  255.     else {
  256.         # It's all literals!  Ahwell, that can happen.
  257.         # So don't bother with the eval.  Return a SCALAR reference.
  258.         return \$big_pile;
  259.     }
  260.  
  261.     die q{Last chunk isn't null??} if @c and length $c[-1]; # sanity
  262.     DEBUG and print scalar(@c), " chunks under closure\n";
  263.     if(@code == 0) { # not possible?
  264.         DEBUG and print "Empty code\n";
  265.         return \'';
  266.     }
  267.     elsif(@code > 1) { # most cases, presumably!
  268.         unshift @code, "join '',\n";
  269.     }
  270.     unshift @code, "use strict; sub {\n";
  271.     push @code, "}\n";
  272.  
  273.     DEBUG and print @code;
  274.     my $sub = eval(join '', @code);
  275.     die "$@ while evalling" . join('', @code) if $@; # Should be impossible.
  276.     return $sub;
  277. }
  278.  
  279. # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  280.  
  281. sub _die_pointing {
  282.     # This is used by _compile to throw a fatal error
  283.     my $target = shift; # class name
  284.     # ...leaving $_[0] the error-causing text, and $_[1] the error message
  285.  
  286.     my $i = index($_[0], "\n");
  287.  
  288.     my $pointy;
  289.     my $pos = pos($_[0]) - (defined($_[2]) ? $_[2] : 0) - 1;
  290.     if($pos < 1) {
  291.         $pointy = "^=== near there\n";
  292.     }
  293.     else { # we need to space over
  294.         my $first_tab = index($_[0], "\t");
  295.         if($pos > 2 and ( -1 == $first_tab  or  $first_tab > pos($_[0]))) {
  296.             # No tabs, or the first tab is harmlessly after where we will point to,
  297.             # AND we're far enough from the margin that we can draw a proper arrow.
  298.             $pointy = ('=' x $pos) . "^ near there\n";
  299.         }
  300.         else {
  301.             # tabs screw everything up!
  302.             $pointy = substr($_[0],0,$pos);
  303.             $pointy =~ tr/\t //cd;
  304.             # make everything into whitespace, but preseving tabs
  305.             $pointy .= "^=== near there\n";
  306.         }
  307.     }
  308.  
  309.     my $errmsg = "$_[1], in\:\n$_[0]";
  310.  
  311.     if($i == -1) {
  312.         # No newline.
  313.         $errmsg .= "\n" . $pointy;
  314.     }
  315.     elsif($i == (length($_[0]) - 1)  ) {
  316.         # Already has a newline at end.
  317.         $errmsg .= $pointy;
  318.     }
  319.     else {
  320.         # don't bother with the pointy bit, I guess.
  321.     }
  322.     Carp::croak( "$errmsg via $target, as used" );
  323. }
  324.  
  325. 1;
  326.  
  327.