File Coverage

blib/lib/Class/DBI/Relationship/HasMany.pm
Criterion Covered Total %
statement 94 102 92.2
branch 33 44 75.0
condition 14 19 73.7
subroutine 15 15 100.0
pod 3 3 100.0
total 159 183 86.9


line stmt bran cond sub pod time code
1             package Class::DBI::Relationship::HasMany;
2              
3 24     24   324 use strict;
  24         261  
  24         344  
4 24     24   367 use warnings;
  24         227  
  24         354  
5              
6 24     24   379 use base 'Class::DBI::Relationship';
  24         239  
  24         368  
7              
8             sub remap_arguments {
9 11     11 1 141 my ($proto, $class, $accessor, $f_class, $f_key, $args) = @_;
10              
11 11 50       128 return $class->_croak($class->name . " needs an accessor name")
12             unless $accessor;
13 11 50       209 return $class->_croak($class->name . " needs a foreign class")
14             unless $f_class;
15              
16             {
17 24     24   443 no strict 'refs';
  24         854  
  24         611  
  11         102  
18 11 50       173 defined &{"$class\::$accessor"}
  11         182  
19             and return $class->_carp("$accessor method already exists in $class\n");
20             }
21              
22 11         107 my @f_method = ();
23 11 100       124 if (ref $f_class eq "ARRAY") {
24 1         15 ($f_class, @f_method) = @$f_class;
25             }
26 11         237 $class->_require_class($f_class);
27              
28 11 100       157 if (ref $f_key eq "HASH") { # didn't supply f_key, this is really $args
29 2         19 $args  = $f_key;
30 2         24 $f_key = "";
31             }
32              
33 11   66     126 $f_key ||= do {
34 7         250 my $meta = $f_class->meta_info('has_a');
35 7         99 my ($col) = grep $meta->{$_}->foreign_class eq $class, keys %$meta;
36 7 100       154 $col || $class->table_alias;
37             };
38              
39 11 50       134 if (ref $f_key eq "ARRAY") {
40 0 0       0 return $class->_croak("Multi-column foreign keys not supported")
41             if @$f_key > 1;
42 0         0 $f_key = $f_key->[0];
43             }
44              
45 11   100     123 $args ||= {};
46 11         118 $args->{mapping}     = \@f_method;
47 11         471 $args->{foreign_key} = $f_key;
48 11   66     129 $args->{order_by} ||= $args->{sort}; # deprecated 0.96
49 11 50       128 warn "sort argument to has_many deprecated in favour of order_by"
50             if $args->{sort}; # deprecated 0.96
51              
52 11         167 return ($class, $accessor, $f_class, $args);
53             }
54              
55             sub _set_up_class_data {
56 11     11   109 my $self = shift;
57 11         186 $self->class->_extend_class_data(
58             __hasa_list => $self->foreign_class => $self->args->{foreign_key});
59 11         776 $self->SUPER::_set_up_class_data;
60             }
61              
62             sub triggers {
63 11     11 1 103 my $self = shift;
64 11 50       155 if ($self->args->{no_cascade_delete}) { # old undocumented way
65 0         0 warn "no_cascade_delete deprecated in favour of cascade => None";
66 0         0 return;
67             }
68 11   100     252 my $strategy = $self->args->{cascade} || "Delete";
69 11 50       334 $strategy = "Class::DBI::Cascade::$strategy" unless $strategy =~ /::/;
70              
71 11         153 $self->foreign_class->_require_class($strategy);
72 11 50       582 $strategy->can('cascade')
73             or return $self->_croak("$strategy is not a valid Cascade Strategy");
74 11         189 my $strat_obj = $strategy->new($self);
75 11     4   265 return (before_delete => sub { $strat_obj->cascade(@_) });
  4         1266  
76             }
77              
78             sub methods {
79 11     11 1 104 my $self = shift;
80 11         162 my $accessor = $self->accessor;
81             return (
82 11         237 $accessor          => $self->_has_many_method,
83             "add_to_$accessor" => $self->_method_add_to,
84             );
85             }
86              
87             sub _method_add_to {
88 11     11   259 my $rel = shift;
89 11         127 my $accessor = $rel->accessor;
90             return sub {
91 9     9   116 my ($self, $data) = @_;
92 9 100       135 my $class = ref $self
93             or return $self->_croak("add_to_$accessor called as class method");
94 8 100       105 return $self->_croak("add_to_$accessor needs data")
95             unless ref $data eq "HASH";
96              
97 7         143 my $meta = $class->meta_info($rel->name => $accessor);
98 7         102 my ($f_class, $f_key, $args) =
99             ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
100 7         109 $data->{$f_key} = $self->id;
101              
102             # See if has_many constraints were defined and auto fill them
103 7 100 66     7239 if (defined $args->{constraint} && ref $args->{constraint} eq 'HASH') {
104 2         21 while (my ($k, $v) = each %{ $args->{constraint} }) {
  3         43  
105 2 100 66     96 $self->_croak(
106             "Can't add_to_$accessor with $k = $data->{$k} (must be $v)")
107             if defined($data->{$k}) && $data->{$k} ne $v;
108 1         12 $data->{$k} = $v;
109             }
110             }
111              
112 6         141 $f_class->insert($data);
113 11         368 };
114             }
115              
116             sub _has_many_method {
117 11     11   103 my $self = shift;
118 11         125 my $run_search = $self->_hm_run_search;
119 11 100       102 my @mapping = @{ $self->args->{mapping} } or return $run_search;
  11         189  
120             return sub {
121 1 50   1   23 return $run_search->(@_)->set_mapping_method(@mapping)
122             unless wantarray;
123 0         0 my @ret = $run_search->(@_);
124 0         0 foreach my $meth (@mapping) { @ret = map $_->$meth(), @ret }
  0         0  
125 0         0 return @ret;
126             }
127 1         32 }
128              
129             sub _hm_run_search {
130 11     11   221 my $rel = shift;
131 11         134 my ($class, $accessor) = ($rel->class, $rel->accessor);
132             return sub {
133 25     25   497 my ($self, @search_args) = @_;
134 25 100       298 @search_args = %{ $search_args[0] } if ref $search_args[0] eq "HASH";
  1         15  
135 25         425 my $meta = $class->meta_info($rel->name => $accessor);
136 25         340 my ($f_class, $f_key, $args) =
137             ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
138 25 100       331 if (ref $self) { # For $artist->cds
139 22 100 66     271 unshift @search_args, %{ $args->{constraint} }
  1         14  
140             if defined($args->{constraint}) && ref $args->{constraint} eq 'HASH';
141 22         299 unshift @search_args, ($f_key => $self->id);
142 22 100       292 push @search_args, { order_by => $args->{order_by} }
143             if defined $args->{order_by};
144 22         459 return $f_class->search(@search_args);
145             } else { # For Artist->cds
146             # Cross-table join as class method
147             # This stuff is highly experimental and will probably change beyond
148             # recognition. Use at your own risk...
149 3         37 my %kv = @search_args;
150 3         51 my $query = Class::DBI::Query->new({ owner => $f_class });
151 3         51 $query->kings($class, $f_class);
152 3         49 $query->add_restriction(sprintf "%s.%s = %s.%s",
153             $f_class->table_alias, $f_key, $class->table_alias,
154             $class->primary_column);
155 3         29 $query->add_restriction("$_ = ?") for keys %kv;
  3         52  
156 3         44 my $sth = $query->run(values %kv);
157 3         47 return $f_class->sth_to_objects($sth);
158             }
159 11         259 };
160             }
161              
162             1;
163