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