[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 5509 - (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 : dpvc 5509 use Scalar::Util;
8 : dpvc 2579
9 :     sub new {
10 :     my $self = shift; my $class = ref($self) || $self;
11 :     my $parent = shift;
12 :     my $data = bless {
13 :     context => $parent, # parent context
14 :     dataName => {}, # name of data storage in context hash
15 : dpvc 5116 tokens => {}, # hash of id => type specifications that will be made into a pattern
16 :     patterns => {}, # hash of pattern => [type,precedence] specification for extra patterns
17 :     tokenType => {}, # type of Parser token for these pattern
18 : dpvc 2579 namePattern => '', # pattern for allowed names for new items
19 :     name => '', Name => '', # lower- and upper-case names for the class of items
20 :     }, $class;
21 : dpvc 5509 $data->weaken;
22 : dpvc 2579 $data->init();
23 :     $parent->{$data->{dataName}} = {};
24 : dpvc 5116 push @{$parent->{data}{objects}},"_$data->{dataName}";
25 : dpvc 2579 $data->add(@_);
26 :     return $data;
27 :     }
28 :    
29 :     #
30 :     # Implemented in sub-classes
31 :     #
32 :     sub init {}
33 :     sub create {shift; shift}
34 : dpvc 3510 sub uncreate {shift; shift}
35 : dpvc 2579
36 :     #
37 : dpvc 5116 # Copy the context data
38 : dpvc 3714 #
39 :     sub copy {
40 : dpvc 5116 my $self = shift; my $orig = shift;
41 :     my $data = $orig->{context}->{$orig->{dataName}};
42 :     my $copy = $self->{context}->{$self->{dataName}};
43 : dpvc 3714 foreach my $name (keys %{$data}) {
44 :     if (ref($data->{$name}) eq 'ARRAY') {
45 :     $copy->{$name} = [@{$data->{$name}}];
46 :     } elsif (ref($data->{$name}) eq 'HASH') {
47 :     $copy->{$name} = {%{$data->{$name}}};
48 :     } else {
49 :     $copy->{$name} = $data->{$name};
50 :     }
51 :     }
52 : dpvc 5116 $self->{tokens} = {%{$orig->{tokens}}};
53 :     foreach my $p (keys %{$orig->{patterns}}) {
54 :     $self->{patterns}{$p} =
55 :     (ref($orig->{patterns}{$p}) ? [@{$orig->{patterns}{$p}}] : $orig->{patterns}{$p});
56 : dpvc 2579 }
57 :     }
58 :    
59 :     #
60 : dpvc 5509 # Make context pointer a weak pointer (avoids reference loops)
61 :     #
62 :     sub weaken {Scalar::Util::weaken((shift)->{context})}
63 :    
64 :     #
65 : dpvc 5116 # Update the context patterns
66 : dpvc 2579 #
67 : dpvc 5116 sub update {(shift)->{context}->update}
68 : dpvc 2579
69 : dpvc 5116 sub addToken {
70 :     my $self = shift; my $token = shift;
71 :     $self->{tokens}{$token} = $self->{tokenType}
72 :     unless $self->{context}{$self->{dataName}}{$token}{hidden};
73 : dpvc 2579 }
74 :    
75 : dpvc 5116 sub removeToken {
76 :     my $self = shift; my $token = shift;
77 :     delete $self->{tokens}{$token};
78 : dpvc 2579 }
79 :    
80 :    
81 :     #
82 :     # Add one or more new items to the list
83 :     #
84 :     sub add {
85 :     my $self = shift; my %D = (@_); return if scalar(@_) == 0;
86 :     my $data = $self->{context}{$self->{dataName}};
87 :     foreach my $x (keys %D) {
88 : dpvc 3370 Value::Error("Illegal %s name '%s'",$self->{name},$x) unless $x =~ m/^$self->{namePattern}$/;
89 : dpvc 2579 warn "$self->{Name} '$x' already exists" if defined($data->{$x});
90 :     $data->{$x} = $self->create($D{$x});
91 : dpvc 5116 $self->addToken($x);
92 : dpvc 2579 }
93 :     $self->update;
94 :     }
95 :    
96 :     #
97 :     # Remove one or more items
98 :     #
99 :     sub remove {
100 :     my $self = shift;
101 :     my $data = $self->{context}{$self->{dataName}};
102 :     foreach my $x (@_) {
103 :     warn "$self->{Name} '$x' doesn't exist" unless defined($data->{$x});
104 : dpvc 5116 $self->removeToken($x);
105 : dpvc 2579 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 : dpvc 5116 $self->{tokens} = {};
126 : dpvc 2579 $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 : dpvc 3483 #
145 :     # Redefine items from the default context, or a given one
146 :     #
147 :     sub redefine {
148 :     my $self = shift; my $X = shift;
149 :     my %options = (using => undef, from => "Full", @_);
150 :     my $Y = $options{using}; my $from = $options{from};
151 :     $from = $Parser::Context::Default::context{$from} unless ref($from);
152 :     $Y = $X if !defined($Y) && !ref($X);
153 :     $X = [$X] unless ref($X) eq 'ARRAY';
154 :     my @data = (); my @remove = ();
155 :     foreach my $x (@{$X}) {
156 :     my $y = defined($Y)? $Y: $x;
157 :     Value::Error("No definition for %s '%s' in the given context",$self->{name},$y)
158 :     unless $from->{$self->{dataName}}{$y};
159 :     push(@remove,$x) if $self->get($x);
160 : dpvc 3510 push(@data,$x => $self->uncreate($from->{$self->{dataName}}{$y}));
161 : dpvc 3483 }
162 :     $self->remove(@remove);
163 :     $self->add(@data);
164 :     }
165 : dpvc 2579
166 : dpvc 3483
167 : dpvc 2579 #
168 :     # Get hash for an item
169 :     #
170 :     sub get {
171 :     my $self = shift; my $x = shift;
172 :     return $self->{context}{$self->{dataName}}{$x};
173 :     }
174 :    
175 :     #
176 :     # Set flags for one or more items
177 :     #
178 :     sub set {
179 :     my $self = shift; my %D = (@_);
180 :     my $data = $self->{context}{$self->{dataName}};
181 :     foreach my $x (keys(%D)) {
182 : dpvc 2771 my $xref = $data->{$x};
183 :     if (defined($xref) && ref($xref) eq 'HASH') {
184 :     foreach my $id (keys %{$D{$x}}) {$xref->{$id} = $D{$x}{$id}}
185 :     } else {
186 :     $data->{$x} = $self->create($D{$x});
187 : dpvc 5116 $self->addToken($x);
188 : dpvc 2771 }
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 : dpvc 4975 END {
214 :     use Value::Context::Flags;
215 :     use Value::Context::Lists;
216 :     use Value::Context::Diagnostics;
217 :     }
218 : dpvc 2579
219 :     #########################################################################
220 :    
221 :     1;

aubreyja at gmail dot com
ViewVC Help
Powered by ViewVC 1.0.9