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