[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 2649 - (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 : dpvc 2649 $string =~ s/^(.*)-(.*)$/-$1$2/g;
80 : dpvc 2579 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