[Summary view] [Print] [Text view]

   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