/[papo]/papo/xot/Xot/Accessors.pm
ViewVC logotype

Diff of /papo/xot/Xot/Accessors.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by jlenton, Mon Jun 30 03:42:06 2003 UTC revision 1.2 by jlenton, Thu Jul 3 23:53:47 2003 UTC
# Line 1  Line 1 
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;
# Line 26  sub _set Line 81  sub _set
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;
# Line 37  sub _get Line 108  sub _get
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;
# Line 111  sub _one Line 254  sub _one
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;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26