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