line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Elive::DAO; |
2
|
36
|
|
|
36
|
|
39306
|
use warnings; use strict; |
|
36
|
|
|
36
|
|
57
|
|
|
36
|
|
|
|
|
1356
|
|
|
36
|
|
|
|
|
159
|
|
|
36
|
|
|
|
|
52
|
|
|
36
|
|
|
|
|
1078
|
|
3
|
|
|
|
|
|
|
|
4
|
36
|
|
|
36
|
|
570
|
use Mouse; |
|
36
|
|
|
|
|
24115
|
|
|
36
|
|
|
|
|
178
|
|
5
|
36
|
|
|
36
|
|
9116
|
use Mouse::Util::TypeConstraints; |
|
36
|
|
|
|
|
66
|
|
|
36
|
|
|
|
|
187
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
our $VERSION = '0.08'; |
8
|
|
|
|
|
|
|
|
9
|
36
|
|
|
36
|
|
4899
|
use parent 'Elive::DAO::_Base'; |
|
36
|
|
|
|
|
1087
|
|
|
36
|
|
|
|
|
231
|
|
10
|
|
|
|
|
|
|
|
11
|
36
|
|
|
36
|
|
2879
|
use YAML::Syck; |
|
36
|
|
|
|
|
4717
|
|
|
36
|
|
|
|
|
2268
|
|
12
|
36
|
|
|
36
|
|
189
|
use Scalar::Util qw{weaken}; |
|
36
|
|
|
|
|
50
|
|
|
36
|
|
|
|
|
2132
|
|
13
|
36
|
|
|
36
|
|
166
|
use Carp; |
|
36
|
|
|
|
|
62
|
|
|
36
|
|
|
|
|
1508
|
|
14
|
36
|
|
|
36
|
|
3782
|
use Try::Tiny; |
|
36
|
|
|
|
|
7774
|
|
|
36
|
|
|
|
|
1645
|
|
15
|
36
|
|
|
36
|
|
8727
|
use URI; |
|
36
|
|
|
|
|
73987
|
|
|
36
|
|
|
|
|
992
|
|
16
|
|
|
|
|
|
|
|
17
|
36
|
|
|
36
|
|
12732
|
use Elive::Util qw{0.01}; |
|
36
|
|
|
|
|
91
|
|
|
36
|
|
|
|
|
217836
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_entities' => {}); |
20
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_aliases'); |
21
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_derivable' => {}); |
22
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_entity_name'); |
23
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_primary_key' => []); |
24
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_params' => {}); |
25
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('collection_name'); |
26
|
|
|
|
|
|
|
__PACKAGE__->mk_classdata('_isa'); |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
foreach my $accessor (qw{_db_data _deleted _is_copy}) { |
29
|
|
|
|
|
|
|
__PACKAGE__->has_metadata($accessor); |
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
=head1 NAME |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
Elive::DAO - Abstract class for Elive Data Access Objects |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
=head1 DESCRIPTION |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
This is an abstract class for retrieving and managing objects mapped to a |
39
|
|
|
|
|
|
|
datastore. |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
=cut |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
our %Stored_Objects; |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
sub BUILDARGS { |
46
|
0
|
|
|
0
|
1
|
0
|
my ($class, $raw, @args) = @_; |
47
|
|
|
|
|
|
|
|
48
|
0
|
0
|
|
|
|
0
|
warn "$class - ignoring arguments to new: @args\n" |
49
|
|
|
|
|
|
|
if @args; |
50
|
|
|
|
|
|
|
|
51
|
0
|
0
|
|
|
|
0
|
if (Elive::Util::_reftype($raw) eq 'HASH') { |
52
|
|
|
|
|
|
|
|
53
|
0
|
|
|
|
|
0
|
my $types = $class->property_types; |
54
|
|
|
|
|
|
|
|
55
|
0
|
|
|
|
|
0
|
my %cooked; |
56
|
|
|
|
|
|
|
|
57
|
0
|
|
|
|
|
0
|
my $aliases = $class->_get_aliases; |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
0
|
foreach (keys %$raw) { |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
# |
62
|
|
|
|
|
|
|
# apply any aliases |
63
|
|
|
|
|
|
|
# |
64
|
|
|
|
|
|
|
|
65
|
0
|
0
|
0
|
|
|
0
|
my $prop = (exists $aliases->{$_} |
66
|
|
|
|
|
|
|
? ($aliases->{$_}{to} or die "$class has malformed alias: $_") |
67
|
|
|
|
|
|
|
: $_); |
68
|
|
|
|
|
|
|
|
69
|
0
|
|
|
|
|
0
|
my $value = $raw->{$_}; |
70
|
0
|
0
|
|
|
|
0
|
if (my $type = $types->{$prop}) { |
71
|
0
|
0
|
|
|
|
0
|
if (ref($value)) { |
72
|
|
|
|
|
|
|
# |
73
|
|
|
|
|
|
|
# inspect the item to see if we need to stringify an |
74
|
|
|
|
|
|
|
# object to obtain a simple string. The property is |
75
|
|
|
|
|
|
|
# likely to be a foreign key. |
76
|
|
|
|
|
|
|
# |
77
|
0
|
0
|
|
|
|
0
|
$value = Elive::Util::string($value, $type) |
78
|
|
|
|
|
|
|
unless Elive::Util::inspect_type($type)->is_ref; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
} |
81
|
|
|
|
|
|
|
else { |
82
|
0
|
|
|
|
|
0
|
Carp::carp "$class: unknown property: $prop"; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
0
|
$cooked{$prop} = $value; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
0
|
|
|
|
|
0
|
return \%cooked; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
0
|
|
|
|
|
0
|
return $raw; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
=head1 METHODS |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=cut |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
sub stringify { |
99
|
218
|
|
|
218
|
1
|
239
|
my $class = shift; |
100
|
218
|
|
|
|
|
196
|
my $data = shift; |
101
|
|
|
|
|
|
|
|
102
|
218
|
50
|
33
|
|
|
463
|
$data = $class |
103
|
|
|
|
|
|
|
if !defined $data && ref $class; |
104
|
|
|
|
|
|
|
|
105
|
218
|
50
|
33
|
|
|
579
|
return $data |
106
|
|
|
|
|
|
|
unless $data && Elive::Util::_reftype($data); |
107
|
|
|
|
|
|
|
|
108
|
218
|
50
|
|
|
|
473
|
my @primary_key = $class->primary_key |
109
|
|
|
|
|
|
|
or return; # weak entity - e.g. Elive::StandardV2::ServerVersions |
110
|
|
|
|
|
|
|
|
111
|
218
|
|
|
|
|
1885
|
my $types = $class->property_types; |
112
|
|
|
|
|
|
|
|
113
|
218
|
|
|
|
|
332
|
my $string = join('/', map {Elive::Util::_freeze($data->{$_}, |
|
218
|
|
|
|
|
587
|
|
114
|
|
|
|
|
|
|
$types->{$_})} |
115
|
|
|
|
|
|
|
@primary_key); |
116
|
|
|
|
|
|
|
|
117
|
218
|
|
|
|
|
1608
|
return $string; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
=head2 entity_name |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
my $entity_name = MyApp::Entity::User->entity_name |
123
|
|
|
|
|
|
|
ok($entity_name eq 'user'); |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
=cut |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
sub entity_name { |
128
|
37
|
|
|
37
|
1
|
96
|
my $entity_class = shift; |
129
|
|
|
|
|
|
|
|
130
|
37
|
50
|
|
|
|
98
|
if (my $entity_name = shift) { |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
# |
133
|
|
|
|
|
|
|
# Set our entity name. Register it in our parent |
134
|
|
|
|
|
|
|
# |
135
|
37
|
|
|
|
|
234
|
$entity_class->_entity_name(ucfirst($entity_name)); |
136
|
|
|
|
|
|
|
|
137
|
37
|
|
|
|
|
1191
|
my $entities = $entity_class->_entities; |
138
|
|
|
|
|
|
|
|
139
|
37
|
50
|
|
|
|
290
|
die "Entity $entity_name redeclared " |
140
|
|
|
|
|
|
|
if exists $entities->{$entity_name}; |
141
|
|
|
|
|
|
|
|
142
|
37
|
|
|
|
|
102
|
$entities->{lcfirst($entity_name)} = $entity_class; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
37
|
|
|
|
|
94
|
return $entity_class->_entity_name; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
=head2 collection_name |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
my $collection_name = MyApp::Entity::User->collection_name |
151
|
|
|
|
|
|
|
ok($collection_name eq 'users'); |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=cut |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# Class::Data::Inheritable property |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# _alias, _get_aliases |
158
|
|
|
|
|
|
|
# |
159
|
|
|
|
|
|
|
# MyApp::Entity::Meeting->_alias(requiredSeats => 'seats'); |
160
|
|
|
|
|
|
|
# |
161
|
|
|
|
|
|
|
# Return or set data mappings. |
162
|
|
|
|
|
|
|
# |
163
|
|
|
|
|
|
|
# These methods assist with the handling of data inconsistancies that |
164
|
|
|
|
|
|
|
# sometimes exist between freeze/thaw property names; or between versions. |
165
|
|
|
|
|
|
|
# These are always trapped at the data level (_freeze & _thaw). |
166
|
|
|
|
|
|
|
# |
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub _alias { |
169
|
59
|
|
|
59
|
|
129
|
my ($entity_class, $from, $to, %opt) = @_; |
170
|
|
|
|
|
|
|
|
171
|
59
|
|
|
|
|
93
|
$from = lcfirst($from); |
172
|
59
|
|
|
|
|
65
|
$to = lcfirst($to); |
173
|
|
|
|
|
|
|
|
174
|
59
|
50
|
33
|
|
|
598
|
die 'usage: $entity_class->_alias(alias, prop, %opts)' |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
175
|
|
|
|
|
|
|
unless ($entity_class |
176
|
|
|
|
|
|
|
&& $from && !ref($from) |
177
|
|
|
|
|
|
|
&& $to && !ref($to)); |
178
|
|
|
|
|
|
|
|
179
|
59
|
|
|
|
|
220
|
my $aliases = $entity_class->_get_aliases; |
180
|
|
|
|
|
|
|
|
181
|
|
|
|
|
|
|
# |
182
|
|
|
|
|
|
|
# Set our entity name. Register it in our parent |
183
|
|
|
|
|
|
|
# |
184
|
59
|
50
|
|
|
|
139
|
die "$entity_class: attempted redefinition of alias: $from" |
185
|
|
|
|
|
|
|
if $aliases->{$from}; |
186
|
|
|
|
|
|
|
|
187
|
59
|
50
|
|
|
|
142
|
die "$entity_class: can't alias $from it's already a property!" |
188
|
|
|
|
|
|
|
if $entity_class->meta->get_attribute($from); |
189
|
|
|
|
|
|
|
|
190
|
59
|
50
|
|
|
|
686
|
die "$entity_class: attempt to alias $from to non-existant property $to - check spelling and declaration order" |
191
|
|
|
|
|
|
|
unless $entity_class->meta->get_attribute($to); |
192
|
|
|
|
|
|
|
|
193
|
59
|
|
|
|
|
500
|
$opt{to} = $to; |
194
|
59
|
|
|
|
|
98
|
$aliases->{$from} = \%opt; |
195
|
|
|
|
|
|
|
|
196
|
59
|
|
|
|
|
140
|
return \%opt; |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
sub _get_aliases { |
200
|
60
|
|
|
60
|
|
77
|
my $entity_class = shift; |
201
|
|
|
|
|
|
|
|
202
|
60
|
|
|
|
|
222
|
my $aliases = $entity_class->_aliases; |
203
|
|
|
|
|
|
|
|
204
|
60
|
100
|
|
|
|
384
|
unless ($aliases) { |
205
|
21
|
|
|
|
|
33
|
$aliases = {}; |
206
|
21
|
|
|
|
|
59
|
$entity_class->_aliases( $aliases ); |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
60
|
|
|
|
|
563
|
return $aliases |
210
|
|
|
|
|
|
|
} |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=head2 id |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
my @primary_vals = $entity_obj->id |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
Return primary key values. |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
=cut |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
sub id { |
221
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
222
|
0
|
|
|
|
|
0
|
return map {$self->$_} ($self->primary_key ); |
|
0
|
|
|
|
|
0
|
|
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
=head2 primary_key |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
Setter/getter for primary key field(s) for this entity class |
228
|
|
|
|
|
|
|
|
229
|
|
|
|
|
|
|
my @pkey = MyApp::Entity::User->primary_key |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
=cut |
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
sub primary_key { |
234
|
468
|
|
|
468
|
1
|
583
|
my ($entity_class, @pkey) = @_; |
235
|
|
|
|
|
|
|
|
236
|
468
|
100
|
|
|
|
919
|
$entity_class->_primary_key(\@pkey) |
237
|
|
|
|
|
|
|
if (@pkey); |
238
|
|
|
|
|
|
|
|
239
|
468
|
|
|
|
|
971
|
return @{$entity_class->_primary_key}; |
|
468
|
|
|
|
|
1089
|
|
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
=head2 params |
243
|
|
|
|
|
|
|
|
244
|
|
|
|
|
|
|
Setter/getter for parameter field(s) for this entity class |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
Elive::Entity::User->params(loginName => 'Str'); |
247
|
|
|
|
|
|
|
my %params = MyApp::Entity::User->params; |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
=cut |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
sub params { |
252
|
9
|
|
|
9
|
1
|
27
|
my ($entity_class, %params) = @_; |
253
|
|
|
|
|
|
|
|
254
|
9
|
50
|
|
|
|
63
|
$entity_class->_params(\%params) |
255
|
|
|
|
|
|
|
if (keys %params); |
256
|
|
|
|
|
|
|
|
257
|
9
|
|
|
|
|
155
|
return %{$entity_class->_params}; |
|
9
|
|
|
|
|
30
|
|
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
=head2 derivable |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
Setter/getter for derivable field(s) for this entity class |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
=cut |
265
|
|
|
|
|
|
|
|
266
|
|
|
|
|
|
|
sub derivable { |
267
|
1
|
|
|
1
|
1
|
3
|
my ($entity_class, %derivable) = @_; |
268
|
|
|
|
|
|
|
|
269
|
1
|
50
|
|
|
|
9
|
$entity_class->_derivable(\%derivable) |
270
|
|
|
|
|
|
|
if (keys %derivable); |
271
|
|
|
|
|
|
|
|
272
|
1
|
|
|
|
|
17
|
return %{$entity_class->_derivable}; |
|
1
|
|
|
|
|
3
|
|
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
=head2 entities |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
my $entities = Entity::Entity->entities |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
print "user has entity class: $entities->{user}\n"; |
280
|
|
|
|
|
|
|
print "meetingParticipant entity class has not been loaded\n" |
281
|
|
|
|
|
|
|
unless ($entities->{meetingParticipant}); |
282
|
|
|
|
|
|
|
|
283
|
|
|
|
|
|
|
Return has hash ref of all loaded entity names and classes |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=cut |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
sub entities { |
288
|
0
|
|
|
0
|
1
|
0
|
my $entity_class = shift; |
289
|
|
|
|
|
|
|
|
290
|
0
|
|
|
|
|
0
|
return $entity_class->_entities; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
sub _ordered_attribute_names { |
294
|
223
|
|
|
223
|
|
240
|
my $class = shift; |
295
|
|
|
|
|
|
|
|
296
|
223
|
|
|
|
|
195
|
my %order; |
297
|
|
|
|
|
|
|
my $rank; |
298
|
|
|
|
|
|
|
# |
299
|
|
|
|
|
|
|
# Put primary key fields at the top |
300
|
|
|
|
|
|
|
# |
301
|
223
|
|
|
|
|
335
|
foreach ($class->primary_key) { |
302
|
223
|
|
|
|
|
1734
|
$order{$_} = ++$rank; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# |
306
|
|
|
|
|
|
|
# Sort remaining fields alphabetically |
307
|
|
|
|
|
|
|
# |
308
|
223
|
|
|
|
|
523
|
my @atts = $class->meta->get_attribute_list; |
309
|
|
|
|
|
|
|
|
310
|
223
|
|
|
|
|
2986
|
foreach (sort @atts) { |
311
|
1221
|
|
66
|
|
|
3189
|
$order{$_} ||= ++$rank; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
223
|
|
|
|
|
739
|
my @atts_sorted = sort {$order{$a} <=> $order{$b}} (keys %order); |
|
2528
|
|
|
|
|
2523
|
|
315
|
223
|
|
|
|
|
750
|
return @atts_sorted; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
sub _ordered_attributes { |
319
|
223
|
|
|
223
|
|
197
|
my $class = shift; |
320
|
|
|
|
|
|
|
|
321
|
223
|
|
|
|
|
500
|
my $meta = $class->meta; |
322
|
|
|
|
|
|
|
|
323
|
223
|
50
|
|
|
|
2098
|
return map {$meta->get_attribute($_) or die "$class: unknown attribute $_"} ($class->_ordered_attribute_names); |
|
1221
|
|
|
|
|
4109
|
|
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
sub _cmp_col { |
327
|
57
|
|
|
57
|
|
168
|
my ($class, $data_type, $v1, $v2, %opt) = @_; |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# |
330
|
|
|
|
|
|
|
# Compare two values for a property |
331
|
|
|
|
|
|
|
# |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
return |
334
|
57
|
100
|
100
|
|
|
290
|
unless (defined $v1 && defined $v2); |
335
|
|
|
|
|
|
|
|
336
|
54
|
|
|
|
|
164
|
my $type_info = Elive::Util::inspect_type($data_type); |
337
|
54
|
|
|
|
|
167
|
my $array_type = $type_info->array_type; |
338
|
54
|
|
|
|
|
113
|
my $type = $type_info->elemental_type; |
339
|
54
|
|
|
|
|
48
|
my $cmp; |
340
|
|
|
|
|
|
|
|
341
|
54
|
100
|
100
|
|
|
164
|
if ($array_type || $type_info->is_struct) { |
|
|
50
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# |
343
|
|
|
|
|
|
|
# Note shallow comparision of entities and arrays. |
344
|
|
|
|
|
|
|
# |
345
|
36
|
|
66
|
|
|
94
|
my $t = $array_type || $type; |
346
|
36
|
|
|
|
|
131
|
$cmp = $t->stringify($v1) cmp $t->stringify($v2); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
elsif ($type =~ m{^Ref|Any}ix) { |
349
|
0
|
|
|
|
|
0
|
$cmp = YAML::Syck::Dump($v1) cmp YAML::Syck::Dump($v2); |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
else { |
352
|
|
|
|
|
|
|
# |
353
|
|
|
|
|
|
|
# Elemental comparision. Use normalised frozen values |
354
|
|
|
|
|
|
|
# |
355
|
18
|
|
|
|
|
33
|
$v1 = Elive::Util::_freeze($v1, $type); |
356
|
18
|
|
|
|
|
32
|
$v2 = Elive::Util::_freeze($v2, $type); |
357
|
|
|
|
|
|
|
|
358
|
18
|
100
|
|
|
|
56
|
if ($type =~ m{^(Str|Enum|HiResDate)}ix) { |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# |
360
|
|
|
|
|
|
|
# string comparision. works on simple strings and |
361
|
|
|
|
|
|
|
# stringified entities. Also used for hires dates |
362
|
|
|
|
|
|
|
# integer comparision may result in arithmetic overflow |
363
|
|
|
|
|
|
|
# |
364
|
14
|
100
|
|
|
|
33
|
$cmp = ($opt{case_insensitive} |
365
|
|
|
|
|
|
|
? uc($v1) cmp uc($v2) |
366
|
|
|
|
|
|
|
: $v1 cmp $v2); |
367
|
|
|
|
|
|
|
} |
368
|
|
|
|
|
|
|
elsif ($type =~ m{^Bool}ix) { |
369
|
|
|
|
|
|
|
# boolean comparison |
370
|
0
|
0
|
|
|
|
0
|
$cmp = ($v1 eq 'true'? 1: 0) <=> ($v2 eq 'true'? 1: 0); |
|
|
0
|
|
|
|
|
|
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
elsif ($type =~ m{^Int}ix) { |
373
|
|
|
|
|
|
|
# int comparision |
374
|
4
|
|
66
|
|
|
26
|
$cmp = defined $v1 && defined $v2 && $v1 <=> $v2; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
else { |
377
|
0
|
|
|
|
|
0
|
Carp::croak "class $class: unknown type: $type\n"; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
54
|
50
|
50
|
|
|
205
|
warn YAML::Syck::Dump {cmp => {result =>$cmp, |
382
|
|
|
|
|
|
|
class => $class, |
383
|
|
|
|
|
|
|
data_type => "$data_type", |
384
|
|
|
|
|
|
|
v1 => $v1, |
385
|
|
|
|
|
|
|
v2 => $v2 |
386
|
|
|
|
|
|
|
}} |
387
|
|
|
|
|
|
|
if ($class->debug||0) >= 5; |
388
|
|
|
|
|
|
|
|
389
|
54
|
|
|
|
|
519
|
return $cmp; |
390
|
|
|
|
|
|
|
} |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
=head2 properties |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
my @properties = MyApp::Entity::User->properties; |
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
Return the property accessor names for an entity |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
=cut |
399
|
|
|
|
|
|
|
|
400
|
|
|
|
|
|
|
sub properties { |
401
|
0
|
|
|
0
|
1
|
0
|
my $class = shift; |
402
|
0
|
|
|
|
|
0
|
return map {$_->name} ($class->_ordered_attributes); |
|
0
|
|
|
|
|
0
|
|
403
|
|
|
|
|
|
|
} |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
=head2 property_types |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
my $user_types = MyApp::Entity::User->property_types; |
408
|
|
|
|
|
|
|
my $type_info = Elive::Util::inspect_type($user_types->{role}) |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
Return a hashref of attribute data types. |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
=cut |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
sub property_types { |
415
|
223
|
|
|
223
|
1
|
2723
|
my $class = shift; |
416
|
|
|
|
|
|
|
|
417
|
223
|
|
|
|
|
390
|
my @atts = $class->_ordered_attributes; |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
return { |
420
|
223
|
|
|
|
|
1205
|
map {$_->name => $_->type_constraint} @atts |
|
1221
|
|
|
|
|
3406
|
|
421
|
|
|
|
|
|
|
}; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
=head2 property_doco |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
my $user_doc = MyApp::Entity::User->property_doc |
427
|
|
|
|
|
|
|
my $user_password_doco = $user_doc->{loginPassword} |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
Return a hashref of documentation for properties |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
=cut |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
sub property_doco { |
434
|
0
|
|
|
0
|
1
|
0
|
my $class = shift; |
435
|
|
|
|
|
|
|
|
436
|
0
|
|
|
|
|
0
|
my @atts = $class->_ordered_attributes; |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
return { |
439
|
0
|
|
|
|
|
0
|
map {$_->name => $_->{documentation}} @atts |
|
0
|
|
|
|
|
0
|
|
440
|
|
|
|
|
|
|
}; |
441
|
|
|
|
|
|
|
} |
442
|
|
|
|
|
|
|
|
443
|
|
|
|
|
|
|
=head2 stringify |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
Return a human readable string representation of an object. For database |
446
|
|
|
|
|
|
|
entities, this is the primary key: |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
if ($user_obj->stringify eq "11223344") { |
449
|
|
|
|
|
|
|
.... |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
Arrays of sub-items evaluated, in a string context, to a semi-colon separated |
453
|
|
|
|
|
|
|
string of the individual values sorted. |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
my $group = Elive::Entity::Group->retrieve(98765); |
456
|
|
|
|
|
|
|
if ($group->members->stringify eq "11223344;2222222") { |
457
|
|
|
|
|
|
|
.... |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
In particular meeting participants stringify to userId=role, e.g. |
461
|
|
|
|
|
|
|
|
462
|
|
|
|
|
|
|
my $participant_list = Elive::Entity::ParticipantList->retrieve(98765); |
463
|
|
|
|
|
|
|
if ($participant_list->participants->stringify eq "11223344=3;2222222=2") { |
464
|
|
|
|
|
|
|
.... |
465
|
|
|
|
|
|
|
} |
466
|
|
|
|
|
|
|
|
467
|
|
|
|
|
|
|
=cut |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
=head2 connection |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
my $default_connection = Elive::Entity::User->connection; |
472
|
|
|
|
|
|
|
my $connection = $entity_obj->connection; |
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
Return a connection. Either the actual connection associated with a entity |
475
|
|
|
|
|
|
|
instance, or the default connection that will be used. |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
=cut |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=head2 disconnect |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
Disconnects and disassociates an Elluminate connection from this class. It is |
482
|
|
|
|
|
|
|
recommended that you do this prior to exiting your program. |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
=cut |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
sub disconnect { |
487
|
1
|
|
|
1
|
1
|
3
|
my ($class, %opt) = @_; |
488
|
|
|
|
|
|
|
|
489
|
1
|
50
|
|
|
|
13
|
if (my $connection = $class->connection) { |
490
|
0
|
|
|
|
|
0
|
$connection->disconnect; |
491
|
0
|
|
|
|
|
0
|
$class->connection(undef); |
492
|
|
|
|
|
|
|
} |
493
|
|
|
|
|
|
|
|
494
|
1
|
|
|
|
|
24
|
return; |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
sub _restful_url { |
498
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
499
|
0
|
|
0
|
|
|
0
|
my $connection = shift || $class->connection; |
500
|
0
|
|
|
|
|
0
|
my $path = shift; |
501
|
|
|
|
|
|
|
|
502
|
0
|
|
|
|
|
0
|
my $uri_obj = URI->new( $connection->url ); |
503
|
0
|
|
|
|
|
0
|
$uri_obj->scheme('http'); |
504
|
|
|
|
|
|
|
|
505
|
0
|
|
|
|
|
0
|
return join('/', $uri_obj->as_string, |
506
|
|
|
|
|
|
|
$class->entity_name, |
507
|
|
|
|
|
|
|
$path); |
508
|
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
=head2 url |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
my $url = $user->url |
513
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
Abstract method to compute a restful url for an object instance. This will |
515
|
|
|
|
|
|
|
include both the url of the connection string and the entity class name. It |
516
|
|
|
|
|
|
|
is used internally to uniquely identify and cache objects across repositories. |
517
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
=cut |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
sub url { |
521
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
522
|
0
|
|
0
|
|
|
0
|
my $connection = shift || $self->connection; |
523
|
0
|
0
|
|
|
|
0
|
my $path = $self->stringify |
524
|
|
|
|
|
|
|
or return; |
525
|
0
|
|
|
|
|
0
|
return $self->_restful_url($connection, $path); |
526
|
|
|
|
|
|
|
} |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
=head2 construct |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
my $user = Entity::User->construct( |
531
|
|
|
|
|
|
|
{userId = 123456, |
532
|
|
|
|
|
|
|
loginName => 'demo_user', |
533
|
|
|
|
|
|
|
role => { |
534
|
|
|
|
|
|
|
roleId => 1 |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
}, |
537
|
|
|
|
|
|
|
overwrite => 1, # overwrite any unsaved changes in cache |
538
|
|
|
|
|
|
|
connection => $conn, # connection to use |
539
|
|
|
|
|
|
|
copy => 1, # return a simple blessed uncached object. |
540
|
|
|
|
|
|
|
); |
541
|
|
|
|
|
|
|
|
542
|
|
|
|
|
|
|
Abstract method to construct a data mapped entity. A copy is made of the |
543
|
|
|
|
|
|
|
data for use by the C and C methods. |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
=cut |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
sub construct { |
548
|
0
|
|
|
0
|
1
|
0
|
my ($class, $data, %opt) = @_; |
549
|
|
|
|
|
|
|
|
550
|
0
|
0
|
|
|
|
0
|
$data = $class->BUILDARGS($data) if $class->can('BUILDARGS'); |
551
|
|
|
|
|
|
|
|
552
|
0
|
0
|
|
|
|
0
|
croak "usage: ${class}->construct( \\%data )" |
553
|
|
|
|
|
|
|
unless (Elive::Util::_reftype($data) eq 'HASH'); |
554
|
|
|
|
|
|
|
|
555
|
0
|
|
|
|
|
0
|
do { |
556
|
0
|
|
|
|
|
0
|
my %unknown_properties; |
557
|
0
|
|
|
|
|
0
|
@unknown_properties{keys %$data} = undef; |
558
|
0
|
|
|
|
|
0
|
delete $unknown_properties{$_} for ($class->properties); |
559
|
0
|
|
|
|
|
0
|
my @unknown = sort keys %unknown_properties; |
560
|
0
|
0
|
|
|
|
0
|
carp "$class - unknown properties: @unknown" if @unknown; |
561
|
|
|
|
|
|
|
}; |
562
|
|
|
|
|
|
|
|
563
|
0
|
0
|
|
|
|
0
|
warn YAML::Syck::Dump({class => $class, construct => $data}) |
564
|
|
|
|
|
|
|
if (Elive->debug > 1); |
565
|
|
|
|
|
|
|
|
566
|
0
|
|
|
|
|
0
|
my $self; |
567
|
|
|
|
|
|
|
|
568
|
0
|
0
|
|
|
|
0
|
$self = Scalar::Util::blessed($data) |
569
|
|
|
|
|
|
|
? $data |
570
|
|
|
|
|
|
|
: $class->new($data); |
571
|
|
|
|
|
|
|
|
572
|
0
|
0
|
0
|
|
|
0
|
my $connection = delete $opt{connection} || $class->connection |
573
|
|
|
|
|
|
|
or die "not connected"; |
574
|
|
|
|
|
|
|
|
575
|
0
|
|
|
|
|
0
|
my %primary_key_data = map {$_ => $data->{ $_ }} ($class->primary_key); |
|
0
|
|
|
|
|
0
|
|
576
|
|
|
|
|
|
|
|
577
|
0
|
|
|
|
|
0
|
foreach (keys %primary_key_data) { |
578
|
0
|
0
|
|
|
|
0
|
unless (defined $primary_key_data{ $_ }) { |
579
|
0
|
|
|
|
|
0
|
die "can't construct $class without value for primary key field: $_"; |
580
|
|
|
|
|
|
|
} |
581
|
|
|
|
|
|
|
} |
582
|
|
|
|
|
|
|
|
583
|
0
|
0
|
|
|
|
0
|
$self->_is_copy(1) |
584
|
|
|
|
|
|
|
if $opt{copy}; |
585
|
|
|
|
|
|
|
|
586
|
0
|
|
|
|
|
0
|
my $data_copy = Elive::Util::_clone($self); |
587
|
0
|
|
|
|
|
0
|
return $self->__set_db_data($data_copy, |
588
|
|
|
|
|
|
|
connection => $connection, |
589
|
|
|
|
|
|
|
overwrite => $opt{overwrite}, |
590
|
|
|
|
|
|
|
); |
591
|
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
|
|
593
|
|
|
|
|
|
|
sub __set_db_data { |
594
|
0
|
|
|
0
|
|
0
|
my $struct = shift; |
595
|
0
|
|
|
|
|
0
|
my $data_copy = shift; |
596
|
0
|
|
|
|
|
0
|
my %opt = @_; |
597
|
|
|
|
|
|
|
|
598
|
0
|
|
|
|
|
0
|
my $connection = $opt{connection}; |
599
|
|
|
|
|
|
|
|
600
|
0
|
|
|
|
|
0
|
my $type = Elive::Util::_reftype( $struct ); |
601
|
|
|
|
|
|
|
|
602
|
0
|
0
|
|
|
|
0
|
if ($type) { |
603
|
|
|
|
|
|
|
|
604
|
0
|
0
|
0
|
|
|
0
|
if (Scalar::Util::blessed $struct |
605
|
|
|
|
|
|
|
&& $struct->can('_is_copy')) { |
606
|
|
|
|
|
|
|
|
607
|
0
|
|
0
|
|
|
0
|
$opt{copy} ||= $struct->_is_copy; |
608
|
|
|
|
|
|
|
|
609
|
0
|
0
|
|
|
|
0
|
$struct->_is_copy(1) |
610
|
|
|
|
|
|
|
if $opt{copy}; |
611
|
|
|
|
|
|
|
} |
612
|
|
|
|
|
|
|
|
613
|
|
|
|
|
|
|
# recurse |
614
|
0
|
0
|
|
|
|
0
|
if ($type eq 'ARRAY') { |
|
|
0
|
|
|
|
|
|
615
|
0
|
|
|
|
|
0
|
foreach (0 .. scalar(@$struct)) { |
616
|
0
|
0
|
|
|
|
0
|
$struct->[$_] = __set_db_data($struct->[$_], $data_copy->[$_], %opt) |
617
|
|
|
|
|
|
|
if ref $struct->[$_]; |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
} |
620
|
|
|
|
|
|
|
elsif ($type eq 'HASH') { |
621
|
0
|
|
|
|
|
0
|
foreach (sort keys %$struct) { |
622
|
0
|
0
|
|
|
|
0
|
$struct->{$_} = __set_db_data($struct->{$_}, $data_copy->{$_}, %opt) |
623
|
|
|
|
|
|
|
if ref $struct->{$_}; |
624
|
|
|
|
|
|
|
} |
625
|
|
|
|
|
|
|
} |
626
|
|
|
|
|
|
|
else { |
627
|
0
|
|
|
|
|
0
|
warn "don't know how to set db data for sub-type $type"; |
628
|
|
|
|
|
|
|
} |
629
|
|
|
|
|
|
|
|
630
|
0
|
0
|
|
|
|
0
|
if (Scalar::Util::blessed $struct) { |
631
|
0
|
0
|
0
|
|
|
0
|
if ($connection && $struct->can('connection')) { |
632
|
|
|
|
|
|
|
|
633
|
0
|
0
|
0
|
|
|
0
|
if (!$opt{copy} |
|
|
|
0
|
|
|
|
|
634
|
|
|
|
|
|
|
&& $struct->can('url') |
635
|
|
|
|
|
|
|
&& (my $obj_url = $struct->url($connection)) |
636
|
|
|
|
|
|
|
) { |
637
|
|
|
|
|
|
|
|
638
|
0
|
|
|
|
|
0
|
my $cache_access; |
639
|
|
|
|
|
|
|
|
640
|
0
|
0
|
|
|
|
0
|
if (my $cached = $Stored_Objects{ $obj_url }) { |
641
|
0
|
|
|
|
|
0
|
$cache_access = 'reuse'; |
642
|
|
|
|
|
|
|
# |
643
|
|
|
|
|
|
|
# Overwrite the cached object, then reuse it. |
644
|
|
|
|
|
|
|
# |
645
|
0
|
0
|
0
|
|
|
0
|
die "attempted overwrite of object with unsaved changes ($obj_url)" |
646
|
|
|
|
|
|
|
if !$opt{overwrite} && $cached->is_changed; |
647
|
|
|
|
|
|
|
|
648
|
0
|
0
|
|
|
|
0
|
die "cache type conflict. $obj_url contains an ".ref($cached)." object, but requested ".ref($struct) |
649
|
|
|
|
|
|
|
unless $cached->isa(ref($struct)); |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
|
652
|
0
|
|
|
|
|
0
|
%{$cached} = %{$struct}; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
653
|
0
|
|
|
|
|
0
|
$struct = $cached; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
else { |
656
|
0
|
|
|
|
|
0
|
$cache_access = 'init'; |
657
|
|
|
|
|
|
|
} |
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
# rewrite, for benefit of 5.13.3 |
660
|
0
|
|
|
|
|
0
|
weaken ($Stored_Objects{$obj_url} = $struct); |
661
|
|
|
|
|
|
|
|
662
|
0
|
0
|
|
|
|
0
|
if ($struct->debug >= 5) { |
663
|
0
|
|
|
|
|
0
|
warn YAML::Syck::Dump({opt => \%opt, struct => $struct, class => ref($struct), url => $obj_url, cache => $cache_access, ref1 => "$struct", ref2 => "$Stored_Objects{$obj_url}"}); |
664
|
|
|
|
|
|
|
} |
665
|
|
|
|
|
|
|
} |
666
|
|
|
|
|
|
|
|
667
|
0
|
|
|
|
|
0
|
$struct->connection( $connection ); |
668
|
|
|
|
|
|
|
} |
669
|
|
|
|
|
|
|
|
670
|
0
|
0
|
|
|
|
0
|
if ($struct->can('_db_data')) { |
671
|
|
|
|
|
|
|
# |
672
|
|
|
|
|
|
|
# save before image from database |
673
|
|
|
|
|
|
|
# |
674
|
0
|
0
|
0
|
|
|
0
|
$data_copy->_db_data(undef) |
675
|
|
|
|
|
|
|
if Scalar::Util::blessed($data_copy) |
676
|
|
|
|
|
|
|
&& $data_copy->can('_db_data'); |
677
|
|
|
|
|
|
|
|
678
|
0
|
|
|
|
|
0
|
$struct->_db_data($data_copy); |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
} |
682
|
|
|
|
|
|
|
|
683
|
0
|
|
|
|
|
0
|
return $struct; |
684
|
|
|
|
|
|
|
} |
685
|
|
|
|
|
|
|
|
686
|
|
|
|
|
|
|
# |
687
|
|
|
|
|
|
|
# _freeze - construct name/value pairs for database inserts or updates |
688
|
|
|
|
|
|
|
# |
689
|
|
|
|
|
|
|
|
690
|
|
|
|
|
|
|
sub _freeze { |
691
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
692
|
0
|
|
|
|
|
0
|
my $db_data = shift; |
693
|
0
|
|
|
|
|
0
|
my %opt = @_; |
694
|
|
|
|
|
|
|
|
695
|
0
|
0
|
0
|
|
|
0
|
$db_data ||= $class if ref($class); |
696
|
0
|
|
0
|
|
|
0
|
$db_data ||= {}; |
697
|
0
|
|
|
|
|
0
|
$db_data = Elive::Util::_clone( $db_data ); |
698
|
|
|
|
|
|
|
|
699
|
0
|
|
0
|
|
|
0
|
my $property_types = $class->property_types || {}; |
700
|
0
|
|
|
|
|
0
|
my %param_types = $class->params; |
701
|
|
|
|
|
|
|
|
702
|
0
|
|
|
|
|
0
|
$class->_canonicalize_properties( $db_data ); |
703
|
|
|
|
|
|
|
|
704
|
0
|
|
|
|
|
0
|
foreach (keys %$db_data) { |
705
|
|
|
|
|
|
|
|
706
|
0
|
|
0
|
|
|
0
|
my $property = $property_types->{$_} || $param_types{$_}; |
707
|
|
|
|
|
|
|
|
708
|
0
|
0
|
|
|
|
0
|
unless ($property) { |
709
|
0
|
|
|
|
|
0
|
my @properties = $class->properties; |
710
|
0
|
|
|
|
|
0
|
my @param_names = sort keys %param_types; |
711
|
0
|
|
|
|
|
0
|
Carp::croak "$class: unknown property/parameter: $_: expected: ",join(',', @properties, @param_names); |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
|
714
|
0
|
|
|
|
|
0
|
my $type_info = Elive::Util::inspect_type($property); |
715
|
0
|
|
|
|
|
0
|
my $type = $type_info->elemental_type; |
716
|
0
|
|
|
|
|
0
|
my $is_array = $type_info->is_array; |
717
|
|
|
|
|
|
|
|
718
|
0
|
|
|
|
|
0
|
for ($db_data->{$_}) { |
719
|
|
|
|
|
|
|
|
720
|
0
|
0
|
|
|
|
0
|
$_ = Elive::Util::_freeze($_, $is_array? $property: $type); |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
# |
726
|
|
|
|
|
|
|
# apply any freeze alias mappings |
727
|
|
|
|
|
|
|
# |
728
|
0
|
0
|
|
|
|
0
|
$class->__apply_freeze_aliases( $db_data ) |
729
|
|
|
|
|
|
|
unless $opt{canonical}; |
730
|
|
|
|
|
|
|
|
731
|
0
|
|
|
|
|
0
|
return $db_data; |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub _canonicalize_properties { |
735
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
736
|
0
|
|
|
|
|
0
|
my $data = shift; |
737
|
|
|
|
|
|
|
|
738
|
0
|
|
|
|
|
0
|
my %aliases = $class->_to_aliases; |
739
|
|
|
|
|
|
|
|
740
|
0
|
|
|
|
|
0
|
for (grep {exists $data->{$_}} (keys %aliases)) { |
|
0
|
|
|
|
|
0
|
|
741
|
0
|
|
|
|
|
0
|
my $att = $aliases{$_}; |
742
|
0
|
|
|
|
|
0
|
$data->{$att} = delete $data->{$_}; |
743
|
|
|
|
|
|
|
} |
744
|
|
|
|
|
|
|
|
745
|
0
|
|
|
|
|
0
|
return $data; |
746
|
|
|
|
|
|
|
} |
747
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
sub __apply_freeze_aliases { |
749
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
750
|
0
|
|
|
|
|
0
|
my $db_data = shift; |
751
|
|
|
|
|
|
|
|
752
|
0
|
|
|
|
|
0
|
my $aliases = $class->_get_aliases; |
753
|
|
|
|
|
|
|
|
754
|
0
|
|
|
|
|
0
|
foreach my $alias (keys %$aliases) { |
755
|
0
|
0
|
|
|
|
0
|
if ($aliases->{$alias}{freeze}) { |
756
|
0
|
0
|
|
|
|
0
|
my $to = $aliases->{$alias}{to} |
757
|
|
|
|
|
|
|
or die "malformed alias: $alias"; |
758
|
|
|
|
|
|
|
# |
759
|
|
|
|
|
|
|
# Freeze with this alias |
760
|
|
|
|
|
|
|
# |
761
|
0
|
0
|
|
|
|
0
|
$db_data->{ $alias } = delete $db_data->{ $to } |
762
|
|
|
|
|
|
|
if exists $db_data->{ $to }; |
763
|
|
|
|
|
|
|
} |
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
|
766
|
0
|
|
|
|
|
0
|
return $db_data; |
767
|
|
|
|
|
|
|
} |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
# _find_entities() |
770
|
|
|
|
|
|
|
# |
771
|
|
|
|
|
|
|
# my %entities = Elive::DAO::find_entities( $db_data ); |
772
|
|
|
|
|
|
|
# |
773
|
|
|
|
|
|
|
# A utility function to locate entities in SOAP response data. This should be |
774
|
|
|
|
|
|
|
# applied after unpacking and before thawing. |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
sub _find_entities { |
777
|
0
|
|
|
0
|
|
0
|
my $db_data = shift; |
778
|
|
|
|
|
|
|
|
779
|
0
|
0
|
|
|
|
0
|
return map {m{^(.*)(Adapter|Response)$}? ($1 => $_): ()} (keys %$db_data); |
|
0
|
|
|
|
|
0
|
|
780
|
|
|
|
|
|
|
} |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
sub __dereference_adapter { |
783
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
784
|
0
|
|
|
|
|
0
|
my $db_data = shift; |
785
|
0
|
|
|
|
|
0
|
my $path = shift; |
786
|
|
|
|
|
|
|
|
787
|
0
|
|
|
|
|
0
|
my $adapter_found; |
788
|
|
|
|
|
|
|
my $entity_data; |
789
|
|
|
|
|
|
|
|
790
|
0
|
0
|
|
|
|
0
|
if (Elive::Util::_reftype($db_data) eq 'HASH') { |
791
|
|
|
|
|
|
|
|
792
|
0
|
|
|
|
|
0
|
my %entities = _find_entities( $db_data ); |
793
|
|
|
|
|
|
|
|
794
|
0
|
|
|
|
|
0
|
my $adapter = delete $entities{ $class->entity_name }; |
795
|
|
|
|
|
|
|
|
796
|
0
|
0
|
|
|
|
0
|
if ($adapter) { |
797
|
0
|
|
|
|
|
0
|
$entity_data = $db_data->{$adapter}; |
798
|
0
|
|
|
|
|
0
|
$$path .= $adapter; |
799
|
|
|
|
|
|
|
} |
800
|
|
|
|
|
|
|
|
801
|
0
|
|
|
|
|
0
|
my @unknown_entities = sort keys %entities; |
802
|
0
|
0
|
|
|
|
0
|
die "unexpected entities in response:: @unknown_entities" |
803
|
|
|
|
|
|
|
if @unknown_entities; |
804
|
|
|
|
|
|
|
} |
805
|
|
|
|
|
|
|
|
806
|
0
|
|
0
|
|
|
0
|
return $entity_data || $db_data; |
807
|
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
# |
810
|
|
|
|
|
|
|
# _thaw - perform database to perl type conversions |
811
|
|
|
|
|
|
|
# |
812
|
|
|
|
|
|
|
|
813
|
|
|
|
|
|
|
sub _thaw { |
814
|
0
|
|
|
0
|
|
0
|
my $class = shift; |
815
|
0
|
|
|
|
|
0
|
my $db_data = shift; |
816
|
0
|
|
0
|
|
|
0
|
my $path = shift || ''; |
817
|
|
|
|
|
|
|
|
818
|
0
|
|
|
|
|
0
|
$path .= '/'; |
819
|
|
|
|
|
|
|
|
820
|
0
|
|
|
|
|
0
|
my $entity_data = __dereference_adapter( $class, $db_data, \$path); |
821
|
0
|
0
|
|
|
|
0
|
return unless defined $entity_data; |
822
|
|
|
|
|
|
|
|
823
|
0
|
|
|
|
|
0
|
my $ref_type = Elive::Util::_reftype($entity_data); |
824
|
0
|
0
|
|
|
|
0
|
die "thawing $class. expected $path to contain HASH data. found: $ref_type" |
825
|
|
|
|
|
|
|
unless $ref_type eq 'HASH'; |
826
|
|
|
|
|
|
|
|
827
|
0
|
|
|
|
|
0
|
my %data; |
828
|
0
|
|
|
|
|
0
|
my @properties = $class->properties; |
829
|
0
|
|
|
|
|
0
|
my $aliases = $class->_get_aliases; |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
# |
832
|
|
|
|
|
|
|
# Normalise: |
833
|
|
|
|
|
|
|
# 1. Entity names returned capitalised: 'LoginName' => 'loginName |
834
|
|
|
|
|
|
|
# 2. Primary key may be returned as Id, rather than Id |
835
|
|
|
|
|
|
|
# 3. Apply aliases. |
836
|
|
|
|
|
|
|
# |
837
|
0
|
|
|
|
|
0
|
my %prop_key_map = map {ucfirst($_) => $_} @properties; |
|
0
|
|
|
|
|
0
|
|
838
|
|
|
|
|
|
|
|
839
|
0
|
|
|
|
|
0
|
my @primary_key = $class->primary_key; |
840
|
|
|
|
|
|
|
|
841
|
0
|
0
|
|
|
|
0
|
$prop_key_map{Id} = lcfirst($primary_key[0]) |
842
|
|
|
|
|
|
|
if @primary_key; |
843
|
|
|
|
|
|
|
|
844
|
0
|
|
|
|
|
0
|
foreach my $alias (keys %$aliases) { |
845
|
0
|
0
|
|
|
|
0
|
my $to = $aliases->{$alias}{to} |
846
|
|
|
|
|
|
|
or die "malformed alias: $alias"; |
847
|
|
|
|
|
|
|
|
848
|
0
|
|
|
|
|
0
|
$prop_key_map{ ucfirst($alias) } = $to; |
849
|
|
|
|
|
|
|
} |
850
|
|
|
|
|
|
|
|
851
|
0
|
|
|
|
|
0
|
my $property_types = $class->property_types; |
852
|
|
|
|
|
|
|
|
853
|
0
|
|
|
|
|
0
|
foreach my $key (keys %$entity_data) { |
854
|
|
|
|
|
|
|
|
855
|
0
|
|
|
|
|
0
|
my $val = $entity_data->{ $key }; |
856
|
0
|
|
0
|
|
|
0
|
my $prop_key = $prop_key_map{$key} || $key; |
857
|
0
|
|
|
|
|
0
|
$data{$prop_key} = $val; |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
0
|
|
|
|
|
0
|
foreach my $col (grep {defined $data{$_}} @properties) { |
|
0
|
|
|
|
|
0
|
|
861
|
|
|
|
|
|
|
|
862
|
0
|
|
|
|
|
0
|
my $property_type = $property_types->{$col}; |
863
|
0
|
|
|
|
|
0
|
my $type_info = Elive::Util::inspect_type($property_type); |
864
|
0
|
|
|
|
|
0
|
my $type = $type_info->elemental_type; |
865
|
0
|
|
|
|
|
0
|
my $is_array = $type_info->is_array; |
866
|
0
|
|
|
|
|
0
|
my $is_struct = $type_info->is_struct; |
867
|
|
|
|
|
|
|
|
868
|
0
|
0
|
0
|
|
|
0
|
next unless $col && defined $data{$col}; |
869
|
|
|
|
|
|
|
|
870
|
0
|
|
|
|
|
0
|
for my $val ($data{$col}) { |
871
|
|
|
|
|
|
|
|
872
|
0
|
|
|
|
|
0
|
my $i = 0; |
873
|
|
|
|
|
|
|
|
874
|
0
|
0
|
|
|
|
0
|
if ($is_array) { |
875
|
|
|
|
|
|
|
|
876
|
0
|
|
0
|
|
|
0
|
my $val_type = Elive::Util::_reftype($val) || 'Scalar'; |
877
|
|
|
|
|
|
|
|
878
|
0
|
0
|
|
|
|
0
|
unless ($val_type eq 'ARRAY') { |
879
|
|
|
|
|
|
|
# |
880
|
|
|
|
|
|
|
# A single value deserialises to a simple |
881
|
|
|
|
|
|
|
# struct. Coerce it to a one element array |
882
|
|
|
|
|
|
|
# |
883
|
0
|
|
|
|
|
0
|
$val = [$val]; |
884
|
0
|
0
|
|
|
|
0
|
warn "thawing $val_type coerced element into array for $col" |
885
|
|
|
|
|
|
|
if ($class->debug); |
886
|
|
|
|
|
|
|
} |
887
|
|
|
|
|
|
|
} |
888
|
|
|
|
|
|
|
|
889
|
0
|
0
|
|
|
|
0
|
foreach ($is_array? @$val: $val) { |
890
|
|
|
|
|
|
|
|
891
|
0
|
0
|
|
|
|
0
|
next unless defined; |
892
|
|
|
|
|
|
|
|
893
|
0
|
0
|
|
|
|
0
|
my $idx = $is_array? '['.$i.']': ''; |
894
|
|
|
|
|
|
|
|
895
|
0
|
0
|
|
|
|
0
|
if ($is_struct) { |
896
|
|
|
|
|
|
|
|
897
|
0
|
|
|
|
|
0
|
$_ = $type->_thaw($_, $path . $idx); |
898
|
|
|
|
|
|
|
|
899
|
|
|
|
|
|
|
} |
900
|
|
|
|
|
|
|
else { |
901
|
0
|
|
|
|
|
0
|
$_ = Elive::Util::_thaw($_, $type); |
902
|
|
|
|
|
|
|
} |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
|
905
|
0
|
0
|
|
|
|
0
|
if ($is_array) { |
906
|
0
|
|
|
|
|
0
|
@$val = grep {defined $_} @$val; |
|
0
|
|
|
|
|
0
|
|
907
|
|
|
|
|
|
|
} |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
# |
910
|
|
|
|
|
|
|
# don't store null values, just omit the property. |
911
|
|
|
|
|
|
|
# saves a heap of work in Moose/Mouse constraints |
912
|
|
|
|
|
|
|
# |
913
|
0
|
0
|
|
|
|
0
|
if (defined $val) { |
914
|
0
|
|
|
|
|
0
|
$data{$col} = $val; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
else { |
917
|
0
|
|
|
|
|
0
|
delete $data{$col}; |
918
|
|
|
|
|
|
|
} |
919
|
|
|
|
|
|
|
} |
920
|
|
|
|
|
|
|
} |
921
|
|
|
|
|
|
|
|
922
|
0
|
0
|
|
|
|
0
|
if ($class->debug) { |
923
|
0
|
|
|
|
|
0
|
warn "thawed: $class: ".YAML::Syck::Dump( |
924
|
|
|
|
|
|
|
{db => $entity_data, |
925
|
|
|
|
|
|
|
thawed => \%data} |
926
|
|
|
|
|
|
|
); |
927
|
|
|
|
|
|
|
} |
928
|
|
|
|
|
|
|
|
929
|
0
|
|
|
|
|
0
|
return \%data; |
930
|
|
|
|
|
|
|
} |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
sub _process_results { |
933
|
0
|
|
|
0
|
|
0
|
my ($class, $soap_results) = @_; |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
# |
936
|
|
|
|
|
|
|
# Thaw our returned SOAP responses to reconstruct the data |
937
|
|
|
|
|
|
|
# image. |
938
|
|
|
|
|
|
|
# |
939
|
|
|
|
|
|
|
|
940
|
0
|
|
|
|
|
0
|
my @rows; |
941
|
|
|
|
|
|
|
|
942
|
0
|
|
|
|
|
0
|
foreach (@$soap_results) { |
943
|
|
|
|
|
|
|
|
944
|
0
|
|
|
|
|
0
|
my $row = $class->_thaw($_); |
945
|
|
|
|
|
|
|
|
946
|
0
|
|
|
|
|
0
|
push(@rows, $row); |
947
|
|
|
|
|
|
|
} |
948
|
|
|
|
|
|
|
|
949
|
0
|
|
|
|
|
0
|
return \@rows; |
950
|
|
|
|
|
|
|
} |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
sub _readback_check { |
953
|
0
|
|
|
0
|
|
0
|
my ($class, $updates_raw, $rows, %opt) = @_; |
954
|
|
|
|
|
|
|
|
955
|
0
|
|
|
|
|
0
|
my $updates = $class->_freeze( $updates_raw, canonical => 1); |
956
|
|
|
|
|
|
|
|
957
|
0
|
0
|
|
|
|
0
|
warn YAML::Syck::Dump({class => $class, updates_raw => $updates_raw, updates => $updates}) |
958
|
|
|
|
|
|
|
if ($class->debug >= 5); |
959
|
|
|
|
|
|
|
|
960
|
0
|
|
|
|
|
0
|
foreach my $row_raw (@$rows) { |
961
|
|
|
|
|
|
|
|
962
|
0
|
|
|
|
|
0
|
my $row = $class->_freeze( $row_raw, canonical => 1); |
963
|
|
|
|
|
|
|
|
964
|
0
|
0
|
|
|
|
0
|
warn YAML::Syck::Dump({row_raw => $row_raw, row => $row}) |
965
|
|
|
|
|
|
|
if ($class->debug >= 5); |
966
|
|
|
|
|
|
|
|
967
|
0
|
|
|
|
|
0
|
foreach ($class->properties) { |
968
|
0
|
0
|
0
|
|
|
0
|
if (exists $updates->{$_} && exists $row->{$_}) { |
969
|
0
|
|
|
|
|
0
|
my $write_val = $updates->{$_}; |
970
|
0
|
|
|
|
|
0
|
my $read_val = $row->{$_}; |
971
|
|
|
|
|
|
|
|
972
|
0
|
0
|
|
|
|
0
|
if ($write_val ne $read_val) { |
973
|
|
|
|
|
|
|
|
974
|
0
|
|
|
|
|
0
|
my $property_type = $class->property_types->{$_}; |
975
|
|
|
|
|
|
|
|
976
|
0
|
0
|
|
|
|
0
|
warn YAML::Syck::Dump({read => $read_val, sent => $write_val, type => "$property_type"}) |
977
|
|
|
|
|
|
|
if ($class->debug >= 2); |
978
|
|
|
|
|
|
|
|
979
|
0
|
|
|
|
|
0
|
croak "${class}: Update consistancy check failed on $_ (${property_type}), sent:".Elive::Util::string($write_val, $property_type).", read-back:".Elive::Util::string($read_val, $property_type); |
980
|
|
|
|
|
|
|
} |
981
|
|
|
|
|
|
|
} |
982
|
|
|
|
|
|
|
} |
983
|
|
|
|
|
|
|
} |
984
|
|
|
|
|
|
|
|
985
|
0
|
|
|
|
|
0
|
return @$rows; |
986
|
|
|
|
|
|
|
} |
987
|
|
|
|
|
|
|
|
988
|
|
|
|
|
|
|
=head2 is_changed |
989
|
|
|
|
|
|
|
|
990
|
|
|
|
|
|
|
Abstract method. Returns a list of properties that have been changed since the |
991
|
|
|
|
|
|
|
entity was last retrieved or saved. |
992
|
|
|
|
|
|
|
|
993
|
|
|
|
|
|
|
=cut |
994
|
|
|
|
|
|
|
|
995
|
|
|
|
|
|
|
sub is_changed { |
996
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
997
|
|
|
|
|
|
|
|
998
|
0
|
|
|
|
|
0
|
my @updated_properties; |
999
|
0
|
|
|
|
|
0
|
my $db_data = $self->_db_data; |
1000
|
|
|
|
|
|
|
|
1001
|
0
|
0
|
|
|
|
0
|
unless ($db_data) { |
1002
|
|
|
|
|
|
|
# |
1003
|
|
|
|
|
|
|
# not mapped to a stored data value. scratch object?, sub entity? |
1004
|
|
|
|
|
|
|
# |
1005
|
0
|
|
|
|
|
0
|
Carp::carp( ref($self)."->is_changed called on non-database object (".$self->stringify.")\n" ); |
1006
|
0
|
|
|
|
|
0
|
return; |
1007
|
|
|
|
|
|
|
} |
1008
|
|
|
|
|
|
|
|
1009
|
0
|
|
|
|
|
0
|
my @props = $self->properties; |
1010
|
0
|
|
|
|
|
0
|
my $property_types = $self->property_types; |
1011
|
|
|
|
|
|
|
|
1012
|
0
|
|
|
|
|
0
|
foreach my $prop (@props) { |
1013
|
|
|
|
|
|
|
|
1014
|
0
|
|
|
|
|
0
|
my $new = $self->$prop; |
1015
|
0
|
|
|
|
|
0
|
my $old = $db_data->$prop; |
1016
|
0
|
|
|
|
|
0
|
my $type = $property_types->{$prop}; |
1017
|
|
|
|
|
|
|
|
1018
|
0
|
0
|
0
|
|
|
0
|
die (ref($self)." - attribute $prop contains tainted data") |
1019
|
|
|
|
|
|
|
if Elive::Util::_tainted($new) || Elive::Util::_tainted($old); |
1020
|
|
|
|
|
|
|
|
1021
|
0
|
0
|
0
|
|
|
0
|
if (defined ($new) != defined ($old) |
1022
|
|
|
|
|
|
|
|| $self->_cmp_col($type, $new, $old)) { |
1023
|
|
|
|
|
|
|
|
1024
|
0
|
|
|
|
|
0
|
push (@updated_properties, $prop); |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
} |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
# |
1029
|
|
|
|
|
|
|
# warn if we catch a primary key modification, after the fact |
1030
|
|
|
|
|
|
|
# |
1031
|
0
|
|
|
|
|
0
|
my %primary_key = map {$_ => 1} ($self->primary_key); |
|
0
|
|
|
|
|
0
|
|
1032
|
0
|
|
|
|
|
0
|
my @primary_key_updates = grep { exists $primary_key{$_} } @updated_properties; |
|
0
|
|
|
|
|
0
|
|
1033
|
0
|
|
|
|
|
0
|
foreach my $prop (@primary_key_updates) { |
1034
|
|
|
|
|
|
|
|
1035
|
0
|
|
|
|
|
0
|
my $type = $property_types->{$prop}; |
1036
|
0
|
|
|
|
|
0
|
my $old_str = Elive::Util::string($db_data->$prop => $type); |
1037
|
0
|
|
|
|
|
0
|
my $new_str = Elive::Util::string($self->$prop => $type); |
1038
|
|
|
|
|
|
|
|
1039
|
0
|
|
|
|
|
0
|
Carp::carp( ref($self).": primary key field has been modified $prop: $old_str => $new_str" ); |
1040
|
|
|
|
|
|
|
} |
1041
|
|
|
|
|
|
|
|
1042
|
0
|
|
|
|
|
0
|
return @updated_properties; |
1043
|
|
|
|
|
|
|
} |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
=head2 set |
1046
|
|
|
|
|
|
|
|
1047
|
|
|
|
|
|
|
$obj->set(prop1 => val1, prop2 => val2 [,...]) |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
Abstract method to assign values to entity properties. |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
=cut |
1052
|
|
|
|
|
|
|
|
1053
|
|
|
|
|
|
|
sub set { |
1054
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
1055
|
0
|
|
|
|
|
0
|
my %data = @_; |
1056
|
|
|
|
|
|
|
|
1057
|
0
|
0
|
|
|
|
0
|
croak "attempt to modify data in a deleted record" |
1058
|
|
|
|
|
|
|
if ($self->_deleted); |
1059
|
|
|
|
|
|
|
|
1060
|
0
|
|
|
|
|
0
|
my %entity_column = map {$_ => 1} ($self->properties); |
|
0
|
|
|
|
|
0
|
|
1061
|
0
|
|
|
|
|
0
|
my %primary_key = map {$_ => 1} ($self->primary_key); |
|
0
|
|
|
|
|
0
|
|
1062
|
|
|
|
|
|
|
|
1063
|
0
|
|
|
|
|
0
|
$self->_canonicalize_properties( \%data ); |
1064
|
|
|
|
|
|
|
|
1065
|
0
|
|
|
|
|
0
|
foreach (keys %data) { |
1066
|
|
|
|
|
|
|
|
1067
|
0
|
0
|
|
|
|
0
|
unless ($entity_column{$_}) { |
1068
|
0
|
|
0
|
|
|
0
|
Carp::carp ((ref($self)||$self).": unknown property: $_"); |
1069
|
0
|
|
|
|
|
0
|
next; |
1070
|
|
|
|
|
|
|
} |
1071
|
|
|
|
|
|
|
|
1072
|
0
|
0
|
0
|
|
|
0
|
my $type = $self->property_types->{$_} |
1073
|
|
|
|
|
|
|
or die ((ref($self)||$self).": unable to determine property type for field: $_"); |
1074
|
|
|
|
|
|
|
|
1075
|
0
|
0
|
|
|
|
0
|
if (exists $primary_key{ $_ }) { |
1076
|
|
|
|
|
|
|
|
1077
|
0
|
|
|
|
|
0
|
my $old_val = $self->{$_}; |
1078
|
|
|
|
|
|
|
|
1079
|
0
|
0
|
0
|
|
|
0
|
if (defined $old_val && !defined $data{$_}) { |
|
|
0
|
|
|
|
|
|
1080
|
0
|
|
|
|
|
0
|
die "attempt to delete primary key"; |
1081
|
|
|
|
|
|
|
} |
1082
|
|
|
|
|
|
|
elsif ($self->_cmp_col($type, $old_val, $data{$_})) { |
1083
|
0
|
|
|
|
|
0
|
die "attempt to update primary key"; |
1084
|
|
|
|
|
|
|
} |
1085
|
|
|
|
|
|
|
} |
1086
|
|
|
|
|
|
|
|
1087
|
0
|
|
|
|
|
0
|
my $meta = $self->meta; |
1088
|
0
|
|
|
|
|
0
|
my $attribute = $meta->get_attribute($_); |
1089
|
0
|
|
|
|
|
0
|
my $value = $data{$_}; |
1090
|
|
|
|
|
|
|
|
1091
|
0
|
0
|
|
|
|
0
|
if (defined $value) { |
1092
|
|
|
|
|
|
|
|
1093
|
0
|
0
|
|
|
|
0
|
if (ref($value)) { |
1094
|
|
|
|
|
|
|
# |
1095
|
|
|
|
|
|
|
# inspect the item to see if we need to stringify back to |
1096
|
|
|
|
|
|
|
# a simpler type. For example we may have been passed an |
1097
|
|
|
|
|
|
|
# object, rather than just its primary key. |
1098
|
|
|
|
|
|
|
# |
1099
|
0
|
0
|
|
|
|
0
|
$value = Elive::Util::string($value, $type) |
1100
|
|
|
|
|
|
|
unless Elive::Util::inspect_type($type)->is_ref; |
1101
|
|
|
|
|
|
|
} |
1102
|
|
|
|
|
|
|
|
1103
|
0
|
0
|
|
|
|
0
|
die (ref($self)." - attempt to set attribute $_ to tainted data") |
1104
|
|
|
|
|
|
|
if Elive::Util::_tainted($value); |
1105
|
|
|
|
|
|
|
|
1106
|
0
|
|
|
|
|
0
|
$self->$_($value); |
1107
|
|
|
|
|
|
|
} |
1108
|
|
|
|
|
|
|
else { |
1109
|
|
|
|
|
|
|
|
1110
|
0
|
0
|
|
|
|
0
|
die ref($self).": attempt to delete required attribute: $_" |
1111
|
|
|
|
|
|
|
if $attribute->is_required; |
1112
|
|
|
|
|
|
|
|
1113
|
0
|
|
|
|
|
0
|
delete $self->{$_}; |
1114
|
|
|
|
|
|
|
} |
1115
|
|
|
|
|
|
|
} |
1116
|
|
|
|
|
|
|
|
1117
|
0
|
|
|
|
|
0
|
return $self; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
|
1120
|
|
|
|
|
|
|
sub _readback { |
1121
|
0
|
|
|
0
|
|
0
|
my ($class, $som, $sent_data, $connection, %opt) = @_; |
1122
|
|
|
|
|
|
|
# |
1123
|
|
|
|
|
|
|
# Inserts and updates normally return a copy of the entity after |
1124
|
|
|
|
|
|
|
# an insert or update. Confirm that the output record contains |
1125
|
|
|
|
|
|
|
# the updates and return it. |
1126
|
|
|
|
|
|
|
|
1127
|
0
|
|
|
|
|
0
|
my $results = $class->_get_results($som, $connection); |
1128
|
|
|
|
|
|
|
# |
1129
|
|
|
|
|
|
|
# Check that the return response has our inserts/updates |
1130
|
|
|
|
|
|
|
# |
1131
|
0
|
|
|
|
|
0
|
my $rows = $class->_process_results( $results ); |
1132
|
0
|
|
|
|
|
0
|
$class->_readback_check($sent_data, $rows, %opt); |
1133
|
|
|
|
|
|
|
|
1134
|
0
|
|
|
|
|
0
|
return @$rows; |
1135
|
|
|
|
|
|
|
} |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
sub _to_aliases { |
1138
|
1
|
|
|
1
|
|
322
|
my $class = shift; |
1139
|
|
|
|
|
|
|
|
1140
|
1
|
|
|
|
|
6
|
my $aliases = $class->_get_aliases; |
1141
|
|
|
|
|
|
|
|
1142
|
1
|
|
|
|
|
3
|
my %aliased_to; |
1143
|
|
|
|
|
|
|
|
1144
|
1
|
|
|
|
|
5
|
foreach my $alias (keys %$aliases) { |
1145
|
7
|
50
|
|
|
|
17
|
my $to = $aliases->{$alias}{to} |
1146
|
|
|
|
|
|
|
or die "malformed alias: $alias"; |
1147
|
|
|
|
|
|
|
|
1148
|
7
|
|
|
|
|
10
|
$aliased_to{$alias} = $to; |
1149
|
|
|
|
|
|
|
} |
1150
|
|
|
|
|
|
|
|
1151
|
1
|
|
|
|
|
6
|
return %aliased_to; |
1152
|
|
|
|
|
|
|
} |
1153
|
|
|
|
|
|
|
|
1154
|
|
|
|
|
|
|
=head2 insert |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
my $new_user = Elive::Entity::User->insert( |
1157
|
|
|
|
|
|
|
{loginName => 'demo_user', |
1158
|
|
|
|
|
|
|
email => 'demo.user@test.org'} |
1159
|
|
|
|
|
|
|
}, |
1160
|
|
|
|
|
|
|
connection => $con, # connection to use, |
1161
|
|
|
|
|
|
|
command => $cmd, # soap command to use |
1162
|
|
|
|
|
|
|
); |
1163
|
|
|
|
|
|
|
|
1164
|
|
|
|
|
|
|
print "inserted user with id: ".$new_user->userId."\n"; |
1165
|
|
|
|
|
|
|
|
1166
|
|
|
|
|
|
|
Abstract method to insert new entities. The primary key is generally not |
1167
|
|
|
|
|
|
|
required. It is generated for you and returned with the newly created object. |
1168
|
|
|
|
|
|
|
|
1169
|
|
|
|
|
|
|
=cut |
1170
|
|
|
|
|
|
|
|
1171
|
|
|
|
|
|
|
sub insert { |
1172
|
0
|
|
|
0
|
1
|
0
|
my ($class, $_insert_data, %opt) = @_; |
1173
|
|
|
|
|
|
|
|
1174
|
0
|
0
|
0
|
|
|
0
|
my $connection = $opt{connection} || $class->connection |
1175
|
|
|
|
|
|
|
or die "not connected"; |
1176
|
|
|
|
|
|
|
|
1177
|
0
|
|
|
|
|
0
|
my %insert_data = %$_insert_data; |
1178
|
0
|
0
|
|
|
|
0
|
my %params = %{delete $opt{param} || {}}; |
|
0
|
|
|
|
|
0
|
|
1179
|
|
|
|
|
|
|
|
1180
|
0
|
|
|
|
|
0
|
my $data_params = $class->_freeze({%insert_data, %params}); |
1181
|
|
|
|
|
|
|
|
1182
|
0
|
|
0
|
|
|
0
|
my $command = $opt{command} || 'create'.$class->entity_name; |
1183
|
|
|
|
|
|
|
|
1184
|
0
|
|
|
|
|
0
|
$connection->check_command($command => 'c'); |
1185
|
|
|
|
|
|
|
|
1186
|
0
|
|
|
|
|
0
|
my $som = $connection->call($command, %$data_params); |
1187
|
|
|
|
|
|
|
|
1188
|
0
|
|
|
|
|
0
|
my @rows = $class->_readback($som, $_insert_data, $connection, %opt); |
1189
|
|
|
|
|
|
|
|
1190
|
0
|
|
|
|
|
0
|
my @objs = (map {$class->construct( $_, connection => $connection )} |
|
0
|
|
|
|
|
0
|
|
1191
|
|
|
|
|
|
|
@rows); |
1192
|
|
|
|
|
|
|
# |
1193
|
|
|
|
|
|
|
# possibly return a list of recurring meetings. |
1194
|
|
|
|
|
|
|
# |
1195
|
0
|
0
|
|
|
|
0
|
return wantarray? @objs : $objs[0]; |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
=head2 live_entity |
1199
|
|
|
|
|
|
|
|
1200
|
|
|
|
|
|
|
my $user_ref |
1201
|
|
|
|
|
|
|
= Elive::Entity->live_entity('http://test.org/User/1234567890'); |
1202
|
|
|
|
|
|
|
|
1203
|
|
|
|
|
|
|
Returns a reference to an object in the Elive::Entity cache. |
1204
|
|
|
|
|
|
|
|
1205
|
|
|
|
|
|
|
=cut |
1206
|
|
|
|
|
|
|
|
1207
|
|
|
|
|
|
|
sub live_entity { |
1208
|
0
|
|
|
0
|
1
|
0
|
my $class = shift; |
1209
|
0
|
|
|
|
|
0
|
my $url = shift; |
1210
|
|
|
|
|
|
|
|
1211
|
0
|
|
|
|
|
0
|
return $Stored_Objects{ $url }; |
1212
|
|
|
|
|
|
|
} |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
=head2 live_entities |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
my $live_entities = Elive::Entity->live_entities; |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
my $user_ref = $live_entities->{'http://test.org/User/1234567890'}; |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
Returns a reference to the Elive::Entity cache. |
1221
|
|
|
|
|
|
|
|
1222
|
|
|
|
|
|
|
=cut |
1223
|
|
|
|
|
|
|
|
1224
|
|
|
|
|
|
|
sub live_entities { |
1225
|
0
|
|
|
0
|
1
|
0
|
my $class = shift; |
1226
|
0
|
|
|
|
|
0
|
return \%Stored_Objects; |
1227
|
|
|
|
|
|
|
} |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
=head2 update |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
Abstract method to update entities. The following commits outstanding changes |
1232
|
|
|
|
|
|
|
to the object. |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
$obj->{foo} = 'Foo'; # change foo attribute directly |
1235
|
|
|
|
|
|
|
$foo->update; # save |
1236
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
$obj->bar('Bar'); # change bar via its accessor |
1238
|
|
|
|
|
|
|
$obj->update; # save |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
Updates may also be passed as parameters: |
1241
|
|
|
|
|
|
|
|
1242
|
|
|
|
|
|
|
# change and save foo and bar. All in one go. |
1243
|
|
|
|
|
|
|
$obj->update({foo => 'Foo', bar => 'Bar'}); |
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
=cut |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
sub update { |
1248
|
0
|
|
|
0
|
1
|
0
|
my ($self, $_update_data, %opt) = @_; |
1249
|
|
|
|
|
|
|
|
1250
|
0
|
0
|
|
|
|
0
|
die "attempted to update deleted record" |
1251
|
|
|
|
|
|
|
if ($self->_deleted); |
1252
|
|
|
|
|
|
|
|
1253
|
0
|
0
|
|
|
|
0
|
my %params = %{ $opt{param} || {} }; |
|
0
|
|
|
|
|
0
|
|
1254
|
0
|
|
|
|
|
0
|
my %update_data; |
1255
|
|
|
|
|
|
|
|
1256
|
0
|
0
|
|
|
|
0
|
if ($_update_data) { |
1257
|
|
|
|
|
|
|
|
1258
|
0
|
0
|
|
|
|
0
|
croak 'usage: $obj->update( \%data )' |
1259
|
|
|
|
|
|
|
unless (Elive::Util::_reftype($_update_data) eq 'HASH'); |
1260
|
|
|
|
|
|
|
|
1261
|
0
|
|
|
|
|
0
|
%update_data = %{ $_update_data }; |
|
0
|
|
|
|
|
0
|
|
1262
|
|
|
|
|
|
|
# |
1263
|
|
|
|
|
|
|
# sift out things which are included in the data payload, but should |
1264
|
|
|
|
|
|
|
# be parameters. |
1265
|
|
|
|
|
|
|
# |
1266
|
0
|
|
|
|
|
0
|
my %param_names = $self->params; |
1267
|
0
|
|
|
|
|
0
|
foreach (grep {exists $update_data{$_}} %param_names) { |
|
0
|
|
|
|
|
0
|
|
1268
|
0
|
|
|
|
|
0
|
my $val = delete $update_data{$_}; |
1269
|
0
|
0
|
|
|
|
0
|
$params{$_} = $val unless exists $params{$_}; |
1270
|
|
|
|
|
|
|
} |
1271
|
|
|
|
|
|
|
|
1272
|
0
|
0
|
|
|
|
0
|
$self->set( %update_data) |
1273
|
|
|
|
|
|
|
if (keys %update_data); |
1274
|
|
|
|
|
|
|
} |
1275
|
|
|
|
|
|
|
|
1276
|
|
|
|
|
|
|
# |
1277
|
|
|
|
|
|
|
# Write only changed properties. |
1278
|
|
|
|
|
|
|
# |
1279
|
0
|
|
|
|
|
0
|
my @updated_properties = ($opt{changed} |
1280
|
0
|
0
|
|
|
|
0
|
? @{$opt{changed}} |
1281
|
|
|
|
|
|
|
: $self->is_changed); |
1282
|
|
|
|
|
|
|
|
1283
|
0
|
|
|
|
|
0
|
my %primary_key = map {$_ => 1} ($self->primary_key); |
|
0
|
|
|
|
|
0
|
|
1284
|
|
|
|
|
|
|
|
1285
|
|
|
|
|
|
|
# |
1286
|
|
|
|
|
|
|
# merge in pending updates to the current entity. |
1287
|
|
|
|
|
|
|
# |
1288
|
0
|
|
|
|
|
0
|
my %updates; |
1289
|
|
|
|
|
|
|
|
1290
|
0
|
|
|
|
|
0
|
foreach (@updated_properties, keys %primary_key) { |
1291
|
|
|
|
|
|
|
|
1292
|
0
|
|
|
|
|
0
|
my $update_val = $self->$_; |
1293
|
|
|
|
|
|
|
|
1294
|
0
|
0
|
|
|
|
0
|
if (exists $primary_key{$_} ) { |
1295
|
0
|
|
|
|
|
0
|
my $type = $self->property_types->{$_}; |
1296
|
0
|
|
|
|
|
0
|
my $db_val = $self->_db_data->$_; |
1297
|
0
|
0
|
|
|
|
0
|
croak 'primary key field $_ updated - refusing to save' |
1298
|
|
|
|
|
|
|
if $self->_cmp_col($type, $db_val, $update_val); |
1299
|
|
|
|
|
|
|
} |
1300
|
|
|
|
|
|
|
|
1301
|
0
|
|
|
|
|
0
|
$updates{$_} = $update_val; |
1302
|
|
|
|
|
|
|
} |
1303
|
|
|
|
|
|
|
|
1304
|
0
|
|
0
|
|
|
0
|
my $command = $opt{command} || 'update'.$self->entity_name; |
1305
|
|
|
|
|
|
|
|
1306
|
0
|
|
|
|
|
0
|
$self->connection->check_command($command => 'u'); |
1307
|
|
|
|
|
|
|
|
1308
|
0
|
|
|
|
|
0
|
my $data_frozen = $self->_freeze({%updates, %params}); |
1309
|
|
|
|
|
|
|
|
1310
|
0
|
|
|
|
|
0
|
my $som = $self->connection->call($command, %$data_frozen); |
1311
|
|
|
|
|
|
|
|
1312
|
0
|
|
|
|
|
0
|
my $class = ref($self); |
1313
|
|
|
|
|
|
|
|
1314
|
0
|
|
|
|
|
0
|
my @rows = $class->_readback($som, \%updates, $self->connection, %opt); |
1315
|
0
|
|
|
|
|
0
|
my $data = $rows[0]; |
1316
|
|
|
|
|
|
|
|
1317
|
0
|
0
|
0
|
|
|
0
|
unless ($data && Elive::Util::_reftype($data) eq 'HASH') { |
1318
|
|
|
|
|
|
|
|
1319
|
0
|
0
|
|
|
|
0
|
warn "no data in update response - having to re-fetch (grrrr!)" |
1320
|
|
|
|
|
|
|
if $class->debug; |
1321
|
|
|
|
|
|
|
|
1322
|
0
|
0
|
|
|
|
0
|
$data = $class->retrieve( $self->stringify, raw => 1) |
1323
|
|
|
|
|
|
|
or die "unable to get update results"; |
1324
|
|
|
|
|
|
|
|
1325
|
0
|
|
|
|
|
0
|
$class->_readback_check(\%updates, [$data], %opt); |
1326
|
|
|
|
|
|
|
} |
1327
|
|
|
|
|
|
|
|
1328
|
|
|
|
|
|
|
# |
1329
|
|
|
|
|
|
|
# refresh the object from the database read-back |
1330
|
|
|
|
|
|
|
# |
1331
|
0
|
|
|
|
|
0
|
my $obj = $self->construct($data, connection => $self->connection, overwrite => 1, copy => $self->_is_copy); |
1332
|
|
|
|
|
|
|
|
1333
|
0
|
0
|
|
|
|
0
|
unless ($obj->_refaddr eq $self->_refaddr) { |
1334
|
0
|
0
|
|
|
|
0
|
warn $obj->url." (obj=$obj, self=$self) - not in cache, nor is it a copy." |
1335
|
|
|
|
|
|
|
unless $self->_is_copy; |
1336
|
|
|
|
|
|
|
# clone the result |
1337
|
0
|
|
|
|
|
0
|
%{$self} = %{ Elive::Util::_clone($obj) }; |
|
0
|
|
|
|
|
0
|
|
|
0
|
|
|
|
|
0
|
|
1338
|
0
|
|
|
|
|
0
|
$self->__set_db_data( Elive::Util::_clone($obj->_db_data), connection => $self->connection, copy => 1); |
1339
|
|
|
|
|
|
|
} |
1340
|
|
|
|
|
|
|
|
1341
|
0
|
|
|
|
|
0
|
return $self; |
1342
|
|
|
|
|
|
|
} |
1343
|
|
|
|
|
|
|
|
1344
|
|
|
|
|
|
|
=head2 list |
1345
|
|
|
|
|
|
|
|
1346
|
|
|
|
|
|
|
my $users = Elive::Entity::User->list( |
1347
|
|
|
|
|
|
|
filter => 'surname = smith', # filter results (server side) |
1348
|
|
|
|
|
|
|
command => $cmd, # soap command to use |
1349
|
|
|
|
|
|
|
connection => $connection, # connection to use |
1350
|
|
|
|
|
|
|
raw => 1, # return unblessed data |
1351
|
|
|
|
|
|
|
); |
1352
|
|
|
|
|
|
|
|
1353
|
|
|
|
|
|
|
Abstract method to list entity objects. |
1354
|
|
|
|
|
|
|
|
1355
|
|
|
|
|
|
|
=cut |
1356
|
|
|
|
|
|
|
|
1357
|
|
|
|
|
|
|
sub list { |
1358
|
0
|
|
|
0
|
1
|
0
|
my ($class, %opt) = @_; |
1359
|
|
|
|
|
|
|
|
1360
|
0
|
|
|
|
|
0
|
my @params; |
1361
|
|
|
|
|
|
|
|
1362
|
0
|
0
|
|
|
|
0
|
if (my $filter = delete $opt{filter} ) { |
1363
|
0
|
|
|
|
|
0
|
push( @params, filter => Elive::Util::_freeze($filter => 'Str') ); |
1364
|
|
|
|
|
|
|
} |
1365
|
|
|
|
|
|
|
|
1366
|
0
|
0
|
0
|
|
|
0
|
my $connection = $opt{connection} || $class->connection |
1367
|
|
|
|
|
|
|
or die "no connection active"; |
1368
|
|
|
|
|
|
|
|
1369
|
0
|
|
0
|
|
|
0
|
my $collection_name = $class->collection_name || $class->entity_name; |
1370
|
|
|
|
|
|
|
|
1371
|
0
|
0
|
|
|
|
0
|
die "misconfigured class $class - has neither a collection_name or entity_name" |
1372
|
|
|
|
|
|
|
unless $collection_name; |
1373
|
|
|
|
|
|
|
|
1374
|
0
|
|
0
|
|
|
0
|
my $command = $opt{command} || 'list'.$collection_name; |
1375
|
0
|
|
|
|
|
0
|
$connection->check_command($command => 'r'); |
1376
|
|
|
|
|
|
|
|
1377
|
0
|
|
|
|
|
0
|
my $som = $connection->call($command, @params); |
1378
|
|
|
|
|
|
|
|
1379
|
0
|
|
|
|
|
0
|
my $results = $class->_get_results($som,$connection); |
1380
|
|
|
|
|
|
|
|
1381
|
0
|
|
|
|
|
0
|
my $rows = $class->_process_results( $results ); |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
return [ |
1384
|
0
|
|
|
|
|
0
|
map { $class->construct( $_, connection => $connection) } |
|
0
|
|
|
|
|
0
|
|
1385
|
|
|
|
|
|
|
@$rows |
1386
|
|
|
|
|
|
|
]; |
1387
|
|
|
|
|
|
|
} |
1388
|
|
|
|
|
|
|
|
1389
|
|
|
|
|
|
|
sub _fetch { |
1390
|
0
|
|
|
0
|
|
0
|
my ($class, $db_query, %opt) = @_; |
1391
|
|
|
|
|
|
|
|
1392
|
0
|
|
0
|
|
|
0
|
$db_query ||= {}; |
1393
|
|
|
|
|
|
|
|
1394
|
0
|
0
|
|
|
|
0
|
croak "usage: ${class}->_fetch( \\%query )" |
1395
|
|
|
|
|
|
|
unless (Elive::Util::_reftype($db_query) eq 'HASH'); |
1396
|
|
|
|
|
|
|
|
1397
|
0
|
0
|
0
|
|
|
0
|
my $connection = $opt{connection} || $class->connection |
1398
|
|
|
|
|
|
|
or die "no connection active"; |
1399
|
|
|
|
|
|
|
|
1400
|
0
|
|
0
|
|
|
0
|
my $command = $opt{command} || 'get'.$class->entity_name; |
1401
|
|
|
|
|
|
|
|
1402
|
0
|
0
|
|
|
|
0
|
warn "get: entity name for $class: ".$class->entity_name.", command: ".$command |
1403
|
|
|
|
|
|
|
if $class->debug; |
1404
|
|
|
|
|
|
|
|
1405
|
0
|
|
|
|
|
0
|
$connection->check_command($command => 'r'); |
1406
|
|
|
|
|
|
|
|
1407
|
0
|
|
|
|
|
0
|
my $db_query_frozen = $class->_freeze( $db_query ); |
1408
|
|
|
|
|
|
|
|
1409
|
0
|
|
|
|
|
0
|
my $som = $connection->call($command, %{$db_query_frozen}); |
|
0
|
|
|
|
|
0
|
|
1410
|
|
|
|
|
|
|
|
1411
|
0
|
|
|
|
|
0
|
my $results = $class->_get_results($som, $connection); |
1412
|
|
|
|
|
|
|
|
1413
|
0
|
|
|
|
|
0
|
my $rows = $class->_process_results( $results ); |
1414
|
0
|
0
|
|
|
|
0
|
return $rows if $opt{raw}; |
1415
|
|
|
|
|
|
|
# |
1416
|
|
|
|
|
|
|
# 0 results => not found. Would be treated by readback as an error, |
1417
|
|
|
|
|
|
|
# but perfectly valid here. Just means we didn't find a matching entity. |
1418
|
|
|
|
|
|
|
# |
1419
|
0
|
0
|
|
|
|
0
|
return [] |
1420
|
|
|
|
|
|
|
unless @$rows; |
1421
|
|
|
|
|
|
|
|
1422
|
0
|
|
|
|
|
0
|
$class->_readback_check($db_query, $rows, %opt); |
1423
|
0
|
|
|
|
|
0
|
return [map {$class->construct( $_, connection => $connection )} @$rows]; |
|
0
|
|
|
|
|
0
|
|
1424
|
|
|
|
|
|
|
} |
1425
|
|
|
|
|
|
|
|
1426
|
|
|
|
|
|
|
=head2 retrieve |
1427
|
|
|
|
|
|
|
|
1428
|
|
|
|
|
|
|
my $user = Elive::Entity::User->retrieve( |
1429
|
|
|
|
|
|
|
$user_id, |
1430
|
|
|
|
|
|
|
reuse => 1, # use cached data if present. |
1431
|
|
|
|
|
|
|
); |
1432
|
|
|
|
|
|
|
|
1433
|
|
|
|
|
|
|
|
1434
|
|
|
|
|
|
|
Abstract method to retrieve a single entity object by primary key. |
1435
|
|
|
|
|
|
|
|
1436
|
|
|
|
|
|
|
=cut |
1437
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
sub retrieve { |
1439
|
0
|
|
|
0
|
1
|
0
|
my ($class, $vals, %opt) = @_; |
1440
|
|
|
|
|
|
|
|
1441
|
0
|
0
|
0
|
|
|
0
|
$vals = [$vals] |
1442
|
|
|
|
|
|
|
if $vals && Elive::Util::_reftype($vals) ne 'ARRAY'; |
1443
|
|
|
|
|
|
|
|
1444
|
0
|
|
|
|
|
0
|
my @key_cols = $class->primary_key; |
1445
|
|
|
|
|
|
|
|
1446
|
0
|
|
|
|
|
0
|
for (my $n = 0; $n < @key_cols; $n++) { |
1447
|
|
|
|
|
|
|
|
1448
|
0
|
0
|
|
|
|
0
|
die "incomplete primary key value for: $key_cols[$n]" |
1449
|
|
|
|
|
|
|
unless defined ($vals->[$n]); |
1450
|
|
|
|
|
|
|
} |
1451
|
|
|
|
|
|
|
|
1452
|
0
|
0
|
0
|
|
|
0
|
my $connection = $opt{connection} || $class->connection |
1453
|
|
|
|
|
|
|
or die "not connected"; |
1454
|
|
|
|
|
|
|
|
1455
|
0
|
0
|
|
|
|
0
|
if ($opt{reuse}) { |
1456
|
|
|
|
|
|
|
# |
1457
|
|
|
|
|
|
|
# Have we already got the object cached? If so return it |
1458
|
|
|
|
|
|
|
# |
1459
|
0
|
|
|
|
|
0
|
my %pkey; |
1460
|
0
|
|
|
|
|
0
|
@pkey{$class->primary_key} = @$vals; |
1461
|
|
|
|
|
|
|
|
1462
|
0
|
|
|
|
|
0
|
my $obj_url = $class->_restful_url( |
1463
|
|
|
|
|
|
|
$connection, |
1464
|
|
|
|
|
|
|
$class->stringify(\%pkey) |
1465
|
|
|
|
|
|
|
); |
1466
|
|
|
|
|
|
|
|
1467
|
0
|
0
|
|
|
|
0
|
if ( my $cached = $class->live_entity($obj_url) ) { |
1468
|
0
|
0
|
|
|
|
0
|
die "cache type conflict. $obj_url contains an ".ref($cached)." object, but requested $class" |
1469
|
|
|
|
|
|
|
unless $cached->isa($class); |
1470
|
|
|
|
|
|
|
|
1471
|
0
|
0
|
|
|
|
0
|
warn "retrieve from cache $obj_url (".ref($cached).")" |
1472
|
|
|
|
|
|
|
if $class->debug; |
1473
|
|
|
|
|
|
|
|
1474
|
0
|
|
|
|
|
0
|
return $cached |
1475
|
|
|
|
|
|
|
} |
1476
|
|
|
|
|
|
|
} |
1477
|
|
|
|
|
|
|
# |
1478
|
|
|
|
|
|
|
# need to fetch it |
1479
|
|
|
|
|
|
|
# |
1480
|
0
|
|
|
|
|
0
|
my $all = $class->_retrieve_all($vals, %opt); |
1481
|
|
|
|
|
|
|
|
1482
|
|
|
|
|
|
|
# |
1483
|
|
|
|
|
|
|
# We've supplied a full primary key, so can expect 0 or 1 values |
1484
|
|
|
|
|
|
|
# to be returned. |
1485
|
|
|
|
|
|
|
# |
1486
|
0
|
0
|
|
|
|
0
|
warn "${class}->retrieve([@$vals]) returned extraneous data - discarding\n" |
1487
|
|
|
|
|
|
|
if (scalar @$all > 1); |
1488
|
|
|
|
|
|
|
|
1489
|
0
|
|
|
|
|
0
|
return $all->[0]; |
1490
|
|
|
|
|
|
|
} |
1491
|
|
|
|
|
|
|
|
1492
|
|
|
|
|
|
|
# _retrieve_all() - Retrieve entity objects by partial primary key. |
1493
|
|
|
|
|
|
|
# |
1494
|
|
|
|
|
|
|
# my $participants |
1495
|
|
|
|
|
|
|
# = Elive::Entity::ParticipantList->_retrieve_all($meeting_id) |
1496
|
|
|
|
|
|
|
# |
1497
|
|
|
|
|
|
|
|
1498
|
|
|
|
|
|
|
sub _retrieve_all { |
1499
|
0
|
|
|
0
|
|
0
|
my ($class, $vals, %opt) = @_; |
1500
|
|
|
|
|
|
|
|
1501
|
0
|
0
|
|
|
|
0
|
croak 'usage $class->_retrieve_all([$val,..],%opt)' |
1502
|
|
|
|
|
|
|
unless Elive::Util::_reftype($vals) eq 'ARRAY'; |
1503
|
|
|
|
|
|
|
|
1504
|
0
|
|
|
|
|
0
|
my @key_cols = $class->primary_key; |
1505
|
0
|
|
|
|
|
0
|
my @vals = @$vals; |
1506
|
|
|
|
|
|
|
|
1507
|
0
|
|
|
|
|
0
|
my %fetch; |
1508
|
|
|
|
|
|
|
|
1509
|
0
|
|
0
|
|
|
0
|
while (@vals && @key_cols) { |
1510
|
0
|
|
|
|
|
0
|
my $key = shift(@key_cols); |
1511
|
0
|
|
|
|
|
0
|
my $val = shift(@vals); |
1512
|
|
|
|
|
|
|
|
1513
|
0
|
0
|
|
|
|
0
|
$fetch{$key} = $val |
1514
|
|
|
|
|
|
|
if (defined $val); |
1515
|
|
|
|
|
|
|
} |
1516
|
|
|
|
|
|
|
|
1517
|
0
|
0
|
|
|
|
0
|
die "nothing to retrieve" |
1518
|
|
|
|
|
|
|
unless (keys %fetch); |
1519
|
|
|
|
|
|
|
|
1520
|
0
|
|
|
|
|
0
|
return $class->_fetch(\%fetch, %opt); |
1521
|
|
|
|
|
|
|
} |
1522
|
|
|
|
|
|
|
|
1523
|
|
|
|
|
|
|
=head2 delete |
1524
|
|
|
|
|
|
|
|
1525
|
|
|
|
|
|
|
$user_obj->delete; |
1526
|
|
|
|
|
|
|
|
1527
|
|
|
|
|
|
|
Abstract method to delete an entity. |
1528
|
|
|
|
|
|
|
|
1529
|
|
|
|
|
|
|
=cut |
1530
|
|
|
|
|
|
|
|
1531
|
|
|
|
|
|
|
sub delete { |
1532
|
0
|
|
|
0
|
1
|
0
|
my ($self, %opt) = @_; |
1533
|
|
|
|
|
|
|
|
1534
|
0
|
|
|
|
|
0
|
my @primary_key = $self->primary_key; |
1535
|
0
|
|
|
|
|
0
|
my @id = $self->id; |
1536
|
|
|
|
|
|
|
|
1537
|
0
|
0
|
|
|
|
0
|
die "entity lacks a primary key - can't delete" |
1538
|
|
|
|
|
|
|
unless (@primary_key > 0); |
1539
|
|
|
|
|
|
|
|
1540
|
0
|
|
|
|
|
0
|
my @params = map { |
1541
|
0
|
|
|
|
|
0
|
$_ => shift( @id ); |
1542
|
|
|
|
|
|
|
} @primary_key; |
1543
|
|
|
|
|
|
|
|
1544
|
0
|
|
0
|
|
|
0
|
my $command = $opt{command} || 'delete'.$self->entity_name; |
1545
|
0
|
|
|
|
|
0
|
$self->connection->check_command($command => 'd'); |
1546
|
|
|
|
|
|
|
|
1547
|
0
|
|
|
|
|
0
|
my $som = $self->connection->call($command, @params); |
1548
|
|
|
|
|
|
|
|
1549
|
0
|
|
|
|
|
0
|
my $results = $self->_get_results($som, $self->connection); |
1550
|
0
|
|
|
|
|
0
|
my $rows = $self->_process_results($results); |
1551
|
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
|
# |
1553
|
|
|
|
|
|
|
# Umm, we did get a read-back of the record, but the contents |
1554
|
|
|
|
|
|
|
# seem to be dubious. Perform cardinality checks, but don't do |
1555
|
|
|
|
|
|
|
# write-back checks. |
1556
|
|
|
|
|
|
|
# |
1557
|
|
|
|
|
|
|
|
1558
|
0
|
0
|
|
|
|
0
|
croak "Didn't receive a response for deletion: ".$self->entity_name |
1559
|
|
|
|
|
|
|
unless @$rows; |
1560
|
|
|
|
|
|
|
|
1561
|
0
|
0
|
|
|
|
0
|
croak "Received multiple responses for deletion: ".$self->entity_name |
1562
|
|
|
|
|
|
|
if (@$rows > 1); |
1563
|
|
|
|
|
|
|
|
1564
|
0
|
|
|
|
|
0
|
return $self->_deleted(1); |
1565
|
|
|
|
|
|
|
} |
1566
|
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
|
=head2 revert |
1568
|
|
|
|
|
|
|
|
1569
|
|
|
|
|
|
|
$user->revert # revert entire entity |
1570
|
|
|
|
|
|
|
$user->revert(qw/loginName email/); # revert selected properties |
1571
|
|
|
|
|
|
|
|
1572
|
|
|
|
|
|
|
Abstract method to revert an entity to its last constructed value. |
1573
|
|
|
|
|
|
|
|
1574
|
|
|
|
|
|
|
=cut |
1575
|
|
|
|
|
|
|
|
1576
|
|
|
|
|
|
|
our $REVERTING; |
1577
|
|
|
|
|
|
|
|
1578
|
|
|
|
|
|
|
sub revert { |
1579
|
0
|
|
|
0
|
1
|
0
|
my ($self, @props) = @_; |
1580
|
|
|
|
|
|
|
|
1581
|
0
|
|
|
|
|
0
|
local( $REVERTING ) = 1; |
1582
|
|
|
|
|
|
|
|
1583
|
0
|
0
|
|
|
|
0
|
my $db_data = $self->_db_data |
1584
|
|
|
|
|
|
|
or die "object doesn't have db-data!? - can't cope"; |
1585
|
|
|
|
|
|
|
|
1586
|
0
|
0
|
|
|
|
0
|
@props = $self->is_changed |
1587
|
|
|
|
|
|
|
unless @props; |
1588
|
|
|
|
|
|
|
|
1589
|
0
|
|
|
|
|
0
|
for (@props) { |
1590
|
|
|
|
|
|
|
|
1591
|
0
|
0
|
|
|
|
0
|
if (exists $db_data->{$_}) { |
1592
|
0
|
|
|
|
|
0
|
$self->{$_} = $db_data->{$_}; |
1593
|
|
|
|
|
|
|
} |
1594
|
|
|
|
|
|
|
else { |
1595
|
0
|
|
|
|
|
0
|
delete $self->{$_}; |
1596
|
|
|
|
|
|
|
} |
1597
|
|
|
|
|
|
|
} |
1598
|
|
|
|
|
|
|
|
1599
|
0
|
|
|
|
|
0
|
return $self; |
1600
|
|
|
|
|
|
|
} |
1601
|
|
|
|
|
|
|
|
1602
|
|
|
|
|
|
|
sub _not_available { |
1603
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
1604
|
|
|
|
|
|
|
|
1605
|
0
|
|
|
|
|
0
|
croak "this operation is not available for ". $self->entity_name; |
1606
|
|
|
|
|
|
|
} |
1607
|
|
|
|
|
|
|
|
1608
|
|
|
|
|
|
|
# |
1609
|
|
|
|
|
|
|
# Shared subtypes |
1610
|
|
|
|
|
|
|
# |
1611
|
|
|
|
|
|
|
BEGIN { |
1612
|
|
|
|
|
|
|
|
1613
|
0
|
0
|
0
|
|
|
0
|
subtype 'HiResDate' |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
1614
|
|
|
|
|
|
|
=> as 'Int' |
1615
|
|
|
|
|
|
|
=> where {m{^-?\d+$} |
1616
|
|
|
|
|
|
|
&& (m{^0+$} || (length($_) > 10 && !m{-}) |
1617
|
|
|
|
|
|
|
or Carp::carp "doesn't look like a hi-res date: $_")} |
1618
|
36
|
|
|
36
|
|
264
|
=> message {"invalid date: $_"}; |
|
0
|
|
|
|
|
0
|
|
1619
|
|
|
|
|
|
|
} |
1620
|
|
|
|
|
|
|
|
1621
|
|
|
|
|
|
|
sub can { |
1622
|
218
|
|
|
218
|
0
|
311
|
my ($class, $method) = @_; |
1623
|
|
|
|
|
|
|
|
1624
|
218
|
|
|
218
|
|
935
|
my $subref = try { $class->SUPER::can($method) }; |
|
218
|
|
|
|
|
5793
|
|
1625
|
|
|
|
|
|
|
|
1626
|
218
|
100
|
|
|
|
2249
|
unless ($subref) { |
1627
|
|
|
|
|
|
|
|
1628
|
112
|
|
|
112
|
|
373
|
my $aliases = try { $class->_aliases }; |
|
112
|
|
|
|
|
1928
|
|
1629
|
|
|
|
|
|
|
|
1630
|
112
|
0
|
33
|
|
|
1623
|
if ($aliases && $aliases->{$method} |
|
|
|
33
|
|
|
|
|
1631
|
|
|
|
|
|
|
&& (my $alias_to = $aliases->{$method}{to})) { |
1632
|
0
|
|
|
|
|
0
|
$subref = $class->SUPER::can($alias_to); |
1633
|
|
|
|
|
|
|
} |
1634
|
|
|
|
|
|
|
} |
1635
|
|
|
|
|
|
|
|
1636
|
218
|
|
|
|
|
468
|
return $subref; |
1637
|
|
|
|
|
|
|
} |
1638
|
|
|
|
|
|
|
|
1639
|
|
|
|
|
|
|
sub AUTOLOAD { |
1640
|
0
|
|
|
0
|
|
0
|
my @class_path = split('::', ${Elive::DAO::AUTOLOAD}); |
1641
|
|
|
|
|
|
|
|
1642
|
0
|
|
|
|
|
0
|
my $method = pop(@class_path); |
1643
|
0
|
|
|
|
|
0
|
my $class = join('::', @class_path); |
1644
|
|
|
|
|
|
|
|
1645
|
0
|
0
|
0
|
|
|
0
|
die "Autoload Dispatch Error: ".${Elive::DAO::AUTOLOAD} |
1646
|
|
|
|
|
|
|
unless $class && $method; |
1647
|
|
|
|
|
|
|
|
1648
|
0
|
0
|
|
|
|
0
|
if (my $subref = $class->can($method)) { |
1649
|
36
|
|
|
36
|
|
12596
|
no strict 'refs'; |
|
36
|
|
|
|
|
62
|
|
|
36
|
|
|
|
|
10246
|
|
1650
|
0
|
|
|
|
|
0
|
*{$class.'::'.$method} = $subref; |
|
0
|
|
|
|
|
0
|
|
1651
|
|
|
|
|
|
|
|
1652
|
0
|
|
|
|
|
0
|
goto $subref; |
1653
|
|
|
|
|
|
|
} |
1654
|
|
|
|
|
|
|
else { |
1655
|
0
|
|
|
|
|
0
|
Carp::croak $class.": unknown method $method"; |
1656
|
|
|
|
|
|
|
} |
1657
|
|
|
|
|
|
|
} |
1658
|
|
|
|
|
|
|
|
1659
|
|
|
|
|
|
|
sub DEMOLISH { |
1660
|
318
|
|
|
318
|
1
|
337
|
my ($self) = shift; |
1661
|
318
|
|
|
|
|
341
|
my $class = ref($self); |
1662
|
|
|
|
|
|
|
|
1663
|
318
|
50
|
0
|
|
|
557
|
warn 'DEMOLISH '.$self->url.': db_data='.($self->_db_data||'(null)')."\n" |
|
|
|
50
|
|
|
|
|
1664
|
|
|
|
|
|
|
if ($self->debug||0) >= 5; |
1665
|
|
|
|
|
|
|
|
1666
|
318
|
50
|
|
|
|
566
|
if (my $db_data = $self->_db_data) { |
1667
|
0
|
0
|
0
|
|
|
|
if (!$REVERTING |
|
|
|
0
|
|
|
|
|
1668
|
|
|
|
|
|
|
&& (my @changed = $self->is_changed) |
1669
|
|
|
|
|
|
|
&& ! $self->_deleted) { |
1670
|
0
|
|
|
|
|
|
my $self_string = Elive::Util::string($self); |
1671
|
0
|
|
|
|
|
|
Carp::carp("$class $self_string destroyed without saving or reverting changes to: " |
1672
|
|
|
|
|
|
|
. join(', ', @changed)); |
1673
|
|
|
|
|
|
|
|
1674
|
0
|
0
|
0
|
|
|
|
warn YAML::Syck::Dump {self => $self, db_data => $db_data} |
1675
|
|
|
|
|
|
|
if ($self->debug||0) >= 6; |
1676
|
|
|
|
|
|
|
} |
1677
|
|
|
|
|
|
|
# |
1678
|
|
|
|
|
|
|
# Destroy this objects data |
1679
|
|
|
|
|
|
|
# |
1680
|
0
|
|
|
|
|
|
$self->_db_data(undef); |
1681
|
|
|
|
|
|
|
} |
1682
|
|
|
|
|
|
|
} |
1683
|
|
|
|
|
|
|
|
1684
|
|
|
|
|
|
|
=head1 ADVANCED |
1685
|
|
|
|
|
|
|
|
1686
|
|
|
|
|
|
|
=head2 Object Management |
1687
|
|
|
|
|
|
|
|
1688
|
|
|
|
|
|
|
L keeps a reference table to all current database objects. This |
1689
|
|
|
|
|
|
|
is primarily used to detect errors, such as destroying or overwriting objects |
1690
|
|
|
|
|
|
|
with unsaved changes. |
1691
|
|
|
|
|
|
|
|
1692
|
|
|
|
|
|
|
You can also reuse objects from this cache by passing C 1> to the |
1693
|
|
|
|
|
|
|
C method. |
1694
|
|
|
|
|
|
|
|
1695
|
|
|
|
|
|
|
my $user = Elive::Entity::User->retrieve(11223344); |
1696
|
|
|
|
|
|
|
# |
1697
|
|
|
|
|
|
|
# returns the same reference, but refetches from the database |
1698
|
|
|
|
|
|
|
# |
1699
|
|
|
|
|
|
|
my $user_copy = Elive::Entity::User->retrieve(11223344); |
1700
|
|
|
|
|
|
|
# |
1701
|
|
|
|
|
|
|
# same as above, however don't refetch if we already have a copy |
1702
|
|
|
|
|
|
|
# |
1703
|
|
|
|
|
|
|
my $user_copy2 = Elive::Entity::User->retrieve(11223344, reuse => 1); |
1704
|
|
|
|
|
|
|
|
1705
|
|
|
|
|
|
|
You can access the in-memory cache using the C and C |
1706
|
|
|
|
|
|
|
methods. |
1707
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
=head2 Entity Manipulation |
1709
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
All objects are simply blessed structures that contain data and nothing else. |
1711
|
|
|
|
|
|
|
You may choose to use the accessors, or work directly with the object data. |
1712
|
|
|
|
|
|
|
|
1713
|
|
|
|
|
|
|
The following are all equivalent, and are all ok: |
1714
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
my $p_list = Elive::Entity::ParticipantList->retrieve(98765); |
1716
|
|
|
|
|
|
|
my $user = Elive::Entity::User->retrieve(11223344); |
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
$p_list->participants->add($user); |
1719
|
|
|
|
|
|
|
push (@{ $p_list->participants }, $user); |
1720
|
|
|
|
|
|
|
push (@{ $p_list->{participants} }, $user); |
1721
|
|
|
|
|
|
|
push (@{ $p_list->get('participants') }, $user); |
1722
|
|
|
|
|
|
|
|
1723
|
|
|
|
|
|
|
=cut |
1724
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
=head1 SEE ALSO |
1726
|
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
|
=over 4 |
1728
|
|
|
|
|
|
|
|
1729
|
|
|
|
|
|
|
=item L (base class) - Middle-weight L like class system |
1730
|
|
|
|
|
|
|
|
1731
|
|
|
|
|
|
|
=back |
1732
|
|
|
|
|
|
|
|
1733
|
|
|
|
|
|
|
=cut |
1734
|
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
|
1; |