File Coverage

blib/lib/Trinket/Object.pm
Criterion Covered Total %
statement 220 281 78.2
branch 29 58 50.0
condition 5 5 100.0
subroutine 42 48 87.5
pod 11 11 100.0
total 307 403 76.1


line stmt bran cond sub pod time code
1             ###########################################################################
2             ### Trinket::Object
3             ###
4             ### Base class for indexed persistent objects.
5             ###
6             ### $Id: Object.pm,v 1.3 2001/02/19 20:01:53 deus_x Exp $
7             ###
8             ### TODO:
9             ### -- Implement support for data types (char is only type for now)
10             ### -- Use classes/modules to define datatypes
11             ### -- Fix use of data type modules in the case of per-object
12             ### properties. (Broken right now)
13             ### -- Definable data types with different accessors,
14             ### index key generators
15             ### -- More detailed introspection on properties
16             ### -- Use hashes in BEGIN block property definitions versus arrays?
17             ### -- Use both for "backward" compatibility?
18             ### -- Instead of per-instance accessor generation, generate them
19             ### per-class in import()
20             ### -- Hooks in _get and _set to cooperate with any on-demand property
21             ### handling a Directory may implement
22             ### -- Property visibility, read only flag.
23             ### -- Data access levels, cooperate with ACLs
24             ### -- Have get_* and set_* methods, implement index_* methods?
25             ### -- Should something happen in DESTROY() ? (per warning)
26             ###
27             ###########################################################################
28              
29             package Trinket::Object;
30              
31 3     3   54996 use strict;
  3         8  
  3         145  
32 3     3   18 use vars qw($VERSION @ISA @EXPORT $DESCRIPTION $AUTOLOAD %PROPERTIES);
  3         5  
  3         265  
33 3     3   314 use Carp qw( croak cluck );
  3         14  
  3         194  
34 3     3   15 no warnings qw( uninitialized );
  3         10  
  3         390  
35              
36             # {{{ Begin POD
37              
38             =head1 NAME
39              
40             Trinket::Object - Base class for persistent objects managed by
41             Trinket::Directory
42              
43             =head1 SYNOPSYS
44              
45             {
46             package TestObject;
47              
48             BEGIN
49             {
50             our $VERSION = "0.0";
51             our @ISA = qw( Trinket::Object );
52             our $DESCRIPTION = 'Test object class';
53             our %PROPERTIES =
54             (
55             ### name => [ type, indexed, desc ]
56             mung => [ 'char', 1, 'Mung' ],
57             bar => [ 'char', 1, 'Bar' ],
58             baz => [ 'char', 0, 'Baz' ],
59             );
60             }
61              
62             use Trinket::Object;
63             }
64              
65             $obj = new TestObject({ mung => 'mung_value' });
66              
67             $obj->add_property( name => 'char', 0, 'The xzzxy property' );
68              
69             $obj->set_name('value');
70              
71             $obj->set(name=>'value');
72              
73             $obj->set(id=>'1',name=>'value',...);
74              
75             $val = $obj->get_name();
76              
77             $val = $obj->get('name');
78              
79             @vals = $obj->get('id','name');
80              
81             $obj->add_property(foo=>'char',0,'Foo property');
82              
83             $obj->remove_property('foo');
84              
85             =head1 DESCRIPTION
86              
87             Trinket::Object is the base class for all classes whose instances are
88             intended to be managed by Trinket::Directory.
89              
90             This base class serves several purposes: A mechanism is specified by
91             which object data properties are described; accessor (get_*) and
92             mutator (set_*) methods are automatically generated; changes in
93             properties are tracked to facilitate object storage and indexing
94              
95             The intent is to both serve as a convenient base class, as well as
96             provide means of interrogation to Trinket::Directory so that the
97             object can be managed transparently without any knowledge about the
98             directory in the object itself. This should allow the object to be
99             managed by any directory.
100              
101             =cut
102              
103             # }}}
104              
105             # {{{ METADATA
106              
107             BEGIN
108             {
109 3     3   6 $VERSION = "0.0";
110 3         62 @ISA = qw( Exporter );
111 3         6 $DESCRIPTION = 'Base object class';
112 3         36 %PROPERTIES =
113             (
114             ### name => [ type, indexed, desc ]
115             id => [ 'char', 1, 'Object ID' ],
116             # name => [ 'char', 1, 'Name' ],
117             class => [ 'char', 1, 'Class' ],
118             # modified => [ 'char', 1, 'Last modified' ],
119             # created => [ 'char', 1, 'Created' ],
120             # author => [ 'char', 1, 'Author' ],
121             directory => [ 'ref', 0, 'Directory' ],
122             );
123 3         88 @EXPORT =
124             qw(
125             &META_TYPES
126             &META_PROP_TYPE
127             &META_PROP_INDEXED
128             &META_PROP_DESC
129             &DIRTY_OLD_VALUE
130             &DIRTY_NEW_VALUE
131             &OBJ_META_PROPS
132             &OBJ_PROPS
133             &PROP_VALUE
134             &PROP_DIRTY
135             &PROP_CLEAN_VALUE
136             );
137             }
138              
139             # }}}
140              
141             # {{{ EXPORTS
142              
143             =head1 EXPORTS
144              
145             =head2 CONSTANTS
146              
147             =over 4
148              
149             =item * META_TYPES - List of datatypes supported by object properties
150              
151             =item * META_PROP_TYPE - Property metadata spec index to the data type
152             of the property. See: add_property()
153              
154             =item * META_PROP_INDEXED - Property metadata spec index to a 0/1 flag
155             indicating whether the property should be indexed. See: add_property()
156              
157             =item * META_PROP_DESC - Property metadata spec index to the text
158             description of the property. See: add_property()
159              
160             =item * DIRTY_OLD_VALUE - See:
161              
162             =item * DIRTY_NEW_VALUE
163              
164             =back
165              
166             TODO
167              
168             =cut
169              
170             # }}}
171              
172             # {{{ CONSTANTS
173              
174 3     3   88 use constant META_PROP_TYPE => 0;
  3         7  
  3         409  
175 3     3   17 use constant META_PROP_TYPE_KEY => 'type';
  3         6  
  3         149  
176 3     3   15 use constant META_PROP_INDEXED => 1;
  3         3  
  3         139  
177 3     3   14 use constant META_PROP_INDEXED_KEY => 'indexed';
  3         26  
  3         115  
178 3     3   22 use constant META_PROP_DESC => 2;
  3         11  
  3         131  
179 3     3   12 use constant META_PROP_DESC_KEY => 'desc';
  3         4  
  3         259  
180 3         514 use constant META_PROP_MAP =>
181             {
182             META_PROP_TYPE_KEY , META_PROP_TYPE,
183             META_PROP_INDEXED_KEY , META_PROP_INDEXED,
184             META_PROP_DESC_KEY , META_PROP_DESC
185 3     3   13 };
  3         5  
186 3     3   15 use constant META_PROP_INSTALLED => 3;
  3         14  
  3         142  
187              
188 3     3   14 use constant DIRTY_OLD_VALUE => 0;
  3         5  
  3         105  
189 3     3   13 use constant DIRTY_NEW_VALUE => 1;
  3         4  
  3         116  
190              
191 3     3   14 use constant OBJ_META_PROPS => 0;
  3         4  
  3         194  
192 3     3   12 use constant OBJ_PROPS => 1;
  3         4  
  3         128  
193              
194 3     3   13 use constant PROP_VALUE => 0;
  3         5  
  3         135  
195 3     3   13 use constant PROP_DIRTY => 1;
  3         3  
  3         109  
196 3     3   13 use constant PROP_CLEAN_VALUE => 2;
  3         5  
  3         107  
197              
198             # }}}
199              
200 3     3   2087 use Trinket::DataType::default;
  3         10  
  3         160  
201 3     3   1963 use Trinket::DataType::object;
  3         74  
  3         402  
202              
203             # {{{ METHODS
204              
205             =head1 METHODS
206              
207             =over 4
208              
209             =cut
210              
211             # }}}
212              
213             # {{{ new(): Object constructor
214              
215             =item $obj = new Trinket::Object({prop1=>'val1'});
216              
217             Object constructor, accepts a hashref of named properties with which to
218             initialize the object. In initialization, the object's set methods
219             are called for each of initializing properties passed. '
220              
221             =cut
222              
223             sub new
224             {
225 106     106 1 5155 my $class = shift;
226              
227 106         231 my $self = [];
228 106         333 $self->[OBJ_META_PROPS] = {};
229 106         306 $self->[OBJ_PROPS] = {};
230              
231 106         241 bless($self, $class);
232 106         496 $self->init(@_);
233 106         344 return $self;
234             }
235              
236             # }}}
237             # {{{ init(): Object initializer
238              
239             =item $obj->init({prop=>$value, prop2=>$value2, ...});
240              
241             =item $obj->init(prop=>$value, prop2=>$value2, ...);
242              
243             Object initializer, called by new() with the initializing parameters
244             sent to it. In the base class, this initializer iterates through each
245             of the properties supplied and calls the appropriate mutator to set
246             the value.
247              
248             This method never needs to be called directly, but it can
249             be overridden in subclasses.
250              
251             =cut
252              
253             sub init {
254 3     3   18 no strict 'refs';
  3         5  
  3         591  
255 106     106 1 226 my ($self) = shift;
256 106         176 my %props;
257              
258 106 100       414 if (ref($_[0]) eq 'HASH') {
259             ### If a hashref is passed, convert to a straight hash.
260 3         112 my $ref = shift;
261 3         21 %props = %$ref;
262             } else {
263             ### Otherwise, assume that this is a list to be used as hash.
264 103         576 %props = @_;
265             }
266              
267 106         209 my $mutator;
268 106         548 foreach (keys %props) {
269 509         807 $mutator = "set_$_";
270 509 50       2913 $self->$mutator($props{$_}) if (defined $props{$_});
271             }
272 106         837 $self->set_class( ref($self) );
273             }
274              
275             # }}}
276              
277             # {{{ AUTOLOAD: Generate get_/set_ mutators to object properties.
278              
279             =item AUTOLOAD
280              
281             The C method of this class automatically generates mutator and
282             accessor methods on demand if they do not already exist. These
283             methods each take the form of get_foo() and set_foo($value) where foo
284             is the name of an object property. If a method matching this pattern
285             already exists, C will not be called, and will not overwrite
286             it.
287              
288             =cut
289              
290             sub AUTOLOAD
291             {
292 3     3   17 no strict 'refs';
  3         6  
  3         1727  
293 13     13   351 my $self = shift;
294            
295             ### Was it a get_... method?
296 13 100       43 if ($AUTOLOAD =~ /.*::get_([\w_]+)/) {
297 1         3 my $attr_name = $1;
298              
299             ### Attempt to retrieve the metadata for this property
300 1         4 my $prop_meta = $self->_get_prop_meta($attr_name);
301 1 50       137 croak ("No such property '$attr_name' to get for $self")
302             if (!defined $prop_meta);
303            
304 0         0 my ($prop_type, $prop_type_params) =
305             split(/:/, $prop_meta->[META_PROP_TYPE]);
306 0         0 my $pkg = "Trinket::DataType::$prop_type";
307 0         0 eval "require $pkg";
308 0 0       0 $pkg = 'Trinket::DataType::default' if ($@);
309              
310 0         0 ($pkg)->install_methods($self, $attr_name);
311            
312 0         0 return ($pkg)->get($self, $attr_name, @_);
313             }
314              
315             ### Was it a set_... method?
316 12 50       77 if ($AUTOLOAD =~ /.*::set_([\w_]+)/) {
317 12         30 my $attr_name = $1;
318              
319             ### Attempt to retrieve the metadata for this property
320 12         36 my $prop_meta = $self->_get_prop_meta($attr_name);
321 12 100       285 croak ("No such property '$attr_name' to set for $self")
322             if (!defined $prop_meta);
323            
324 11         39 my ($prop_type, $prop_type_params) =
325             split(/:/, $prop_meta->[META_PROP_TYPE]);
326 11         26 my $pkg = "Trinket::DataType::$prop_type";
327 11         20484 eval "require $pkg";
328 11 50       108 $pkg = 'Trinket::DataType::default' if ($@);
329              
330 11         65 ($pkg)->install_methods($self, $attr_name);
331              
332 11         47 return ($pkg)->set($self, $attr_name, @_);
333             }
334              
335 0         0 croak("no such method: $AUTOLOAD");
336             }
337              
338             # }}}
339             # {{{ import()
340              
341             =item import
342              
343             The C method of this base class facilitates the inheritance of
344             class metadata. When a subclass is created, the list of properties
345             and other class definition data will be merged into the subclass' own
346             metadata. '
347              
348             =cut
349              
350             sub import {
351 3     3   18 no strict; ### Wooo, scary scary.
  3         4  
  3         3778  
352              
353 7     7   4658 my ($self) = shift;
354 7         45 my $pkg = (caller())[0];
355              
356             ### Alias the metadata for the class subclassing Toybox::Component
357 7         15 *PKG_PROPS = *{"$pkg\::PROPERTIES"};
  7         59  
358              
359             ### Prepare some scratch variables for the inheritance
360 7         22 my %props = ();
361              
362             ### Iterate through each of the class' superclasses
363 7         29 foreach my $anc_pkg (_derive_ancestry($pkg)) {
364             ### Skip metadata inheritance if this is not a subclass
365 14 100       110 next if (! UNIVERSAL::isa($anc_pkg, __PACKAGE__));
366            
367             ### Alias the superclass' metadata
368 4         8 *ANC_PROPS = *{"$anc_pkg\::PROPERTIES"};
  4         17  
369            
370             ### Inherit the metadata from this superclass
371 4         49 $props{$_} = $ANC_PROPS{$_} foreach (keys %ANC_PROPS);
372             }
373            
374             ### Finalize the inheritance. For the hash metadata, inherit those
375             ### values which are not already present in the class.
376 7         25 foreach(keys %props)
377 15 100       44 { $PKG_PROPS{$_} = $props{$_} if (! defined $PKG_PROPS{$_}); }
378              
379             # foreach my $name (keys %PKG_PROPS) {
380             # if ($PKG_PROPS{$name}->[META_PROP_INSTALLED]) {
381             # next;
382             # }
383             # $PKG_PROPS{$name}->[META_PROP_INSTALLED] = 1;
384            
385             # warn("IMPORT INSTALLING $name");
386             # my $prop_meta = $PKG_PROPS{$name};
387              
388             # if (!defined $prop_name) {
389             # die ("WHAT? $prop_name $pkg");
390             # }
391              
392             # my ($prop_type, $prop_type_params) =
393             # split(/:/, $prop_meta->[META_PROP_TYPE]);
394             # my $data_pkg = "Trinket::DataType::$prop_type";
395             # eval "require $data_pkg";
396             # $data_pkg = 'Trinket::DataType::default' if ($@);
397            
398             # ($data_pkg)->install_methods($pkg, $name);
399             # }
400            
401             ### Finally, call on Exporter's original import
402 7         12204 __PACKAGE__->export_to_level(1, \@_);
403             }
404              
405             # }}}
406             # {{{ set(): Object property mutator
407              
408             =item $obj->set(name=>'value');
409              
410             In addition to auto-generated property mutators, set() is a generic
411             mutator which can be used to set properties by name, and to set more
412             than one in a single method call.
413              
414             Note that this method accesses object property data directly, and does
415             not call any overridden mutators in a subclass. Because of this, this
416             method should only be used in overriding mutators and possibly object
417             directory data access backends.
418              
419             =cut
420              
421             sub set {
422 0     0 1 0 my ($self, $name, $val) = @_;
423            
424             ### Attempt to retrieve the metadata for this property
425 0         0 my $prop_meta = $self->_get_prop_meta($name);
426 0 0       0 if (!defined $prop_meta) {
427 0         0 die "No such property '$name' to set for $self";
428             } else {
429 0         0 my ($prop_type, $prop_type_params) =
430             split(/:/, $prop_meta->[META_PROP_TYPE]);
431              
432 0         0 my $pkg = "Trinket::DataType::$prop_type";
433 0         0 eval "require $pkg";
434 0 0       0 if ($@) {
435 0         0 $pkg = 'Trinket::DataType::default';
436             }
437 0         0 return ($pkg)->set(@_);
438             }
439             }
440              
441             # }}}
442             # {{{ get(): Object property accessor
443              
444             =item $val = $obj->get('name');
445              
446             In addition to auto-generated property accessors, get() is a generic
447             mutator which can be used to get properties by name, and to get more
448             than one in a single method call.
449              
450             Note that this method accesses object property data directly, and does
451             not call any overridden accessors in a subclass. Because of this,
452             this method should only be used in overriding accessors and possibly
453             object directory data access backends.
454              
455             =cut
456              
457             sub get {
458 954     954 1 1620 my ($self, $name) = @_;
459              
460             ### Attempt to retrieve the metadata for this property
461 954         2036 my $prop_meta = $self->_get_prop_meta($name);
462 954 50       2905 if (!defined $prop_meta) {
463 0         0 die "No such property '$name' to get for $self";
464             } else {
465 954         3378 my ($prop_type, $prop_type_params) =
466             split(/:/, $prop_meta->[META_PROP_TYPE]);
467              
468 954         2512 my $pkg = "Trinket::DataType::$prop_type";
469 954         70761 eval "require $pkg";
470 954 50       11174 if ($@) {
471 954         2021 $pkg = 'Trinket::DataType::default';
472             }
473 954         6132 return ($pkg)->get(@_);
474             }
475             }
476              
477             # }}}
478              
479             # {{{ has_property(): Test for property availability
480              
481             =item $obj->has_property('name')
482              
483             Tests whether an object has a given property.
484              
485             =cut
486              
487             sub has_property {
488 0     0 1 0 my ($self, $name) = @_;
489              
490             ### Attempt to retrieve the metadata for this property
491 0         0 my $prop_meta = $self->_get_prop_meta($name);
492 0 0       0 if (!defined $prop_meta) {
493 0         0 return undef;
494             } else {
495 0         0 return 1;
496             }
497             }
498              
499             # }}}
500             # {{{ type_property(): Get a property's type
501              
502             =item $obj->type_property('name')
503              
504             Query the data type for a given property
505              
506             =cut
507              
508             sub type_property {
509 0     0 1 0 my ($self, $name) = @_;
510              
511             ### Attempt to retrieve the metadata for this property
512 0         0 my $prop_meta = $self->_get_prop_meta($name);
513 0 0       0 if (!defined $prop_meta) {
514 0         0 return undef;
515             } else {
516 0         0 my ($prop_type, $prop_type_params);
517 0 0       0 if ($prop_meta->[META_PROP_TYPE] =~ /([^:]+):(.*)/) {
518 0         0 $prop_type = $1;
519 0         0 $prop_type_params = $2;
520             } else {
521 0         0 $prop_type = $prop_meta->[META_PROP_TYPE];
522 0         0 $prop_type_params = undef;
523             }
524              
525 0         0 return $prop_type, $prop_type_params;
526             }
527             }
528              
529             # }}}
530             # {{{ describe_property(): Get a property's type
531              
532             =item $obj->describe_property('name')
533              
534             Query the data type for a given property
535              
536             =cut
537              
538             sub describe_property {
539 0     0 1 0 my ($self, $name) = @_;
540              
541             ### Attempt to retrieve the metadata for this property
542 0         0 my $prop_meta = $self->_get_prop_meta($name);
543 0 0       0 if (!defined $prop_meta) {
544 0         0 return undef;
545             } else {
546 0         0 return $prop_meta->[META_PROP_DESC];
547             }
548             }
549              
550             # }}}
551             # {{{ add_property(): Add a property to the object
552              
553             =item $obj->add_property(name=>'type',0,'Description');
554              
555             Add a property to the object. The new property will be available to
556             get and set methods, and will be handled by the object directory.
557              
558             The metadata supplied are the property name, whether the property
559             should be indexed (0/1), and a description of the property.
560              
561             =cut
562              
563             sub add_property
564             {
565 3     3 1 435 my ($self, $name, $type, $indexed, $desc) = @_;
566              
567 3         7 my $prop_spec = [];
568 3         6 $prop_spec->[META_PROP_TYPE] = $type;
569 3         5 $prop_spec->[META_PROP_INDEXED] = $indexed;
570 3         5 $prop_spec->[META_PROP_DESC] = $desc;
571            
572 3         9 my ($prop_type, $prop_type_params) = split(/:/, $type);
573 3         6 my $pkg = "Trinket::DataType::$prop_type";
574 3         183 eval "require $pkg";
575 3 50       19 $pkg = 'Trinket::DataType::default' if ($@);
576 3         15 ($pkg)->install_methods($self, $name);
577            
578 3         13 return $self->_set_prop_meta($name => $prop_spec);
579             }
580              
581             # }}}
582             # {{{ remove_property(): Delete a property from the object
583              
584             =item $obj->remove_property('prop_name');
585              
586             Remove a named property from the object. After deletion, it will no
587             longer be recognized as a property to set or get, and will not be used
588             by the object directory in any operations.
589              
590             =cut
591              
592             sub remove_property
593             {
594 2     2 1 200 my ($self, $name, $meta) = @_;
595              
596             ### Delete the property data from the object
597 2         7 delete $self->[OBJ_PROPS]->{$name};
598              
599 2         7 my $prop_meta = $self->_get_prop_meta($name);
600 2         8 my ($prop_type, $prop_type_params) =
601             split(/:/, $prop_meta->[META_PROP_TYPE]);
602 2         4 my $pkg = "Trinket::DataType::$prop_type";
603 2         136 eval "require $pkg";
604 2 50       15 $pkg = 'Trinket::DataType::default' if ($@);
605 2         15 ($pkg)->uninstall_methods($self, $name);
606            
607             ### Delete the property metadata from the object
608 2         11 return $self->_set_prop_meta($name => undef);
609             }
610              
611             # }}}
612             # {{{ list_properties(): List property names in the object.
613              
614             =item $obj->list_properties();
615              
616             Return a list of properties in the object.
617              
618             =cut
619              
620             sub list_properties
621             {
622 106     106 1 208 my ($self) = @_;
623              
624 106         261 my @props = ();
625             {
626 3     3   20 no strict 'refs';
  3         14  
  3         2960  
  106         143  
627 106         228 my $pkg = ref($self);
628 106         194 foreach (keys %{"$pkg\::PROPERTIES"})
  106         627  
629 954         1372 { push @props, $_; }
630             }
631 106         317 foreach (keys %{$self->[OBJ_META_PROPS]})
  106         424  
632 0         0 { push @props, $_; }
633              
634 106         587 return @props;
635             }
636              
637             # }}}
638             # {{{ list_indices(): List property names in the object.
639              
640             =item $obj->list_indices();
641              
642             Return a list of indexed properties in the object.
643              
644             =cut
645              
646             sub list_indices
647             {
648 0     0 1 0 my ($self) = @_;
649              
650 0         0 my @indices = ();
651 0         0 my $props = $self->[OBJ_PROPS];
652 0         0 my ($name, $prop, $prop_meta);
653 0         0 while (($name, $prop) = each %{$props})
  0         0  
654             {
655 0         0 $prop_meta = $self->_get_prop_meta($name);
656 0 0       0 push @indices if ($prop_meta->[META_PROP_INDEXED]);
657             }
658              
659 0         0 return @indices;
660             }
661              
662             # }}}
663              
664             # {{{ _find_dirty(): Find dirty indexed properties, return old/new values
665              
666             sub _find_dirty
667             {
668 6     6   397 my $self = shift;
669              
670 6         8 my (%dirty_props, $name, $prop, $prop_meta);
671 6         9 my $props = $self->[OBJ_PROPS];
672 6         10 while (($name, $prop) = each %{$props})
  17         63  
673             {
674 11         30 $prop_meta = $self->_get_prop_meta($name);
675 11 100       26 if ($prop->[PROP_DIRTY])
676             {
677 4         15 $dirty_props{$name} = [ $prop->[PROP_CLEAN_VALUE],
678             $prop->[PROP_VALUE] ];
679             }
680             }
681              
682 6         19 return \%dirty_props;
683             }
684              
685             # }}}
686             # {{{ _find_dirty_indices(): Find dirty indexed properties, return old/new values
687              
688             sub _find_dirty_indices {
689 108     108   247 my $self = shift;
690              
691 108         204 my (%dirty_props, $name, $prop, $prop_meta);
692 108         1272 my $props = $self->[OBJ_PROPS];
693 108         200 while (($name, $prop) = each %{$props}) {
  1067         4123  
694 959         2909 $prop_meta = $self->_get_prop_meta($name);
695 959 100       2362 if ($prop_meta->[META_PROP_INDEXED]) {
696 745 100       2005 if ($prop->[PROP_DIRTY]) {
697 636         3921 $dirty_props{$name} = [ $prop->[PROP_CLEAN_VALUE],
698             $prop->[PROP_VALUE] ];
699             }
700             }
701             }
702            
703 108         1206 return \%dirty_props;
704             }
705              
706             # }}}
707             # {{{ _clean_all(): Mark all dirty properties as clean.
708              
709             sub _clean_all
710             {
711 108     108   770 my $self = shift;
712              
713 108         184 my (%dirty_props);
714 108         271 my $props = $self->[OBJ_PROPS];
715 108         185 while (my($name, $prop) = each %{$props})
  1066         2969  
716 958         1974 { $prop->[PROP_DIRTY] = 0; }
717              
718 108         347 return \%dirty_props;
719             }
720              
721             # }}}
722             # {{{ _dirty_all(): Mark all dirty properties as clean.
723              
724             sub _dirty_all {
725 7     7   15 my $self = shift;
726            
727 7         10 my (%dirty_props);
728 7         15 my $props = $self->[OBJ_PROPS];
729 7         15 while (my($name, $prop) = each %{$props}) {
  67         190  
730 60         101 $prop->[PROP_DIRTY] = 1;
731             }
732            
733 7         24 return \%dirty_props;
734             }
735              
736             # }}}
737              
738             # {{{ _set_prop_meta(): Set the metadata for a named property
739              
740             sub _set_prop_meta
741             {
742 5     5   10 my ($self, $name, $meta) = @_;
743              
744 5 100       13 if (defined $meta)
745 3         56 { return $self->[OBJ_META_PROPS]->{$name} = $meta; }
746             else
747             {
748 2         17 delete $self->[OBJ_META_PROPS]->{$name};
749 2         8 return undef;
750             }
751             }
752              
753             # }}}
754             # {{{ _get_prop_meta(): Get the metadata for a named property
755              
756             sub _get_prop_meta {
757 3     3   20 no strict 'refs';
  3         14  
  3         1417  
758 1939     1939   2859 my ($self, $name) = @_;
759            
760             ### Attempt to retrieve the metadata for this property
761 1939         2754 my $pkg = ref($self);
762 1939         2054 my $prop_meta;
763              
764             $prop_meta = $self->[OBJ_META_PROPS]->{$name} ||
765 1939   100     9578 (${"$pkg\::PROPERTIES"}{$name});
766            
767             ### Convert hash-style definition into array-style
768             ### TODO: Need to cache this!
769 1939 50       9723 if (ref($prop_meta) eq "HASH") {
770 0         0 my $new_prop_meta = [];
771 0         0 my $prop_map = META_PROP_MAP;
772 0         0 foreach my $map_name ( keys %{$prop_map} ) {
  0         0  
773 0         0 $new_prop_meta->[$prop_map->{$map_name}] = $prop_meta->{$map_name};
774             }
775            
776 0         0 $prop_meta = $new_prop_meta;
777            
778 0 0       0 if (defined $self->[OBJ_META_PROPS]->{$name}) {
  0 0       0  
779 0         0 $self->[OBJ_META_PROPS]->{$name} = $prop_meta;
780             } elsif (defined ${"$pkg\::PROPERTIES"}{$name}) {
781 0         0 ${"$pkg\::PROPERTIES"}{$name} = $prop_meta;
  0         0  
782             }
783             }
784              
785 1939         4028 return $prop_meta;
786             }
787              
788             # }}}
789             # {{{ _derive_ancestry(): Derive the class ancestry for an object or class
790              
791             sub _derive_ancestry
792             {
793 332     332   664 my $obj = shift;
794 332   100     1222 my $anc = shift || {};
795              
796 332 100       1153 my $class = (ref($obj)) ? ref($obj) : $obj;
797              
798 332         19558 my @isa = eval('@'.$class.'::ISA');
799              
800             ### Iterate through each class in the ancestry and mark it,
801             ### then derive ancestry for each class in the ancestry
802 332         1847 $anc->{$class}++;
803 332         954 foreach (@isa)
804 219         622 { _derive_ancestry($_, $anc); }
805              
806             ### Return the list of ancestors for this class.
807 332         1644 return keys %$anc;
808             }
809              
810             # }}}
811              
812             # {{{ DESTROY
813              
814             sub DESTROY
815 0     0     {
816             ## no-op to pacify warnings
817             }
818              
819             # }}}
820              
821             # {{{ End POD
822              
823             =back
824              
825             =head1 AUTHOR
826              
827             Maintained by Leslie Michael Orchard >
828              
829             =head1 COPYRIGHT
830              
831             Copyright (c) 2000, Leslie Michael Orchard. All Rights Reserved.
832             This module is free software; you can redistribute it and/or
833             modify it under the same terms as Perl itself.
834              
835             =cut
836              
837             # }}}
838              
839             1;
840             __END__