ddc11b50bd5120527dfc904cf4c730fb84bd1d1d
[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   my $self = shift;
88   die "Can't call *_related as class methods" unless ref $self;
89   my $rel = shift;
90   my $attrs = { };
91   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
92     $attrs = { %{ pop(@_) } };
93   }
94   my $rel_obj = $self->relationship_info($rel);
95   $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
96   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
97
98   $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
99   my $query = ((@_ > 1) ? {@_} : shift);
100
101   my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self);
102   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
103   #use Data::Dumper; warn Dumper($cond);
104   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
105   return $self->result_source->related_source($rel
106            )->resultset->search($query, $attrs);
107 }
108
109 =head2 count_related
110
111   $obj->count_related('relname', $cond, $attrs);
112
113 =cut
114
115 sub count_related {
116   my $self = shift;
117   return $self->search_related(@_)->count;
118 }
119
120 =head2 create_related
121
122   My::Table->create_related('relname', \%col_data);
123
124 =cut
125
126 sub create_related {
127   my $self = shift;
128   my $rel = shift;
129   return $self->search_related($rel)->create(@_);
130 }
131
132 =head2 new_related
133
134   My::Table->new_related('relname', \%col_data);
135
136 =cut
137
138 sub new_related {
139   my ($self, $rel, $values, $attrs) = @_;
140   return $self->search_related($rel)->new($values, $attrs);
141 }
142
143 =head2 find_related
144
145   My::Table->find_related('relname', @pri_vals | \%pri_vals);
146
147 =cut
148
149 sub find_related {
150   my $self = shift;
151   my $rel = shift;
152   return $self->search_related($rel)->find(@_);
153 }
154
155 =head2 find_or_create_related
156
157   My::Table->find_or_create_related('relname', \%col_data);
158
159 =cut
160
161 sub find_or_create_related {
162   my $self = shift;
163   return $self->find_related(@_) || $self->create_related(@_);
164 }
165
166 =head2 set_from_related
167
168   My::Table->set_from_related('relname', $rel_obj);
169
170 =cut
171
172 sub set_from_related {
173   my ($self, $rel, $f_obj) = @_;
174   my $rel_obj = $self->relationship_info($rel);
175   $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
176   my $cond = $rel_obj->{cond};
177   $self->throw_exception( "set_from_related can only handle a hash condition; the "
178     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
179       unless ref $cond eq 'HASH';
180   my $f_class = $self->result_source->schema->class($rel_obj->{class});
181   $self->throw_exception( "Object $f_obj isn't a ".$f_class )
182     unless $f_obj->isa($f_class);
183   foreach my $key (keys %$cond) {
184     next if ref $cond->{$key}; # Skip literals and complex conditions
185     $self->throw_exception("set_from_related can't handle $key as key")
186       unless $key =~ m/^foreign\.([^\.]+)$/;
187     my $val = $f_obj->get_column($1);
188     $self->throw_exception("set_from_related can't handle ".$cond->{$key}." as value")
189       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
190     $self->set_column($1 => $val);
191   }
192   return 1;
193 }
194
195 =head2 update_from_related
196
197   My::Table->update_from_related('relname', $rel_obj);
198
199 =cut
200
201 sub update_from_related {
202   my $self = shift;
203   $self->set_from_related(@_);
204   $self->update;
205 }
206
207 =head2 delete_related
208
209   My::Table->delete_related('relname', $cond, $attrs);
210
211 =cut
212
213 sub delete_related {
214   my $self = shift;
215   return $self->search_related(@_)->delete;
216 }
217
218 1;
219
220 =head1 AUTHORS
221
222 Matt S. Trout <mst@shadowcatsystems.co.uk>
223
224 =head1 LICENSE
225
226 You may distribute this code under the same terms as Perl itself.
227
228 =cut
229