[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 2771 - (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 :     push(@pattern,protectRegexp($s)) if length($s) ==1;
65 :     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 :     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 : dpvc 2771 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 : dpvc 2579 };
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