File Coverage

blib/lib/Elive/DAO.pm
Criterion Covered Total %
statement 138 590 23.3
branch 34 306 11.1
condition 22 179 12.2
subroutine 30 62 48.3
pod 25 26 96.1
total 249 1163 21.4


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;