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__ |