File Coverage

blib/lib/Class/DBI/Relationship/MightHave.pm
Criterion Covered Total %
statement 46 46 100.0
branch 8 8 100.0
condition 12 12 100.0
subroutine 12 12 100.0
pod 3 3 100.0
total 81 81 100.0


line stmt bran cond sub pod time code
1             package Class::DBI::Relationship::MightHave;
2              
3 24     24   420 use strict;
  24         262  
  24         6051  
4 24     24   625 use warnings;
  24         218  
  24         967  
5              
6 24     24   403 use base 'Class::DBI::Relationship';
  24         222  
  24         386  
7              
8             sub remap_arguments {
9 1     1 1 15 my ($proto, $class, $method, $f_class, @methods) = @_;
10 1         17 $class->_require_class($f_class);
11 1         16 return ($class, $method, $f_class, { import => \@methods });
12             }
13              
14             sub triggers {
15 1     1 1 10 my $self = shift;
16              
17 1         17 my $method = $self->accessor;
18              
19             return (
20             before_update => sub {
21 7 100   7   4937 if (my $for_obj = shift->$method()) { $for_obj->update }
  6         177  
22             },
23              
24             before_delete => sub {
25 3 100   3   954 if (my $for_obj = shift->$method()) { $for_obj->delete }
  2         69  
26             },
27 1         42 );
28             }
29              
30             sub methods {
31 1     1 1 9 my $self = shift;
32 1         12 my ($class, $method) = ($self->class, $self->accessor);
33             return (
34 1         24 $method => $self->_object_accessor,
35 1         39 map { $_ => $self->_imported_accessor($_) } @{ $self->args->{import} }
  1         18  
36             );
37             }
38              
39             sub _object_accessor {
40 1     1   10 my $rel = shift;
41 1         12 my ($class, $method) = ($rel->class, $rel->accessor);
42             return sub {
43 30   100 30   378 my $self = shift;
44 30         660 my $meta = $class->meta_info($rel->name => $method);
45 30         3188 my ($f_class, @extra) =
46 30         374 ($meta->foreign_class, @{ $meta->args->{import} });
47             return
48 30 100 100     3781 if defined($self->{"_${method}_object"})
49             && $self->{"_${method}_object"}
50             ->isa('Class::DBI::Object::Has::Been::Deleted');
51 28   100     396 $self->{"_${method}_object"} ||= $f_class->retrieve($self->id);
52 1         22 };
53             }
54              
55             sub _imported_accessor {
56 1     1   11 my ($rel, $name) = @_;
57 1         13 my ($class, $method) = ($rel->class, $rel->accessor);
58             return sub {
59 14     14   139 my $self = shift;
60 14         186 my $meta = $class->meta_info($rel->name => $method);
61 14         366 my ($f_class, @extra) =
62 14         263 ($meta->foreign_class, @{ $meta->args->{import} });
63 14   100     351 my $for_obj = $self->$method() || do {
64 6 100       85 return unless @_; # just fetching
65 3         30 my $val = shift;
66 3         47 $f_class->insert(
67             { $f_class->primary_column => $self->id, $name => $val });
68 3         85 $self->$method();
69             };
70 11         377 $for_obj->$name(@_);
71 1         28 };
72             }
73              
74             1;
75