[system] / trunk / pg / lib / Value / Context / Data.pm Repository:
ViewVC logotype

View of /trunk/pg/lib/Value/Context/Data.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2658 - (download) (as text) (annotate)
Fri Aug 20 11:17:06 2004 UTC (15 years, 5 months ago) by dpvc
File size: 4239 byte(s)
Make blank patterns be ^$ (which should never match) rather than empty
(which always matches).  this fixes a problem where if a context has
no functions, for example, the parser would attempt to create function
calls to a function named ''.

    1 #########################################################################
    2 #
    3 #  Implements base class for data list in Context objects.
    4 #
    5 package Value::Context::Data;
    6 use strict;
    7 
    8 sub new {
    9   my $self = shift; my $class = ref($self) || $self;
   10   my $parent = shift;
   11   my $data = bless {
   12     context => $parent,     # parent context
   13     dataName => {},         # name of data storage in context hash
   14     pattern => '^$',        # pattern for names of data items (default never matches)
   15     namePattern => '',      # pattern for allowed names for new items
   16     name => '', Name => '', # lower- and upper-case names for the class of items
   17   }, $class;
   18   $data->init();
   19   $parent->{$data->{dataName}} = {};
   20   $data->add(@_);
   21   return $data;
   22 }
   23 
   24 #
   25 #  Implemented in sub-classes
   26 #
   27 sub init {}
   28 sub create {shift; shift}
   29 
   30 #
   31 #  Sort names so that they can be joined for regexp matching
   32 #
   33 sub byName {
   34   my $result = length($b) <=> length($a);
   35   return $result unless $result == 0;
   36   return $a cmp $b;
   37 }
   38 
   39 #
   40 #  Update the pattern for the names
   41 #
   42 sub update {
   43   my $self = shift;
   44   my $data = $self->{context}->{$self->{dataName}};
   45   my $single = ''; my @multi = ();
   46   foreach my $x (sort byName (keys %{$data})) {
   47     unless ($data->{$x}{hidden}) {
   48       if (length($x) == 1) {$single .= $x} else {push(@multi,$x)}
   49     }
   50   }
   51   $self->{pattern} = $self->getPattern($single,@multi);
   52   $self->{context}->update;
   53 }
   54 
   55 #
   56 #  Build a regexp pattern from the characters and list of names
   57 #  (protect special characters)
   58 #
   59 sub getPattern {
   60   shift; my $s = shift;
   61   foreach my $x (@_) {$x = protectRegexp($x)}
   62   my @pattern = ();
   63   push(@pattern,join('|',@_)) if scalar(@_) > 0;
   64   push(@pattern,protectRegexp($s)) if length($s) ==1;
   65   push(@pattern,"[".protectChars($s)."]") if length($s) > 1;
   66   my $pattern = join('|',@pattern);
   67   $pattern = '^$' if $pattern eq '';
   68   return $pattern;
   69 }
   70 
   71 sub protectRegexp {
   72   my $string = shift;
   73   $string =~ s/[\[\](){}|+.*?\\]/\\$&/g;
   74   return $string;
   75 }
   76 
   77 sub protectChars {
   78   my $string = shift;
   79   $string =~ s/\]/\\\]/g;
   80   $string =~ s/^(.*)-(.*)$/-$1$2/g;
   81   return $string;
   82 }
   83 
   84 
   85 #
   86 #  Add one or more new items to the list
   87 #
   88 sub add {
   89   my $self = shift; my %D = (@_); return if scalar(@_) == 0;
   90   my $data = $self->{context}{$self->{dataName}};
   91   foreach my $x (keys %D) {
   92     Value::Error("Illegal $self->{name} name '$x'") unless $x =~ m/^$self->{namePattern}$/;
   93     warn "$self->{Name} '$x' already exists" if defined($data->{$x});
   94     $data->{$x} = $self->create($D{$x});
   95   }
   96   $self->update;
   97 }
   98 
   99 #
  100 #  Remove one or more items
  101 #
  102 sub remove {
  103   my $self = shift;
  104   my $data = $self->{context}{$self->{dataName}};
  105   foreach my $x (@_) {
  106     warn "$self->{Name} '$x' doesn't exist" unless defined($data->{$x});
  107     delete $data->{$x};
  108   }
  109   $self->update;
  110 }
  111 
  112 #
  113 #  Replace an item with a new definition
  114 #
  115 sub replace {
  116   my $self = shift; my %list = (@_);
  117   $self->remove(keys %list);
  118   $self->add(@_);
  119 }
  120 
  121 #
  122 #  Clear all items
  123 #
  124 sub clear {
  125   my $self = shift;
  126   $self->{context}{$self->{dataName}} = {};
  127   $self->update;
  128 }
  129 
  130 #
  131 #  Make the data be only these items
  132 #
  133 sub are {
  134   my $self = shift;
  135   $self->clear;
  136   $self->add(@_);
  137 }
  138 
  139 #
  140 #  Make one or more items become undefined, but still recognized.
  141 #  (Implemented in the sub-classes.)
  142 #
  143 sub undefine {my $self = shift; $self->remove(@_)}
  144 
  145 
  146 #
  147 #  Get hash for an item
  148 #
  149 sub get {
  150   my $self = shift; my $x = shift;
  151   return $self->{context}{$self->{dataName}}{$x};
  152 }
  153 
  154 #
  155 #  Set flags for one or more items
  156 #
  157 sub set {
  158   my $self = shift; my %D = (@_);
  159   my $data = $self->{context}{$self->{dataName}};
  160   foreach my $x (keys(%D)) {
  161     $data->{$x} = (defined($data->{$x}) && ref($data->{$x}) eq 'HASH') ?
  162                     {%{$data->{$x}},%{$D{$x}}} :
  163                     $self->create($D{$x});
  164   };
  165 }
  166 
  167 #
  168 #  Get the names of all items
  169 #
  170 sub names {
  171   my $self = shift;
  172   return sort(keys %{$self->{context}{$self->{dataName}}});
  173 }
  174 
  175 #
  176 #  Get the complete data hash
  177 #
  178 sub all {
  179   my $self = shift;
  180   $self->{context}{$self->{dataName}};
  181 }
  182 
  183 #########################################################################
  184 #
  185 #  Load the subclasses.
  186 #
  187 
  188 use Value::Context::Flags;
  189 use Value::Context::Lists;
  190 
  191 #########################################################################
  192 
  193 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9