pass through $attrs to add_relationship when $cond is undefined
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Relationship / Base.pm
1 package DBIx::Class::Relationship::Base;
2
3 use strict;
4 use warnings;
5
6 use base qw/Class::Data::Inheritable/;
7
8 __PACKAGE__->mk_classdata('_relationships', { } );
9
10 =head1 NAME 
11
12 DBIx::Class::Relationship - Inter-table relationships
13
14 =head1 SYNOPSIS
15
16 =head1 DESCRIPTION
17
18 This class handles relationships between the tables in your database
19 model. It allows your to set up relationships, and to perform joins
20 on searches.
21
22 =head1 METHODS
23
24 =over 4
25
26 =item add_relationship
27
28   __PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
29
30 The condition needs to be an SQL::Abstract-style representation of the
31 join between the tables - for example if you're creating a rel from Foo to Bar
32
33   { 'foreign.foo_id' => 'self.id' }
34
35 will result in a JOIN clause like
36
37   foo me JOIN bar bar ON bar.foo_id = me.id
38
39 =cut
40
41 sub add_relationship {
42   my ($class, $rel, $f_class, $cond, $attrs) = @_;
43   die "Can't create relationship without join condition" unless $cond;
44   $attrs ||= {};
45   eval "use $f_class;";
46   my %rels = %{ $class->_relationships };
47   $rels{$rel} = { class => $f_class,
48                   cond  => $cond,
49                   attrs => $attrs };
50   $class->_relationships(\%rels);
51   #warn %{$f_class->_columns};
52
53   return unless eval { %{$f_class->_columns}; }; # Foreign class not loaded
54   eval { $class->_resolve_join($rel, 'me') };
55
56   if ($@) { # If the resolve failed, back out and re-throw the error
57     delete $rels{$rel}; # 
58     $class->_relationships(\%rels);
59     $class->throw("Error creating relationship $rel: $@");
60   }
61   1;
62 }
63
64 sub _resolve_join {
65   my ($class, $join, $alias) = @_;
66   if (ref $join eq 'ARRAY') {
67     return map { $class->_resolve_join($_, $alias) } @$join;
68   } elsif (ref $join eq 'HASH') {
69     return map { $class->_resolve_join($_, $alias),
70                  $class->_relationships->{$_}{class}->_resolve_join($join->{$_}, $_) }
71            keys %$join;
72   } elsif (ref $join) {
73     $class->throw("No idea how to resolve join reftype ".ref $join);
74   } else {
75     my $rel_obj = $class->_relationships->{$join};
76     $class->throw("No such relationship ${join}") unless $rel_obj;
77     my $j_class = $rel_obj->{class};
78     my %join = (_action => 'join',
79          _aliases => { 'self' => $alias, 'foreign' => $join },
80          _classes => { $alias => $class, $join => $j_class });
81     my $j_cond = $j_class->resolve_condition($rel_obj->{cond}, \%join);
82     return [ { $join => $j_class->_table_name,
83                -join_type => $rel_obj->{attrs}{join_type} || '' }, $j_cond ];
84   }
85 }
86
87 sub resolve_condition {
88   my ($self, $cond, $attrs) = @_;
89   if (ref $cond eq 'HASH') {
90     my %ret;
91     foreach my $key (keys %$cond) {
92       my $val = $cond->{$key};
93       if (ref $val) {
94         $self->throw("Can't handle this yet :(");
95       } else {
96         $ret{$self->_cond_key($attrs => $key)}
97           = $self->_cond_value($attrs => $key => $val);
98       }
99     }
100     return \%ret;
101   } else {
102    $self->throw("Can't handle this yet :(");
103   }
104 }
105
106 sub _cond_key {
107   my ($self, $attrs, $key) = @_;
108   my $action = $attrs->{_action} || '';
109   if ($action eq 'convert') {
110     unless ($key =~ s/^foreign\.//) {
111       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
112     }
113     return $key;
114   } elsif ($action eq 'join') {
115     return $key unless $key =~ /\./;
116     my ($type, $field) = split(/\./, $key);
117     if (my $alias = $attrs->{_aliases}{$type}) {
118       my $class = $attrs->{_classes}{$alias};
119       $self->throw("Unknown column $field on $class as $alias")
120         unless exists $class->_columns->{$field};
121       return join('.', $alias, $field);
122     } else {
123       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
124             join(', ', keys %{$attrs->{_aliases} || {}}) );
125     }
126   }
127   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
128 }
129
130 sub _cond_value {
131   my ($self, $attrs, $key, $value) = @_;
132   my $action = $attrs->{_action} || '';
133   if ($action eq 'convert') {
134     unless ($value =~ s/^self\.//) {
135       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
136     }
137     unless ($self->_columns->{$value}) {
138       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
139     }
140     return $self->get_column($value);
141   } elsif ($action eq 'join') {
142     return $key unless $key =~ /\./;
143     my ($type, $field) = split(/\./, $value);
144     if (my $alias = $attrs->{_aliases}{$type}) {
145       my $class = $attrs->{_classes}{$alias};
146       $self->throw("Unknown column $field on $class as $alias")
147         unless exists $class->_columns->{$field};
148       return join('.', $alias, $field);
149     } else {
150       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
151             join(', ', keys %{$attrs->{_aliases} || {}}) );
152     }
153   }
154       
155   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
156 }
157
158 =item search_related
159
160   My::Table->search_related('relname', $cond, $attrs);
161
162 =cut
163
164 sub search_related {
165   my $self = shift;
166   return $self->_query_related('search', @_);
167 }
168
169 =item count_related
170
171   My::Table->count_related('relname', $cond, $attrs);
172
173 =cut
174
175 sub count_related {
176   my $self = shift;
177   return $self->_query_related('count', @_);
178 }
179
180 sub _query_related {
181   my $self = shift;
182   my $meth = shift;
183   my $rel = shift;
184   my $attrs = { };
185   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
186     $attrs = { %{ pop(@_) } };
187   }
188   my $rel_obj = $self->_relationships->{$rel};
189   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
190   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
191
192   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
193   my $query = ((@_ > 1) ? {@_} : shift);
194
195   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
196                                  # to merge into the AST really?
197   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
198   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
199   #use Data::Dumper; warn Dumper($query);
200   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
201   delete $attrs->{_action};
202   return $self->resolve_class($rel_obj->{class}
203            )->$meth($query, $attrs);
204 }
205
206 =item create_related
207
208   My::Table->create_related('relname', \%col_data);
209
210 =cut
211
212 sub create_related {
213   my $class = shift;
214   return $class->new_related(@_)->insert;
215 }
216
217 =item new_related
218
219   My::Table->new_related('relname', \%col_data);
220
221 =cut
222
223 sub new_related {
224   my ($self, $rel, $values, $attrs) = @_;
225   $self->throw( "Can't call new_related as class method" ) 
226     unless ref $self;
227   $self->throw( "new_related needs a hash" ) 
228     unless (ref $values eq 'HASH');
229   my $rel_obj = $self->_relationships->{$rel};
230   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
231   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
232     unless ref $rel_obj->{cond} eq 'HASH';
233   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
234
235   my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
236   $fields{$_} = $values->{$_} for keys %$values;
237
238   return $self->resolve_class($rel_obj->{class})->new(\%fields);
239 }
240
241 =item find_related
242
243   My::Table->find_related('relname', @pri_vals | \%pri_vals);
244
245 =cut
246
247 sub find_related {
248   my $self = shift;
249   my $rel = shift;
250   my $rel_obj = $self->_relationships->{$rel};
251   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
252   my ($cond) = $self->resolve_condition($rel_obj->{cond}, { _action => 'convert' });
253   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
254   my $attrs = { };
255   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
256     $attrs = { %{ pop(@_) } };
257   }
258   my $query = ((@_ > 1) ? {@_} : shift);
259   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
260   return $self->resolve_class($rel_obj->{class})->find($query);
261 }
262
263 =item find_or_create_related
264
265   My::Table->find_or_create_related('relname', \%col_data);
266
267 =cut
268
269 sub find_or_create_related {
270   my $self = shift;
271   return $self->find_related(@_) || $self->create_related(@_);
272 }
273
274 =item set_from_related
275
276   My::Table->set_from_related('relname', $rel_obj);
277
278 =cut
279
280 sub set_from_related {
281   my ($self, $rel, $f_obj) = @_;
282   my $rel_obj = $self->_relationships->{$rel};
283   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
284   my $cond = $rel_obj->{cond};
285   $self->throw( "set_from_related can only handle a hash condition; the "
286     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
287       unless ref $cond eq 'HASH';
288   my $f_class = $self->resolve_class($rel_obj->{class});
289   $self->throw( "Object $f_obj isn't a ".$f_class )
290     unless $f_obj->isa($f_class);
291   foreach my $key (keys %$cond) {
292     next if ref $cond->{$key}; # Skip literals and complex conditions
293     $self->throw("set_from_related can't handle $key as key")
294       unless $key =~ m/^foreign\.([^\.]+)$/;
295     my $val = $f_obj->get_column($1);
296     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
297       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
298     $self->set_column($1 => $val);
299   }
300   return 1;
301 }
302
303 =item update_from_related
304
305   My::Table->update_from_related('relname', $rel_obj);
306
307 =cut
308
309 sub update_from_related {
310   my $self = shift;
311   $self->set_from_related(@_);
312   $self->update;
313 }
314
315 =item delete_related
316
317   My::Table->delete_related('relname', $cond, $attrs);
318
319 =cut
320
321 sub delete_related {
322   my $self = shift;
323   return $self->search_related(@_)->delete;
324 }
325
326 1;
327
328 =back
329
330 =head1 AUTHORS
331
332 Matt S. Trout <mst@shadowcatsystems.co.uk>
333
334 =head1 LICENSE
335
336 You may distribute this code under the same terms as Perl itself.
337
338 =cut
339