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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 3483 - (view) (download) (as text)

1 : dpvc 2579 #########################################################################
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 : dpvc 2658 pattern => '^$', # pattern for names of data items (default never matches)
15 : dpvc 2579 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 : dpvc 3333 push(@pattern,protectRegexp($s)) if length($s) == 1;
65 : dpvc 2579 push(@pattern,"[".protectChars($s)."]") if length($s) > 1;
66 :     my $pattern = join('|',@pattern);
67 : dpvc 2658 $pattern = '^$' if $pattern eq '';
68 : dpvc 2579 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 : dpvc 2649 $string =~ s/^(.*)-(.*)$/-$1$2/g;
81 : dpvc 2579 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 : dpvc 3370 Value::Error("Illegal %s name '%s'",$self->{name},$x) unless $x =~ m/^$self->{namePattern}$/;
93 : dpvc 2579 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 : dpvc 3483 #
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 : dpvc 2579
167 : dpvc 3483
168 : dpvc 2579 #
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 : dpvc 2771 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 : dpvc 2579 };
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