[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 2649 - (download) (as text) (annotate)
Thu Aug 19 14:19:32 2004 UTC (15 years, 5 months ago) by dpvc
File size: 4178 byte(s)
Fixed an error in the generation of regexp patterns for the various
data types.

    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
   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   return $pattern;
   68 }
   69 
   70 sub protectRegexp {
   71   my $string = shift;
   72   $string =~ s/[\[\](){}|+.*?\\]/\\$&/g;
   73   return $string;
   74 }
   75 
   76 sub protectChars {
   77   my $string = shift;
   78   $string =~ s/\]/\\\]/g;
   79   $string =~ s/^(.*)-(.*)$/-$1$2/g;
   80   return $string;
   81 }
   82 
   83 
   84 #
   85 #  Add one or more new items to the list
   86 #
   87 sub add {
   88   my $self = shift; my %D = (@_); return if scalar(@_) == 0;
   89   my $data = $self->{context}{$self->{dataName}};
   90   foreach my $x (keys %D) {
   91     Value::Error("Illegal $self->{name} name '$x'") unless $x =~ m/^$self->{namePattern}$/;
   92     warn "$self->{Name} '$x' already exists" if defined($data->{$x});
   93     $data->{$x} = $self->create($D{$x});
   94   }
   95   $self->update;
   96 }
   97 
   98 #
   99 #  Remove one or more items
  100 #
  101 sub remove {
  102   my $self = shift;
  103   my $data = $self->{context}{$self->{dataName}};
  104   foreach my $x (@_) {
  105     warn "$self->{Name} '$x' doesn't exist" unless defined($data->{$x});
  106     delete $data->{$x};
  107   }
  108   $self->update;
  109 }
  110 
  111 #
  112 #  Replace an item with a new definition
  113 #
  114 sub replace {
  115   my $self = shift; my %list = (@_);
  116   $self->remove(keys %list);
  117   $self->add(@_);
  118 }
  119 
  120 #
  121 #  Clear all items
  122 #
  123 sub clear {
  124   my $self = shift;
  125   $self->{context}{$self->{dataName}} = {};
  126   $self->update;
  127 }
  128 
  129 #
  130 #  Make the data be only these items
  131 #
  132 sub are {
  133   my $self = shift;
  134   $self->clear;
  135   $self->add(@_);
  136 }
  137 
  138 #
  139 #  Make one or more items become undefined, but still recognized.
  140 #  (Implemented in the sub-classes.)
  141 #
  142 sub undefine {my $self = shift; $self->remove(@_)}
  143 
  144 
  145 #
  146 #  Get hash for an item
  147 #
  148 sub get {
  149   my $self = shift; my $x = shift;
  150   return $self->{context}{$self->{dataName}}{$x};
  151 }
  152 
  153 #
  154 #  Set flags for one or more items
  155 #
  156 sub set {
  157   my $self = shift; my %D = (@_);
  158   my $data = $self->{context}{$self->{dataName}};
  159   foreach my $x (keys(%D)) {
  160     $data->{$x} = (defined($data->{$x}) && ref($data->{$x}) eq 'HASH') ?
  161                     {%{$data->{$x}},%{$D{$x}}} :
  162                     $self->create($D{$x});
  163   };
  164 }
  165 
  166 #
  167 #  Get the names of all items
  168 #
  169 sub names {
  170   my $self = shift;
  171   return sort(keys %{$self->{context}{$self->{dataName}}});
  172 }
  173 
  174 #
  175 #  Get the complete data hash
  176 #
  177 sub all {
  178   my $self = shift;
  179   $self->{context}{$self->{dataName}};
  180 }
  181 
  182 #########################################################################
  183 #
  184 #  Load the subclasses.
  185 #
  186 
  187 use Value::Context::Flags;
  188 use Value::Context::Lists;
  189 
  190 #########################################################################
  191 
  192 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9