File Coverage

blib/lib/ObjectDB.pm
Criterion Covered Total %
statement 81 334 24.2
branch 22 180 12.2
condition 10 44 22.7
subroutine 18 47 38.3
pod 24 31 77.4
total 155 636 24.3


line stmt bran cond sub pod time code
1             package ObjectDB;
2              
3 5     5   280745 use strict;
  5         40  
  5         137  
4 5     5   25 use warnings;
  5         9  
  5         110  
5 5     5   27 use mro;
  5         9  
  5         34  
6              
7             require Carp;
8 5     5   154 use Scalar::Util ();
  5         18  
  5         114  
9 5     5   2296 use SQL::Composer;
  5         66166  
  5         243  
10 5     5   2152 use ObjectDB::DBHPool;
  5         17  
  5         162  
11 5     5   2591 use ObjectDB::Meta;
  5         18  
  5         155  
12 5     5   2076 use ObjectDB::Quoter;
  5         12  
  5         135  
13 5     5   1994 use ObjectDB::RelatedFactory;
  5         11  
  5         129  
14 5     5   2174 use ObjectDB::Table;
  5         13  
  5         150  
15 5     5   29 use ObjectDB::With;
  5         9  
  5         121  
16 5     5   25 use ObjectDB::Util qw(execute filter_columns);
  5         39  
  5         1642  
17              
18             our $VERSION = '3.28';
19              
20             $Carp::Internal{ (__PACKAGE__) }++;
21             $Carp::Internal{"ObjectDB::$_"}++ for qw/
22             With
23             Related
24             Related::ManyToOne
25             Related::OneToOne
26             Related::ManyToMany
27             Related::OneToMany
28             Meta::Relationship
29             Meta::Relationship::ManyToOne
30             Meta::Relationship::OneToOne
31             Meta::Relationship::ManyToMany
32             Meta::Relationship::OneToMany
33             Meta::RelationshipFactory
34             Table
35             Util
36             Quoter
37             DBHPool
38             Meta
39             RelationshipFactory
40             /;
41              
42             sub new {
43 8     8 0 18082 my $class = shift;
44 8 50       22 $class = ref $class if ref $class;
45 8         19 my (%columns) = @_;
46              
47 8         13 my $self = {};
48 8         17 bless $self, $class;
49              
50 8         17 foreach my $column (keys %columns) {
51 4 100 66     14 if ( $self->meta->is_column($column)
52             || $self->meta->is_relationship($column))
53             {
54 3         11 $self->set_column($column => $columns{$column});
55             }
56             }
57              
58 8         18 $self->{is_in_db} = 0;
59 8         14 $self->{is_modified} = 0;
60              
61 8         20 return $self;
62             }
63              
64             sub is_in_db {
65 0     0 1 0 my $self = shift;
66              
67 0 0       0 if (@_) {
68 0         0 $self->{is_in_db} = $_[0];
69 0         0 return $self;
70             }
71              
72 0         0 return $self->{is_in_db};
73             }
74              
75             sub is_modified {
76 0     0 1 0 my $self = shift;
77              
78 0         0 return $self->{is_modified};
79             }
80              
81 0     0 0 0 sub dbh { &init_db }
82              
83             sub init_db {
84 0     0 1 0 my $self = shift;
85              
86 5     5   40 no strict;
  5         9  
  5         17215  
87              
88 0 0       0 my $class = ref($self) ? ref($self) : $self;
89              
90 0         0 my $dbh;
91 0 0       0 if (@_) {
92 0 0 0     0 if (@_ == 1 && ref $_[0]) {
93 0         0 ${"$class\::DBH"} = shift;
  0         0  
94             }
95             else {
96 0         0 ${"$class\::DBH"} = ObjectDB::DBHPool->new(@_);
  0         0  
97             }
98              
99 0         0 $dbh = ${"$class\::DBH"};
  0         0  
100             }
101             else {
102 0         0 $dbh = ${"$class\::DBH"};
  0         0  
103              
104 0 0       0 if (!$dbh) {
105 0         0 my $parents = mro::get_linear_isa($class);
106 0         0 foreach my $parent (@$parents) {
107 0 0       0 if ($dbh = ${"$parent\::DBH"}) {
  0         0  
108 0         0 last;
109             }
110             }
111             }
112              
113 0 0       0 Carp::croak('Setup a dbh first') unless $dbh;
114             }
115              
116 0 0       0 return $dbh->isa('ObjectDB::DBHPool')
117             ? $dbh->dbh
118             : $dbh;
119             }
120              
121             sub txn {
122 0     0 1 0 my $self = shift;
123 0         0 my ($cb) = @_;
124              
125 0         0 my $dbh = $self->init_db;
126              
127 0         0 my $retval;
128             eval {
129 0         0 $dbh->{AutoCommit} = 0;
130              
131 0         0 $retval = $cb->($self);
132              
133 0         0 $self->commit;
134 0 0       0 } || do {
135 0         0 my $e = $@;
136              
137 0         0 $self->rollback;
138              
139 0         0 Carp::croak($e);
140             };
141              
142 0         0 return $retval;
143             }
144              
145             sub commit {
146 0     0 1 0 my $self = shift;
147              
148 0         0 my $dbh = $self->init_db;
149              
150 0 0       0 if ($dbh->{AutoCommit} == 0) {
151 0         0 $dbh->commit;
152 0         0 $dbh->{AutoCommit} = 1;
153             }
154              
155 0         0 return $self;
156             }
157              
158             sub rollback {
159 0     0 1 0 my $self = shift;
160              
161 0         0 my $dbh = $self->init_db;
162              
163 0 0       0 if ($dbh->{AutoCommit} == 0) {
164 0         0 $dbh->rollback;
165 0         0 $dbh->{AutoCommit} = 1;
166             }
167              
168 0         0 return $self;
169             }
170              
171             sub meta {
172 42     42 1 9354 my $class = shift;
173 42 100       91 $class = ref $class if ref $class;
174              
175 42         109 return ObjectDB::Meta->find_or_register_meta($class, @_);
176             }
177              
178             sub table {
179 0     0 0 0 my $self = shift;
180 0 0       0 my $class = ref $self ? ref $self : $self;
181              
182 0         0 return ObjectDB::Table->new(class => $class, dbh => $self->init_db);
183             }
184              
185             sub columns {
186 0     0 1 0 my $self = shift;
187              
188 0         0 my @columns;
189 0         0 foreach my $key ($self->meta->columns) {
190 0 0       0 if (exists $self->{columns}->{$key}) {
191 0         0 push @columns, $key;
192             }
193             }
194              
195 0         0 return @columns;
196             }
197              
198             sub column {
199 0     0 1 0 my $self = shift;
200              
201 0   0     0 $self->{columns} ||= {};
202              
203 0 0       0 if (@_ == 1) {
    0          
204 0         0 return $self->get_column(@_);
205             }
206             elsif (@_ == 2) {
207 0         0 $self->set_column(@_);
208             }
209              
210 0         0 return $self;
211             }
212              
213             sub get_column {
214 8     8 1 47 my $self = shift;
215 8         13 my ($name) = @_;
216              
217 8 100       16 if ($self->meta->is_column($name)) {
    50          
218 6         8 my $value;
219              
220 6 100       14 if (exists $self->{columns}->{$name}) {
221 3         7 $value = $self->{columns}->{$name};
222             }
223             else {
224 3 100       6 if (exists $self->meta->get_column($name)->{default}) {
225 1         3 my $default = $self->meta->get_column($name)->{default};
226 1 50       5 $value = ref $default eq 'CODE' ? $default->() : $default;
227             }
228             }
229              
230 6 100 66     25 if (defined $value && $value ne '') {
231 4 50       9 if (my $type = $self->meta->get_column($name)->{type}) {
232 0 0       0 if ($type eq 'number') {
    0          
233 0         0 $value += 0;
234             }
235             elsif ($type eq 'string') {
236 0         0 $value .= '';
237             }
238             }
239             }
240              
241 6         37 return $value;
242             }
243             elsif ($self->meta->is_relationship($name)) {
244             return exists $self->{relationships}->{$name}
245 0 0       0 ? $self->{relationships}->{$name}
246             : undef;
247             }
248             else {
249 2         20 return $self->{virtual_columns}->{$name};
250             }
251             }
252              
253             sub set_columns {
254 1     1 1 10 my $self = shift;
255 1 50       5 my %values = ref $_[0] ? %{ $_[0] } : @_;
  0         0  
256              
257 1         6 while (my ($key, $value) = each %values) {
258 1         3 $self->set_column($key => $value);
259             }
260              
261 1         3 return $self;
262             }
263              
264             sub set_column {
265 7     7 1 19 my $self = shift;
266 7         14 my ($name, $value) = @_;
267              
268 7 100       14 if ($self->meta->is_column($name)) {
    50          
269 6 50 66     37 if ( !defined $value
270             && !$self->meta->is_nullable($name) )
271             {
272 2         8 return $self;
273             }
274              
275 4 50 33     26 if ( !exists $self->{columns}->{$name}
      33        
      66        
276             || !((defined $self->{columns}->{$name} && defined $value) && ($self->{columns}->{$name} eq $value)))
277             {
278 4         7 $self->{columns}->{$name} = $value;
279 4         9 $self->{is_modified} = 1;
280             }
281             }
282             elsif ($self->meta->is_relationship($name)) {
283 0         0 my $related_value;
284 0 0       0 if (Scalar::Util::blessed($value)) {
    0          
    0          
285 0         0 $related_value = $value;
286             }
287             elsif (ref $value eq 'ARRAY') {
288 0         0 $related_value = [];
289 0         0 foreach my $sub_value (@$value) {
290 0 0 0     0 next unless defined $sub_value && ref $sub_value;
291              
292 0 0       0 Carp::croak(qq{Value of related object(s) '$name' has to be a reference}) unless ref $sub_value;
293              
294 0 0       0 if (Scalar::Util::blessed($sub_value)) {
    0          
295 0         0 push @$related_value, $sub_value;
296             }
297             elsif (ref($sub_value) eq 'HASH') {
298 0 0       0 if (!$self->_is_empty_hash_ref($sub_value)) {
299 0         0 push @$related_value, $self->meta->get_relationship($name)->class->new(%$sub_value);
300             }
301             }
302             else {
303 0         0 Carp::croak(qq{Unexpected reference found } . qq{when setting '$name' related object});
304             }
305             }
306              
307 0 0       0 undef $related_value unless @$related_value;
308             }
309             elsif (!$self->_is_empty_hash_ref($value)) {
310 0         0 $related_value = $self->meta->get_relationship($name)->class->new(%$value);
311             }
312              
313 0 0       0 if ($related_value) {
314 0 0 0     0 if ($self->meta->get_relationship($name)->is_multi
315             && ref($related_value) ne 'ARRAY')
316             {
317 0         0 $related_value = [$related_value];
318             }
319              
320 0         0 $self->{relationships}->{$name} = $related_value;
321             }
322             }
323             else {
324 1         3 $self->{virtual_columns}->{$name} = $value;
325             }
326              
327 5         22 return $self;
328             }
329              
330             sub clone {
331 0     0 1   my $self = shift;
332              
333 0           my %columns;
334 0           foreach my $column ($self->meta->columns) {
335             next
336 0 0 0       if $self->meta->is_primary_key($column)
337             || $self->meta->is_unique_key($column);
338 0           $columns{$column} = $self->column($column);
339             }
340              
341 0           return (ref $self)->new->set_columns(%columns);
342             }
343              
344             sub create {
345 0     0 1   my $self = shift;
346              
347 0 0         Carp::croak(q{Calling 'create' on already created object})
348             if $self->is_in_db;
349              
350 0           my $dbh = $self->init_db;
351              
352             my $sql = SQL::Composer->build(
353             'insert',
354             driver => $dbh->{Driver}->{Name},
355             into => $self->meta->table,
356 0           values => [ map { $_ => $self->{columns}->{$_} } $self->columns ]
  0            
357             );
358              
359 0           my $rv = execute($dbh, $sql);
360              
361 0 0         if (my $auto_increment = $self->meta->auto_increment) {
362 0           $self->set_column(
363             $auto_increment => $dbh->last_insert_id(undef, undef, $self->meta->table, $auto_increment));
364             }
365              
366 0           $self->{is_in_db} = 1;
367 0           $self->{is_modified} = 0;
368              
369 0           foreach my $rel_name (keys %{ $self->meta->relationships }) {
  0            
370 0 0         if (my $rel_values = $self->{relationships}->{$rel_name}) {
371 0 0         if (ref $rel_values eq 'ARRAY') {
372 0           @$rel_values = grep { !$_->is_in_db } @$rel_values;
  0            
373 0 0         next unless @$rel_values;
374             }
375             else {
376 0 0         next if $rel_values->is_in_db;
377             }
378              
379 0           my $rel = $self->meta->get_relationship($rel_name);
380 0           my @related = $self->create_related($rel_name, $rel_values);
381              
382 0 0         $self->{relationships}->{$rel_name} =
383             $rel->is_multi ? \@related : $related[0];
384             }
385             }
386              
387 0           return $self;
388             }
389              
390             sub save {
391 0     0 0   my $self = shift;
392              
393 0 0         if ($self->is_in_db) {
394 0           return $self->update;
395             }
396             else {
397 0           return $self->create;
398             }
399             }
400              
401 0     0 0   sub find { shift->table->find(@_) }
402              
403             sub load {
404 0     0 1   my $self = shift;
405 0           my (%params) = @_;
406              
407 0           my @columns;
408              
409 0           foreach my $name ($self->columns) {
410 0 0         push @columns, $name if $self->meta->is_primary_key($name);
411             }
412              
413 0 0         if (!@columns) {
414 0           foreach my $name ($self->columns) {
415 0 0         push @columns, $name if $self->meta->is_unique_key($name);
416             }
417             }
418              
419 0 0         Carp::croak(ref($self) . ': no primary or unique keys specified')
420             unless @columns;
421              
422 0           my $where = [ map { $_ => $self->{columns}->{$_} } @columns ];
  0            
423              
424 0           my $with = ObjectDB::With->new(meta => $self->meta, with => $params{with});
425              
426 0           my $columns = filter_columns([ $self->meta->get_columns ], \%params);
427              
428             my $select = SQL::Composer->build(
429             'select',
430             driver => $self->init_db->{Driver}->{Name},
431             columns => $columns,
432             from => $self->meta->table,
433             where => $where,
434             join => $with->to_joins,
435             for_update => $params{for_update},
436 0           );
437              
438 0           my ($rv, $sth) = execute($self->init_db, $select);
439              
440 0           my $rows = $sth->fetchall_arrayref;
441 0 0 0       return unless $rows && @$rows;
442              
443 0           my $row_object = $select->from_rows($rows)->[0];
444              
445 0           $self->{columns} = {};
446 0           $self->{relationships} = {};
447              
448 0           $self->set_columns(%$row_object);
449              
450 0           $self->{is_modified} = 0;
451 0           $self->{is_in_db} = 1;
452              
453 0           return $self;
454             }
455              
456             sub load_or_create {
457 0     0 0   my $self = shift;
458              
459 0           my @columns;
460 0           foreach my $name ($self->columns) {
461 0 0         push @columns, $name if $self->meta->is_primary_key($name);
462             }
463              
464 0 0         if (!@columns) {
465 0           foreach my $name ($self->columns) {
466 0 0         push @columns, $name if $self->meta->is_unique_key($name);
467             }
468             }
469              
470 0           my $object;
471 0 0         $object = $self->load if @columns;
472 0   0       $object ||= $self->create;
473              
474 0           return $object;
475             }
476              
477             sub update {
478 0     0 1   my $self = shift;
479              
480 0 0         return $self unless $self->is_modified;
481              
482 0           my %where;
483 0           foreach my $name ($self->columns) {
484 0 0         $where{$name} = $self->{columns}->{$name}
485             if $self->meta->is_primary_key($name);
486             }
487              
488 0 0         if (!keys %where) {
489 0           foreach my $name ($self->columns) {
490 0 0         $where{$name} = $self->{columns}->{$name}
491             if $self->meta->is_unique_key($name);
492             }
493             }
494              
495 0 0         Carp::croak(ref($self) . ': no primary or unique keys specified')
496             unless keys %where;
497              
498 0           my @columns = grep { !$self->meta->is_primary_key($_) } $self->columns;
  0            
499 0           my @values = map { $self->{columns}->{$_} } @columns;
  0            
500              
501 0           my %columns_set;
502 0           @columns_set{@columns} = @values;
503             my $sql = SQL::Composer->build(
504             'update',
505             driver => $self->init_db->{Driver}->{Name},
506 0           table => $self->meta->table,
507             values => [%columns_set],
508             where => [%where]
509             );
510              
511 0           my $rv = execute($self->init_db, $sql);
512              
513 0 0         Carp::croak('No rows were affected') if $rv eq '0E0';
514              
515 0           $self->{is_modified} = 0;
516 0           $self->{is_in_db} = 1;
517              
518 0           return $self;
519             }
520              
521             sub delete : method {
522 0     0 1   my $self = shift;
523              
524 0           my %where;
525 0           foreach my $name ($self->columns) {
526 0 0         $where{$name} = $self->{columns}->{$name}
527             if $self->meta->is_primary_key($name);
528             }
529              
530 0 0         if (!keys %where) {
531 0           foreach my $name ($self->columns) {
532 0 0         $where{$name} = $self->{columns}->{$name}
533             if $self->meta->is_unique_key($name);
534             }
535             }
536              
537 0 0         Carp::croak(ref($self) . ': no primary or unique keys specified')
538             unless keys %where;
539              
540             my $sql = SQL::Composer->build(
541             'delete',
542             driver => $self->init_db->{Driver}->{Name},
543 0           from => $self->meta->table,
544             where => [%where]
545             );
546              
547 0           my $rv = execute($self->init_db, $sql);
548              
549 0 0         Carp::croak('No rows were affected') if $rv eq '0E0';
550              
551 0           %$self = ();
552              
553 0           return $self;
554             }
555              
556             sub to_hash {
557 0     0 1   my $self = shift;
558              
559 0           my $hash = {};
560              
561 0           foreach my $key ($self->meta->get_columns) {
562 0 0         if (exists $self->{columns}->{$key}) {
    0          
563 0           $hash->{$key} = $self->get_column($key);
564             }
565             elsif (exists $self->meta->get_column($key)->{default}) {
566 0           $hash->{$key} = $self->get_column($key);
567             }
568             }
569              
570 0           foreach my $key (keys %{ $self->{virtual_columns} }) {
  0            
571 0           $hash->{$key} = $self->get_column($key);
572             }
573              
574 0           foreach my $name (keys %{ $self->{relationships} }) {
  0            
575 0           my $rel = $self->{relationships}->{$name};
576 0 0         next unless defined $rel;
577              
578 0 0         Carp::croak("unknown '$name' relationship") unless $rel;
579              
580 0 0         if (ref $rel eq 'ARRAY') {
581 0           $hash->{$name} = [ map { $_->to_hash } @$rel ];
  0            
582             }
583             else {
584 0           $hash->{$name} = $rel->to_hash;
585             }
586             }
587              
588 0           return $hash;
589             }
590              
591             sub is_related_loaded {
592 0     0 1   my $self = shift;
593 0           my ($name) = @_;
594              
595 0           return exists $self->{relationships}->{$name};
596             }
597              
598             sub related {
599 0     0 1   my $self = shift;
600 0           my ($name) = shift;
601              
602 0           my $rel = $self->meta->get_relationship($name);
603              
604 0 0         if (!$self->{relationships}->{$name}) {
605 0 0         $self->{relationships}->{$name} =
606             $rel->is_multi
607             ? [ $self->find_related($name, @_) ]
608             : $self->find_related($name, @_);
609             }
610              
611 0           my $related = $self->{relationships}->{$name};
612              
613             return
614             wantarray
615 0 0         ? ref $related eq 'ARRAY'
    0          
616             ? @$related
617             : ($related)
618             : $related;
619             }
620              
621 0     0 1   sub find_related { shift->_do_related('find', @_) }
622 0     0 1   sub update_related { shift->_do_related('update', @_) }
623 0     0 0   sub count_related { shift->_do_related('count', @_) }
624 0     0 1   sub delete_related { shift->_do_related('delete', @_) }
625              
626             sub create_related {
627 0     0 1   my $self = shift;
628 0           my $name = shift;
629              
630 0 0         my @related = @_ == 1 ? ref $_[0] eq 'ARRAY' ? @{ $_[0] } : ($_[0]) : ({@_});
  0 0          
631              
632 0           my @rv = $self->_do_related('create', $name, \@related);
633 0 0         return @rv == 1 ? $rv[0] : @rv;
634             }
635              
636             sub _do_related {
637 0     0     my $self = shift;
638 0           my $action = shift;
639 0           my $name = shift;
640              
641 0 0         Carp::croak('Relationship name is required') unless $name;
642              
643 0           my $related = $self->_build_related($name);
644              
645 0           my $method = "$action\_related";
646 0           return $related->$method($self, @_);
647             }
648              
649             sub _build_related {
650 0     0     my $self = shift;
651 0           my ($name) = @_;
652              
653 0           my $meta = $self->meta->get_relationship($name);
654              
655 0           return ObjectDB::RelatedFactory->new->build($meta->type, meta => $meta);
656             }
657              
658             sub _is_empty_hash_ref {
659 0     0     my $self = shift;
660 0           my ($hash_ref) = @_;
661              
662 0 0 0       return 1 unless defined $hash_ref && ref $hash_ref eq 'HASH';
663              
664 0           foreach my $key (keys %$hash_ref) {
665 0 0 0       if (defined $hash_ref->{$key} && $hash_ref->{$key} ne '') {
666 0 0         if (ref($hash_ref->{$key}) eq 'HASH') {
667 0           my $is_empty = $self->_is_empty_hash_ref($hash_ref->{$key});
668 0 0         return 0 unless $is_empty;
669             }
670             else {
671 0           return 0;
672             }
673             }
674             }
675              
676 0           return 1;
677             }
678              
679             1;
680             __END__