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