483ee98e5967734875f2e96f8b255a3afc32fa18
[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 =head2 register_relationship($relname, $rel_info)
73
74 Registers a relationship on the class
75
76 =cut
77
78 sub register_relationship { }
79
80 =head2 search_related
81
82   My::Table->search_related('relname', $cond, $attrs);
83
84 =cut
85
86 sub search_related {
87   return shift->related_resultset(shift)->search(@_);
88 }
89
90 =head2 count_related
91
92   $obj->count_related('relname', $cond, $attrs);
93
94 =cut
95
96 sub count_related {
97   my $self = shift;
98   return $self->search_related(@_)->count;
99 }
100
101 =head2 create_related
102
103   My::Table->create_related('relname', \%col_data);
104
105 =cut
106
107 sub create_related {
108   my $self = shift;
109   my $rel = shift;
110   my $obj = $self->search_related($rel)->create(@_);
111   delete $self->{related_resultsets}->{$rel};
112   return $obj;
113 }
114
115 =head2 new_related
116
117   My::Table->new_related('relname', \%col_data);
118
119 =cut
120
121 sub new_related {
122   my ($self, $rel, $values, $attrs) = @_;
123   return $self->search_related($rel)->new($values, $attrs);
124 }
125
126 =head2 find_related
127
128   My::Table->find_related('relname', @pri_vals | \%pri_vals);
129
130 =cut
131
132 sub find_related {
133   my $self = shift;
134   my $rel = shift;
135   return $self->search_related($rel)->find(@_);
136 }
137
138 =head2 find_or_create_related
139
140   My::Table->find_or_create_related('relname', \%col_data);
141
142 =cut
143
144 sub find_or_create_related {
145   my $self = shift;
146   return $self->find_related(@_) || $self->create_related(@_);
147 }
148
149 =head2 set_from_related
150
151   My::Table->set_from_related('relname', $rel_obj);
152
153 =cut
154
155 sub set_from_related {
156   my ($self, $rel, $f_obj) = @_;
157   my $rel_obj = $self->relationship_info($rel);
158   $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
159   my $cond = $rel_obj->{cond};
160   $self->throw_exception( "set_from_related can only handle a hash condition; the "
161     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
162       unless ref $cond eq 'HASH';
163   my $f_class = $self->result_source->schema->class($rel_obj->{class});
164   $self->throw_exception( "Object $f_obj isn't a ".$f_class )
165     unless $f_obj->isa($f_class);
166   $self->set_columns(
167     $self->result_source->resolve_condition(
168        $rel_obj->{cond}, $f_obj, $rel));
169   return 1;
170 }
171
172 =head2 update_from_related
173
174   My::Table->update_from_related('relname', $rel_obj);
175
176 =cut
177
178 sub update_from_related {
179   my $self = shift;
180   $self->set_from_related(@_);
181   $self->update;
182 }
183
184 =head2 delete_related
185
186   My::Table->delete_related('relname', $cond, $attrs);
187
188 =cut
189
190 sub delete_related {
191   my $self = shift;
192   my $obj = $self->search_related(@_)->delete;
193   delete $self->{related_resultsets}->{$_[0]};
194   return $obj;
195 }
196
197 1;
198
199 =head2 related_resultset($name)
200
201 Returns a L<DBIx::Class::ResultSet> for the relationship named $name.
202
203   $rs = My::Table->related_resultset('related_table');
204
205 =cut
206
207 sub related_resultset {
208   my $self = shift;
209   $self->throw_exception("Can't call *_related as class methods") unless ref $self;
210   my $rel = shift;
211   $self->{related_resultsets} ||= {};
212   #use Data::Dumper; warn "related_resultsets: ", Dumper $self->{related_resultsets};
213   my $resultsets = $self->{related_resultsets};
214   if( !exists $resultsets->{$rel} ) {
215
216     #warn "creating related resultset for relation '$rel'", \$self;
217     my $source = $self->result_source;
218     # if relation exists but resultset doesn't, create the resultset
219
220     my $attrs = { };
221     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
222       $attrs = { %{ pop(@_) } };
223     }
224   
225     my $rel_obj = $self->relationship_info($rel);
226     $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
227     $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
228
229     $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
230     my $query = ((@_ > 1) ? {@_} : shift);
231
232     my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self);
233     if (ref $cond eq 'ARRAY') {
234       $cond = [ map { my %hash;
235         foreach my $key (keys %{$_}) {
236           unless ($key =~ m/\./) {
237             $hash{"me.$key"} = $_->{$key};
238           } else {
239            $hash{$key} = $_->{$key};
240           }
241         }; \%hash; } @$cond ];
242       } else {
243       foreach my $key (keys %$cond) {
244         unless ($key =~ m/\./) {
245           $cond->{"me.$key"} = delete $cond->{$key};
246         }
247       }
248     }
249     $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
250     #use Data::Dumper; warn Dumper($cond);
251     #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
252     $resultsets->{$rel} = 
253       $self->result_source->related_source($rel)->resultset->search($query, $attrs);
254   }
255   return $resultsets->{$rel};
256 }
257
258 =head1 AUTHORS
259
260 Matt S. Trout <mst@shadowcatsystems.co.uk>
261
262 =head1 LICENSE
263
264 You may distribute this code under the same terms as Perl itself.
265
266 =cut
267