[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 3483 - (download) (as text) (annotate)
Fri Aug 12 01:21:48 2005 UTC (14 years, 4 months ago) by dpvc
File size: 5028 byte(s)
Added redefine() function to complement undefine() for various
Context() values.  For example

      Context()->operators->undefine('+');

makes '+' undefined, but

      Context()->operators->redefine('+');

will put it back.  You can specify a context from which to take the
redefinition, and a name in that context, as in

      Context()->operators->redefine('U',from=>"Interval");
      Context()->operators->redefine('u',from=>"Interval",using=>"U");
      Context()->operators->redefine('U',from=>$content);

where $content is a reference to a Context object.

The undefine() function lets you undefine several items at once, as in

      Context()->operators->undefine('+','-');

For redefine, you must put multiple names in square brackets because
of the optional parmeters:

      Context()->operators->redefine(['+','-']);

    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 %s name '%s'",$self->{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 #  Redefine items from the default context, or a given one
  147 #
  148 sub redefine {
  149   my $self = shift; my $X = shift;
  150   my %options = (using => undef, from => "Full", @_);
  151   my $Y = $options{using}; my $from = $options{from};
  152   $from = $Parser::Context::Default::context{$from} unless ref($from);
  153   $Y = $X if !defined($Y) && !ref($X);
  154   $X = [$X] unless ref($X) eq 'ARRAY';
  155   my @data = (); my @remove = ();
  156   foreach my $x (@{$X}) {
  157     my $y = defined($Y)? $Y: $x;
  158     Value::Error("No definition for %s '%s' in the given context",$self->{name},$y)
  159       unless $from->{$self->{dataName}}{$y};
  160     push(@remove,$x) if $self->get($x);
  161     push(@data,$x => $from->{$self->{dataName}}{$y});
  162   }
  163   $self->remove(@remove);
  164   $self->add(@data);
  165 }
  166 
  167 
  168 #
  169 #  Get hash for an item
  170 #
  171 sub get {
  172   my $self = shift; my $x = shift;
  173   return $self->{context}{$self->{dataName}}{$x};
  174 }
  175 
  176 #
  177 #  Set flags for one or more items
  178 #
  179 sub set {
  180   my $self = shift; my %D = (@_);
  181   my $data = $self->{context}{$self->{dataName}};
  182   foreach my $x (keys(%D)) {
  183     my $xref = $data->{$x};
  184     if (defined($xref) && ref($xref) eq 'HASH') {
  185       foreach my $id (keys %{$D{$x}}) {$xref->{$id} = $D{$x}{$id}}
  186     } else {
  187       $data->{$x} = $self->create($D{$x});
  188     }
  189   };
  190 }
  191 
  192 #
  193 #  Get the names of all items
  194 #
  195 sub names {
  196   my $self = shift;
  197   return sort(keys %{$self->{context}{$self->{dataName}}});
  198 }
  199 
  200 #
  201 #  Get the complete data hash
  202 #
  203 sub all {
  204   my $self = shift;
  205   $self->{context}{$self->{dataName}};
  206 }
  207 
  208 #########################################################################
  209 #
  210 #  Load the subclasses.
  211 #
  212 
  213 use Value::Context::Flags;
  214 use Value::Context::Lists;
  215 
  216 #########################################################################
  217 
  218 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9