Pod formatting cleanup in Cookbook
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Relationship / Base.pm
CommitLineData
55e2d745 1package DBIx::Class::Relationship::Base;
2
3use strict;
4use warnings;
5
1edd1722 6use base qw/DBIx::Class/;
55e2d745 7
8__PACKAGE__->mk_classdata('_relationships', { } );
9
10=head1 NAME
11
8918977e 12DBIx::Class::Relationship::Base - Inter-table relationships
55e2d745 13
14=head1 SYNOPSIS
15
16=head1 DESCRIPTION
17
18This class handles relationships between the tables in your database
19model. It allows your to set up relationships, and to perform joins
20on searches.
21
22=head1 METHODS
23
8091aa91 24=head2 add_relationship
503536d5 25
26 __PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
27
28The condition needs to be an SQL::Abstract-style representation of the
8091aa91 29join between the tables. For example, if you're creating a rel from Foo to Bar,
503536d5 30
31 { 'foreign.foo_id' => 'self.id' }
32
8091aa91 33will result in the JOIN clause
503536d5 34
35 foo me JOIN bar bar ON bar.foo_id = me.id
36
8091aa91 37You can specify as many foreign => self mappings as necessary.
38
39Valid attributes are as follows:
40
41=over 4
42
43=item join_type
44
45Explicitly specifies the type of join to use in the relationship. Any SQL
46join type is valid, e.g. C<LEFT> or C<RIGHT>. It will be placed in the SQL
47command immediately before C<JOIN>.
48
49=item proxy
50
51An arrayref containing a list of accessors in the foreign class to proxy in
52the main class. If, for example, you do the following:
53
54 __PACKAGE__->might_have(bar => 'Bar', undef, { proxy => qw[/ margle /] });
55
56Then, 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
63Specifies the type of accessor that should be created for the relationship.
64Valid values are C<single> (for when there is only a single related object),
65C<multi> (when there can be many), and C<filter> (for when there is a single
66related object, but you also want the relationship accessor to double as
67a column accessor). For C<multi> accessors, an add_to_* method is also
68created, which calls C<create_related> for the relationship.
69
70=back
71
71e65b39 72=head2 register_relationship($relname, $rel_info)
73
74Registers a relationship on the class
75
55e2d745 76=cut
77
71e65b39 78sub register_relationship { }
79
8091aa91 80=head2 search_related
503536d5 81
82 My::Table->search_related('relname', $cond, $attrs);
83
84=cut
85
55e2d745 86sub search_related {
87 my $self = shift;
3842b955 88 die "Can't call *_related as class methods" unless ref $self;
55e2d745 89 my $rel = shift;
90 my $attrs = { };
91 if (@_ > 1 && ref $_[$#_] eq 'HASH') {
92 $attrs = { %{ pop(@_) } };
93 }
4685e006 94 my $rel_obj = $self->relationship_info($rel);
701da8c4 95 $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
55e2d745 96 $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
97
701da8c4 98 $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
55e2d745 99 my $query = ((@_ > 1) ? {@_} : shift);
100
3842b955 101 my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self);
438adc0e 102 $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
3842b955 103 #use Data::Dumper; warn Dumper($cond);
438adc0e 104 #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
3842b955 105 return $self->result_source->related_source($rel
106 )->resultset->search($query, $attrs);
b52e9bf8 107}
108
109=head2 count_related
110
7be93b07 111 $obj->count_related('relname', $cond, $attrs);
b52e9bf8 112
113=cut
114
115sub count_related {
116 my $self = shift;
117 return $self->search_related(@_)->count;
55e2d745 118}
119
8091aa91 120=head2 create_related
503536d5 121
122 My::Table->create_related('relname', \%col_data);
123
124=cut
125
55e2d745 126sub create_related {
3842b955 127 my $self = shift;
fea3d045 128 my $rel = shift;
3842b955 129 return $self->search_related($rel)->create(@_);
55e2d745 130}
131
8091aa91 132=head2 new_related
503536d5 133
134 My::Table->new_related('relname', \%col_data);
135
136=cut
137
55e2d745 138sub new_related {
139 my ($self, $rel, $values, $attrs) = @_;
fea3d045 140 return $self->search_related($rel)->new($values, $attrs);
55e2d745 141}
142
8091aa91 143=head2 find_related
503536d5 144
145 My::Table->find_related('relname', @pri_vals | \%pri_vals);
146
147=cut
148
1a14aa3f 149sub find_related {
150 my $self = shift;
151 my $rel = shift;
716b3d29 152 return $self->search_related($rel)->find(@_);
1a14aa3f 153}
154
8091aa91 155=head2 find_or_create_related
503536d5 156
157 My::Table->find_or_create_related('relname', \%col_data);
158
159=cut
160
55e2d745 161sub find_or_create_related {
162 my $self = shift;
1a14aa3f 163 return $self->find_related(@_) || $self->create_related(@_);
55e2d745 164}
165
8091aa91 166=head2 set_from_related
503536d5 167
168 My::Table->set_from_related('relname', $rel_obj);
169
170=cut
171
55e2d745 172sub set_from_related {
173 my ($self, $rel, $f_obj) = @_;
4685e006 174 my $rel_obj = $self->relationship_info($rel);
701da8c4 175 $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
55e2d745 176 my $cond = $rel_obj->{cond};
701da8c4 177 $self->throw_exception( "set_from_related can only handle a hash condition; the "
55e2d745 178 ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
179 unless ref $cond eq 'HASH';
7fb16f1a 180 my $f_class = $self->result_source->schema->class($rel_obj->{class});
701da8c4 181 $self->throw_exception( "Object $f_obj isn't a ".$f_class )
55e2d745 182 unless $f_obj->isa($f_class);
183 foreach my $key (keys %$cond) {
184 next if ref $cond->{$key}; # Skip literals and complex conditions
701da8c4 185 $self->throw_exception("set_from_related can't handle $key as key")
55e2d745 186 unless $key =~ m/^foreign\.([^\.]+)$/;
187 my $val = $f_obj->get_column($1);
701da8c4 188 $self->throw_exception("set_from_related can't handle ".$cond->{$key}." as value")
55e2d745 189 unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
190 $self->set_column($1 => $val);
191 }
192 return 1;
193}
194
8091aa91 195=head2 update_from_related
503536d5 196
197 My::Table->update_from_related('relname', $rel_obj);
198
199=cut
200
55e2d745 201sub update_from_related {
202 my $self = shift;
203 $self->set_from_related(@_);
204 $self->update;
205}
206
8091aa91 207=head2 delete_related
503536d5 208
209 My::Table->delete_related('relname', $cond, $attrs);
210
211=cut
212
55e2d745 213sub delete_related {
214 my $self = shift;
215 return $self->search_related(@_)->delete;
216}
217
2181;
219
55e2d745 220=head1 AUTHORS
221
daec44b8 222Matt S. Trout <mst@shadowcatsystems.co.uk>
55e2d745 223
224=head1 LICENSE
225
226You may distribute this code under the same terms as Perl itself.
227
228=cut
229