File Coverage

blib/lib/Class/DBI/Relationship/HasA.pm
Criterion Covered Total %
statement 50 51 98.0
branch 25 30 83.3
condition 9 12 75.0
subroutine 10 10 100.0
pod 2 2 100.0
total 96 105 91.4


line stmt bran cond sub pod time code
1             package Class::DBI::Relationship::HasA;
2              
3 24     24   417 use strict;
  24         660  
  24         609  
4 24     24   785 use warnings;
  24         531  
  24         379  
5              
6 24     24   460 use base 'Class::DBI::Relationship';
  24         221  
  24         376  
7              
8             sub remap_arguments {
9 21     21 1 255 my ($proto, $class, $want_col, $a_class, %meths) = @_;
10 21 100       244 $class->_invalid_object_method("has_a") if ref $class;
11 20 100       330 my $column = $class->find_column($want_col)
12             or return $class->_croak("Column $want_col does not exist in $class");
13 19 100       479 $class->_croak("$class $column needs an associated class") unless $a_class;
14 18         354 return ($class, $column, $a_class, \%meths);
15             }
16              
17             sub triggers {
18 18     18 1 225 my $self = shift;
19 18         254 $self->class->_require_class($self->foreign_class);
20 18         379 my $column = $self->accessor;
21             return (
22 18         418 select => $self->_inflator,
23              
24             # after_create => $self->_inflator, # see t/6
25             "after_set_$column" => $self->_inflator,
26             deflate_for_create  => $self->_deflator(1),
27             deflate_for_update  => $self->_deflator,
28             );
29             }
30              
31             sub _inflator {
32 36     36   635 my $rel = shift;
33 36         408 my $col = $rel->accessor;
34             return sub {
35 165     165   88737 my $self = shift;
36 165 100       15973 defined(my $value = $self->_attrs($col)) or return;
37 54         1601 my $meta = $self->meta_info($rel->name => $col);
38 54         8862 my ($a_class, %meths) = ($meta->foreign_class, %{ $meta->args });
  54         1790  
39              
40 54 100 100     1719 return if ref $value and $value->isa($a_class);
41 39         1038 my $inflator;
42              
43             my $get_new_value = sub {
44 41         419 my ($inflator, $value, $want_class, $obj) = @_;
45 41 100       680 my $new_value =
46             (ref $inflator eq 'CODE')
47             ? $inflator->($value, $obj)
48             : $want_class->$inflator($value);
49 41         2074 return $new_value;
50 39         1487 };
51              
52             # If we have a custom inflate ...
53 39 100       431 if (exists $meths{'inflate'}) {
54 5         58 $value = $get_new_value->($meths{'inflate'}, $value, $a_class, $self);
55 5 100 66     99 return $self->_attribute_store($col, $value)
56             if ref $value
57             and $value->isa($a_class);
58 3 50       32 $self->_croak("Inflate method didn't inflate right") if ref $value;
59             }
60              
61 37 100       379 return $self->_croak("Can't inflate $col to $a_class using '$value': "
62             . ref($value)
63             . " is not a $a_class")
64             if ref $value;
65              
66 36 50       2579 $inflator = $a_class->isa('Class::DBI') ? "_simple_bless" : "new";
67 36         378 $value = $get_new_value->($inflator, $value, $a_class);
68              
69 36 50 33     3999 return $self->_attribute_store($col, $value)
70             if ref $value
71             and $value->isa($a_class);
72              
73             # use ref as $obj may be overloaded and appear 'false'
74 0 0       0 return $self->_croak(
75             "Can't inflate $col to $a_class " . "via $inflator using '$value'")
76             unless ref $value;
77 36         2065 };
78             }
79              
80             sub _deflator {
81 36     36   418 my ($self, $always) = @_;
82 36         743 my $col = $self->accessor;
83             return sub {
84 45     45   16973 my $self = shift;
85 45 100       1417 return unless $self->_attribute_exists($col);
86 44 100 100     2266 $self->_attribute_store($col => $self->_deflated_column($col))
87             if ($always or $self->{__Changed}->{$col});
88 36         1322 };
89             }
90              
91             sub _set_up_class_data {
92 18     18   172 my $self = shift;
93 18         10151 $self->class->_extend_class_data(__hasa_rels => $self->accessor =>
94 18         329 [ $self->foreign_class, %{ $self->args } ]);
95 18         577 $self->SUPER::_set_up_class_data;
96             }
97              
98             1;
99