View of /trunk/pg/lib/Parser/Context/Strings.pm

    1 #########################################################################
    2 #
    3 #  Implement the list of known strings
    4 #
    5 package Parser::Context::Strings;
    6 use strict;
    7 use vars qw (@ISA);
    8 @ISA = qw(Value::Context::Data);
    9 
   10 sub init {
   11   my $self = shift;
   12   $self->{dataName} = 'strings';
   13   $self->{name} = 'string';
   14   $self->{Name} = 'String';
   15   $self->{namePattern} = '[\S ]+';
   16 }
   17 
   18 #
   19 #  Allow for case-insensitive strings.
   20 #  Case-insensitive is now the default.
   21 #  You can use
   22 #
   23 #       $context->strings->set(name=>{caseSensitive=>1});
   24 #
   25 #  to get a case-sensitive string called "name".
   26 #
   27 sub update {
   28   my $self = shift;
   29   my $data = $self->{context}->{$self->{dataName}};
   30   my $single = ''; my @multi = ();
   31   foreach my $x (sort byName (keys %{$data})) {
   32     unless ($data->{$x}{hidden}) {
   33       if ($data->{$x}{caseSensitive} || uc($x) eq lc($x)) {
   34   if (length($x) == 1) {$single .= $x}
   35                   else {push(@multi,protectRegexp($x))}
   36       } else {
   37   if (length($x) == 1) {$single .= uc($x).lc($x)}
   38                   else {push(@multi,"(?:(?i)".protectRegexp($x).")")}
   39       }
   40     }
   41   }
   42   $self->{pattern} = $self->getPattern($single,@multi);
   43   $self->{context}->update;
   44 }
   45 
   46 #
   47 #  Must be in the same package as the sort call
   48 #  (due to global $a and $b, I assume)
   49 #
   50 sub byName {
   51   my $result = length($b) <=> length($a);
   52   return $result unless $result == 0;
   53   return $a cmp $b;
   54 }
   55 
   56 #
   57 #  Same as Value::Context::Data::getPattern, but with
   58 #  the protectRegexp already done on the @multi list.
   59 #
   60 sub getPattern {
   61   shift; my $s = shift;
   62 #  foreach my $x (@_) {$x = protectRegexp($x)}
   63   my @pattern = ();
   64   push(@pattern,join('|',@_)) if scalar(@_) > 0;
   65   push(@pattern,protectRegexp($s)) if length($s) == 1;
   66   push(@pattern,"[".protectChars($s)."]") if length($s) > 1;
   67   my $pattern = join('|',@pattern);
   68   $pattern = '^$' if $pattern eq '';
   69   return $pattern;
   70 }
   71 
   72 #
   73 #  Add upper-case alias for case-insensitive strings
   74 #  (so we can always find their definitions)
   75 #
   76 sub add {
   77   my $self = shift; return if scalar(@_) == 0;
   78   my $data = $self->{context}{$self->{dataName}};
   79   $self->SUPER::add(@_);
   80   my %D = (@_);
   81   foreach my $x (keys %D) {
   82     $data->{uc($x)} = {alias => $x, hidden => 1}
   83       unless $data->{$x}{caseSensitive} || uc($x) eq $x;
   84   }
   85 }
   86 
   87 #
   88 #  Call the ones in Value::Context::Data
   89 #
   90 sub protectRegexp {Value::Context::Data::protectRegexp(@_)}
   91 sub protectChars {Value::Context::Data::protectChars(@_)}
   92 
   93 
   94 #########################################################################
   95 
   96 1;