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

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9