14741b0ee30ab594d72ccd4d9ea7f5037d978df2
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Relationship.pm
1 package DBIx::Class::Relationship;
2
3 use strict;
4 use warnings;
5
6 use base qw/Class::Data::Inheritable/;
7
8 __PACKAGE__->mk_classdata('_relationships', { } );
9
10 =head1 NAME 
11
12 DBIx::Class::Relationship - 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 =cut
27
28 sub add_relationship {
29   my ($class, $rel, $f_class, $cond, $attrs) = @_;
30   die "Can't create relationship without join condition" unless $cond;
31   $attrs ||= {};
32   eval "use $f_class;";
33   my %rels = %{ $class->_relationships };
34   $rels{$rel} = { class => $f_class,
35                   cond  => $cond,
36                   attrs => $attrs };
37   $class->_relationships(\%rels);
38   #warn %{$f_class->_columns};
39
40   return unless eval { %{$f_class->_columns}; }; # Foreign class not loaded
41   my %join = (%$attrs, _action => 'join',
42     _aliases => { 'self' => 'me', 'foreign' => $rel },
43     _classes => { 'me' => $class, $rel => $f_class });
44   eval { $class->_cond_resolve($cond, \%join) };
45
46   if ($@) { # If the resolve failed, back out and re-throw the error
47     delete $rels{$rel}; # 
48     $class->_relationships(\%rels);
49     $class->throw("Error creating relationship $rel: $@");
50   }
51   1;
52 }
53
54 sub _cond_key {
55   my ($self, $attrs, $key) = @_;
56   my $action = $attrs->{_action} || '';
57   if ($action eq 'convert') {
58     unless ($key =~ s/^foreign\.//) {
59       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
60     }
61     return $key;
62   } elsif ($action eq 'join') {
63     my ($type, $field) = split(/\./, $key);
64     if (my $alias = $attrs->{_aliases}{$type}) {
65       my $class = $attrs->{_classes}{$alias};
66       $self->throw("Unknown column $field on $class as $alias")
67         unless exists $class->_columns->{$field};
68       return join('.', $alias, $field);
69     } else {
70       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
71             join(', ', keys %{$attrs->{_aliases} || {}}) );
72     }
73   }
74   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
75 }
76
77 sub _cond_value {
78   my ($self, $attrs, $key, $value) = @_;
79   my $action = $attrs->{_action} || '';
80   if ($action eq 'convert') {
81     unless ($value =~ s/^self\.//) {
82       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
83     }
84     unless ($self->_columns->{$value}) {
85       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
86     }
87     push(@{$attrs->{bind}}, $self->get_column($value));
88     return '?';
89   } elsif ($action eq 'join') {
90     my ($type, $field) = split(/\./, $value);
91     if (my $alias = $attrs->{_aliases}{$type}) {
92       my $class = $attrs->{_classes}{$alias};
93       $self->throw("Unknown column $field on $class as $alias")
94         unless exists $class->_columns->{$field};
95       return join('.', $alias, $field);
96     } else {
97       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
98             join(', ', keys %{$attrs->{_aliases} || {}}) );
99     }
100   }
101       
102   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
103 }
104
105 sub search_related {
106   my $self = shift;
107   return $self->_literal_related('search', @_);
108 }
109
110 sub count_related {
111   my $self = shift;
112   return $self->_literal_related('count', @_);
113 }
114
115 sub _literal_related {
116   my $self = shift;
117   my $op = shift;
118   my $meth = "${op}_literal";
119   my $rel = shift;
120   my $attrs = { };
121   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
122     $attrs = { %{ pop(@_) } };
123   }
124   my $rel_obj = $self->_relationships->{$rel};
125   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
126   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
127   my $s_cond;
128   if (@_) {
129     $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
130     my $query = ((@_ > 1) ? {@_} : shift);
131     $s_cond = $self->_cond_resolve($query, $attrs);
132   }
133   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
134                                  # to merge into the AST really?
135   my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
136   $cond = "${s_cond} AND ${cond}" if $s_cond;
137   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}});
138   return $rel_obj->{class}->$meth($cond, @{$attrs->{bind} || []}, $attrs);
139 }
140
141 sub create_related {
142   my $class = shift;
143   return $class->new_related(@_)->insert;
144 }
145
146 sub new_related {
147   my ($self, $rel, $values, $attrs) = @_;
148   $self->throw( "Can't call new_related as class method" ) 
149     unless ref $self;
150   $self->throw( "new_related needs a hash" ) 
151     unless (ref $values eq 'HASH');
152   my $rel_obj = $self->_relationships->{$rel};
153   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
154   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
155     unless ref $rel_obj->{cond} eq 'HASH';
156   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
157   my %fields = %$values;
158   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
159     $self->_cond_value($attrs, $k => $v);
160     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
161   }
162   return $rel_obj->{class}->new(\%fields);
163 }
164
165 sub find_or_create_related {
166   my $self = shift;
167   return ($self->search_related(@_))[0] || $self->create_related(@_);
168 }
169
170 sub set_from_related {
171   my ($self, $rel, $f_obj) = @_;
172   my $rel_obj = $self->_relationships->{$rel};
173   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
174   my $cond = $rel_obj->{cond};
175   $self->throw( "set_from_related can only handle a hash condition; the "
176     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
177       unless ref $cond eq 'HASH';
178   $self->throw( "Object $f_obj isn't a ".$rel_obj->{class} )
179     unless $f_obj->isa($rel_obj->{class});
180   foreach my $key (keys %$cond) {
181     next if ref $cond->{$key}; # Skip literals and complex conditions
182     $self->throw("set_from_related can't handle $key as key")
183       unless $key =~ m/^foreign\.([^\.]+)$/;
184     my $val = $f_obj->get_column($1);
185     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
186       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
187     $self->set_column($1 => $val);
188   }
189   return 1;
190 }
191
192 sub update_from_related {
193   my $self = shift;
194   $self->set_from_related(@_);
195   $self->update;
196 }
197
198 1;
199
200 =back
201
202 =head1 AUTHORS
203
204 Matt S. Trout <perl-stuff@trout.me.uk>
205
206 =head1 LICENSE
207
208 You may distribute this code under the same terms as Perl itself.
209
210 =cut
211