[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 3333 - (download) (as text) (annotate)
Sun Jul 3 20:06:33 2005 UTC (14 years, 6 months ago) by dpvc
File size: 4282 byte(s)
Adjusted some spacing

    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     my $xref = $data->{$x};
  162     if (defined($xref) && ref($xref) eq 'HASH') {
  163       foreach my $id (keys %{$D{$x}}) {$xref->{$id} = $D{$x}{$id}}
  164     } else {
  165       $data->{$x} = $self->create($D{$x});
  166     }
  167   };
  168 }
  169 
  170 #
  171 #  Get the names of all items
  172 #
  173 sub names {
  174   my $self = shift;
  175   return sort(keys %{$self->{context}{$self->{dataName}}});
  176 }
  177 
  178 #
  179 #  Get the complete data hash
  180 #
  181 sub all {
  182   my $self = shift;
  183   $self->{context}{$self->{dataName}};
  184 }
  185 
  186 #########################################################################
  187 #
  188 #  Load the subclasses.
  189 #
  190 
  191 use Value::Context::Flags;
  192 use Value::Context::Lists;
  193 
  194 #########################################################################
  195 
  196 1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9