1 |
package Xot::Accessors; |
package Xot::Accessors; |
2 |
use strict; |
use strict; |
3 |
|
use Xot::Misc qw':all'; |
4 |
use Data::Dumper; |
use Data::Dumper; |
5 |
use Carp; |
use Carp (); |
6 |
|
|
7 |
our $AUTOLOAD; |
my %_mmap = ( '_one' => '%s', |
8 |
my (%Valid, %Multi); |
'_add' => 'add_%s', |
9 |
|
'_remove' => 'remove_%s', |
10 |
|
'_names' => '%s_names', |
11 |
|
'_vals' => '%ss', |
12 |
|
); |
13 |
my $uniquifier = 0; |
my $uniquifier = 0; |
14 |
|
|
15 |
|
|
16 |
|
=head1 NAME |
17 |
|
|
18 |
|
Xot::Accessors - Perl class for creating commonly used constructors |
19 |
|
and accessors on demand for objects created from a XML::Twig parsing |
20 |
|
run |
21 |
|
|
22 |
|
=head1 SYNOPSIS |
23 |
|
|
24 |
|
package Foo; |
25 |
|
use base 'Xot::Accessors'; |
26 |
|
|
27 |
|
Foo->plain(qw(foo)); |
28 |
|
Foo->multi(qw(bar)); |
29 |
|
|
30 |
|
sub init |
31 |
|
{ |
32 |
|
... do object initialization |
33 |
|
} |
34 |
|
|
35 |
|
and now Foo has methods new (that calls init), foo, add_bar, bar, |
36 |
|
bars, and bar_names. |
37 |
|
|
38 |
|
FIXME: flesh this out |
39 |
|
|
40 |
|
=head1 METHODS |
41 |
|
|
42 |
|
=head2 new |
43 |
|
|
44 |
|
A constructor. Blesses an empty hash reference into the class. |
45 |
|
|
46 |
|
=cut |
47 |
|
|
48 |
|
|
49 |
sub new |
sub new |
50 |
{ |
{ |
51 |
my $class = shift; |
my $class = shift; |
52 |
my $self = bless {}, $class; |
my $self = bless {}, $class; |
53 |
|
|
54 |
|
Carp::croak("class $class doesn't provide an init method") |
55 |
|
unless $self->can('init'); |
56 |
|
|
57 |
$self->init(@_); |
$self->init(@_); |
58 |
|
|
59 |
return $self; |
return $self; |
60 |
} |
} |
61 |
|
|
62 |
|
=head2 _set <key>, <value> |
63 |
|
|
64 |
|
=head2 _hide <key>, <value> |
65 |
|
|
66 |
|
=head2 _get <key> |
67 |
|
|
68 |
|
The setter/getter pair, called by the named methods created by plain |
69 |
|
or hider (so if you override new to use a different kind of object, |
70 |
|
you can overrite _set (or _hide) and _get to access the new object, |
71 |
|
but still have Xot::Accessors create the accessors for you). |
72 |
|
|
73 |
|
=cut |
74 |
|
|
75 |
sub _set |
sub _set |
76 |
{ |
{ |
77 |
my ($self, $key) = splice @_, 0, 2; |
my ($self, $key) = splice @_, 0, 2; |
81 |
} |
} |
82 |
else |
else |
83 |
{ |
{ |
84 |
Carp::confess("Wrong number of arguments"); |
Carp::croak("Wrong number of arguments"); |
85 |
|
} |
86 |
|
|
87 |
|
undef; |
88 |
|
} |
89 |
|
|
90 |
|
sub _hide |
91 |
|
{ |
92 |
|
my ($self, $key) = splice @_, 0, 2; |
93 |
|
|
94 |
|
if (@_==1) { |
95 |
|
my $secret = shift; |
96 |
|
$self->{uc $key} = sub {return $secret}; |
97 |
|
} |
98 |
|
else |
99 |
|
{ |
100 |
|
Carp::croak("Wrong number of arguments"); |
101 |
} |
} |
102 |
|
|
103 |
undef; |
undef; |
108 |
my ($self, $key) = splice @_, 0, 2; |
my ($self, $key) = splice @_, 0, 2; |
109 |
if (@_) |
if (@_) |
110 |
{ |
{ |
111 |
Carp::confess("Wrong number of arguments"); |
Carp::croak("Wrong number of arguments"); |
112 |
} |
} |
113 |
|
|
114 |
return $self->{uc $key} |
return $self->{uc $key} |
115 |
} |
} |
116 |
|
|
117 |
|
=head2 plain <name> ... |
118 |
|
|
119 |
|
takes a list of names as argument and sets up a method B<in the |
120 |
|
callers namespace> called as that argument that gets (and optionally |
121 |
|
sets) the entry in the hash whose key is the uppercase of the name |
122 |
|
provided. |
123 |
|
|
124 |
|
=cut |
125 |
|
|
126 |
sub plain |
sub plain |
127 |
{ |
{ |
128 |
my $class = shift; |
my $class = shift; |
129 |
|
|
130 |
foreach (@_) { |
foreach (@_) |
131 |
eval sprintf('package %s; sub %s {my $s = shift; $s->_set("%s", @_) if @_;return $s->_get("%s");}', |
{ |
132 |
|
eval sprintf(q(package %s; sub %s { my $s = shift; $s->_set('%s', @_) if @_; return $s->_get('%s') }), |
133 |
|
$class, $_, $_, $_); |
134 |
|
Carp::croak("unable to create '$_' method: $@") if $@; |
135 |
|
} |
136 |
|
} |
137 |
|
|
138 |
|
=head2 hider <name> ... |
139 |
|
|
140 |
|
like plain, but puts the value inside a closure to make sure it's privage |
141 |
|
|
142 |
|
=cut |
143 |
|
|
144 |
|
sub hider |
145 |
|
{ |
146 |
|
my $class = shift; |
147 |
|
foreach (@_) |
148 |
|
{ |
149 |
|
eval sprintf(q(package %s; sub %s { my $s = shift; $s->_hide('%s', @_) if @_; return $s->_get('%s')->() }), |
150 |
$class, $_, $_, $_); |
$class, $_, $_, $_); |
151 |
Carp::confess("unable to create '$_' method: $@") if $@; |
Carp::croak("unable to create '$_' method: $@") if $@; |
152 |
} |
} |
153 |
} |
} |
154 |
|
|
155 |
|
=head2 multi <name> => <value> ... |
156 |
|
|
157 |
|
takes a list of pairs name => class, and creates methods to add, |
158 |
|
remove, and list the items provided. |
159 |
|
|
160 |
|
=cut |
161 |
|
|
162 |
sub multi |
sub multi |
163 |
{ |
{ |
164 |
my $class = shift; |
my $class = shift; |
165 |
my %args = (@_); |
my %class = (@_); |
166 |
my %h; |
my %h; |
167 |
foreach (keys %args) { |
foreach my $name (keys %class) |
168 |
eval sprintf('package %s; sub %s {my $s = shift; return $s->_one("%s", "%s", @_)}', |
{ |
169 |
$class, $_, $_, $args{$_}); |
foreach my $priv (keys %_mmap) |
170 |
Carp::confess("unable to create '$_' method: $@") if $@; |
{ |
171 |
eval sprintf('package %s; sub add_%s {my $s = shift; return $s->_add("%s", "%s", @_)}', |
my $pub = sprintf $_mmap{$priv}, $name; |
172 |
$class, $_, $_, $args{$_}); |
|
173 |
Carp::confess("unable to create 'add_$_' method: $@") if $@; |
eval "package $class; sub $pub { my \$s = shift; return \$s->$priv('$name', '$class{$name}', \@_)}"; |
174 |
eval sprintf('package %s; sub %s_names {my $s = shift; return $s->_names("%s", "%s", @_)}', |
Carp::croak("unable to create $pub method: $@") if $@; |
175 |
$class, $_, $_, $args{$_}); |
} |
|
Carp::confess("unable to create '${_}_names' method: $@") if $@; |
|
|
eval sprintf('package %s; sub %ss {my $s = shift; return $s->_vals("%s", "%s", @_)}', |
|
|
$class, $_, $_, $args{$_}); |
|
|
Carp::confess("unable to create '${_}s method: $@") if $@; |
|
|
|
|
176 |
} |
} |
177 |
} |
} |
178 |
|
|
179 |
sub twig |
=head2 _names <key> |
180 |
|
|
181 |
|
Returns the list of names of the objects in the specified container. |
182 |
|
|
183 |
|
=cut |
184 |
|
|
185 |
|
sub _names |
186 |
{ |
{ |
187 |
my ($self, $twig) = splice @_, 0, 2; |
my ($self, $key) = @_; |
188 |
|
return keys %{ $self->{uc $key} || {} }; |
189 |
|
} |
190 |
|
|
191 |
$self->{TWIG} = sub{ return $twig } |
=head2 _vals <key> |
|
if defined $twig; |
|
192 |
|
|
193 |
return $self->{TWIG}->(); |
Returns the list of the objects in the specifeid container. |
194 |
|
|
195 |
|
=cut |
196 |
|
|
197 |
|
sub _vals |
198 |
|
{ |
199 |
|
my ($self, $key) = @_; |
200 |
|
return values %{ $self->{uc $key} || {} }; |
201 |
} |
} |
202 |
|
|
203 |
|
=head2 _add <key>, <class>, <name> |
204 |
|
|
205 |
|
Adds one of the specified objects to the specified container. |
206 |
|
|
207 |
|
=cut |
208 |
|
|
209 |
sub _add |
sub _add |
210 |
{ |
{ |
211 |
my ($self, $key, $class, $twig) = splice @_, 0, 4; |
my ($self, $key, $class, $name) = splice @_, 0, 4; |
212 |
|
|
213 |
Carp::confess("Must call add_$key with a twig") |
$name = sprintf('UNNAMED_%04X', $uniquifier++) |
214 |
unless defined $twig; |
unless defined $name; |
215 |
|
|
216 |
my $name = $twig->att("name") || sprintf('UNNAMED_%04X', $uniquifier++); |
my $new = $class->new($self, $name, @_); |
|
my $new = $class->new($self, $twig); |
|
217 |
$self->$key($name => $new); |
$self->$key($name => $new); |
218 |
|
|
219 |
|
return $new; |
220 |
} |
} |
221 |
|
|
222 |
|
=head2 _remove <key>, <name> |
223 |
|
|
224 |
|
Removes the specified object from the specified container. |
225 |
|
|
226 |
|
=cut |
227 |
|
|
228 |
|
sub _remove |
229 |
|
{ |
230 |
|
my ($self, $key, $name) = @_; |
231 |
|
|
232 |
|
Carp::croak("Must call remove_$key with a name") |
233 |
|
unless defined $name; |
234 |
|
|
235 |
|
delete $self->{uc $key}->{$name} |
236 |
|
} |
237 |
|
|
238 |
|
=head2 _one <key>, <class>, <name>, [<value>] |
239 |
|
|
240 |
|
Singular getter/setter for a specified object in a specified container. |
241 |
|
|
242 |
|
=cut |
243 |
|
|
244 |
sub _one |
sub _one |
245 |
{ |
{ |
246 |
my ($self, $key, $class, $name, $value) = splice @_, 0, 5; |
my ($self, $key, $class, $name, $value) = splice @_, 0, 5; |
254 |
return $self->{uc $key}->{$name}; |
return $self->{uc $key}->{$name}; |
255 |
} |
} |
256 |
|
|
257 |
sub _names |
=head1 BUGS |
|
{ |
|
|
my ($self, $key) = @_; |
|
|
return keys %{ $self->{uc $key} || {} }; |
|
|
} |
|
258 |
|
|
259 |
sub _vals |
This is essentially Class::Accessor. |
260 |
{ |
|
261 |
my ($self, $key) = @_; |
=head1 SEE ALSO |
262 |
return values %{ $self->{uc $key} || {} }; |
|
263 |
} |
L<Class::Accessor(3)> |
264 |
|
|
265 |
|
=head1 COPYRIGHT |
266 |
|
|
267 |
|
(C) 2003 John R. Lenton <john@vialibre.org.ar>, for Fundación Vía Libre |
268 |
|
|
269 |
|
=cut |
270 |
|
|
271 |
1; |
1; |