Commit | Line | Data |
b8e1e21f |
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 | |
34d52be2 |
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 | |
b8e1e21f |
28 | sub add_relationship { |
29 | my ($class, $rel, $f_class, $cond, $attrs) = @_; |
1c6ae274 |
30 | die "Can't create relationship without join condition" unless $cond; |
d2ff6175 |
31 | $attrs ||= {}; |
32 | eval "use $f_class;"; |
b8e1e21f |
33 | my %rels = %{ $class->_relationships }; |
34 | $rels{$rel} = { class => $f_class, |
35 | cond => $cond, |
36 | attrs => $attrs }; |
37 | $class->_relationships(\%rels); |
d2ff6175 |
38 | #warn %{$f_class->_columns}; |
39 | return unless eval { %{$f_class->_columns}; }; # Foreign class not loaded |
40 | my %join = (%$attrs, _action => 'join', |
41 | _aliases => { 'self' => 'me', 'foreign' => $rel }, |
42 | _classes => { 'me' => $class, $rel => $f_class }); |
43 | eval { $class->_cond_resolve($cond, \%join) }; |
44 | $class->throw("Error creating relationship $rel: $@") if $@; |
b8e1e21f |
45 | } |
46 | |
47 | sub _cond_key { |
48 | my ($self, $attrs, $key) = @_; |
49 | my $action = $attrs->{_action} || ''; |
50 | if ($action eq 'convert') { |
51 | unless ($key =~ s/^foreign\.//) { |
78bab9ca |
52 | $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}"); |
b8e1e21f |
53 | } |
54 | return $key; |
55 | } elsif ($action eq 'join') { |
56 | my ($type, $field) = split(/\./, $key); |
d2ff6175 |
57 | if (my $alias = $attrs->{_aliases}{$type}) { |
58 | my $class = $attrs->{_classes}{$alias}; |
59 | $self->throw("Unknown column $field on $class as $alias") |
60 | unless exists $class->_columns->{$field}; |
61 | return join('.', $alias, $field); |
b8e1e21f |
62 | } else { |
78bab9ca |
63 | $self->throw( "Unable to resolve type ${type}: only have aliases for ". |
d2ff6175 |
64 | join(', ', keys %{$attrs->{_aliases} || {}}) ); |
b8e1e21f |
65 | } |
66 | } |
67 | return $self->NEXT::ACTUAL::_cond_key($attrs, $key); |
68 | } |
69 | |
70 | sub _cond_value { |
71 | my ($self, $attrs, $key, $value) = @_; |
72 | my $action = $attrs->{_action} || ''; |
73 | if ($action eq 'convert') { |
74 | unless ($value =~ s/^self\.//) { |
78bab9ca |
75 | $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" ); |
b8e1e21f |
76 | } |
c687b87e |
77 | unless ($self->_columns->{$value}) { |
78bab9ca |
78 | $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" ); |
b8e1e21f |
79 | } |
80 | push(@{$attrs->{bind}}, $self->get_column($value)); |
81 | return '?'; |
82 | } elsif ($action eq 'join') { |
83 | my ($type, $field) = split(/\./, $value); |
d2ff6175 |
84 | if (my $alias = $attrs->{_aliases}{$type}) { |
85 | my $class = $attrs->{_classes}{$alias}; |
86 | $self->throw("Unknown column $field on $class as $alias") |
87 | unless exists $class->_columns->{$field}; |
88 | return join('.', $alias, $field); |
b8e1e21f |
89 | } else { |
78bab9ca |
90 | $self->throw( "Unable to resolve type ${type}: only have aliases for ". |
d2ff6175 |
91 | join(', ', keys %{$attrs->{_aliases} || {}}) ); |
b8e1e21f |
92 | } |
93 | } |
94 | |
95 | return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value) |
96 | } |
97 | |
98 | sub search_related { |
99 | my $self = shift; |
100 | my $rel = shift; |
101 | my $attrs = { }; |
102 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
103 | $attrs = { %{ pop(@_) } }; |
104 | } |
105 | my $rel_obj = $self->_relationships->{$rel}; |
78bab9ca |
106 | $self->throw( "No such relationship ${rel}" ) unless $rel; |
9b6e0845 |
107 | $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} }; |
b8e1e21f |
108 | my $s_cond; |
109 | if (@_) { |
78bab9ca |
110 | $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1)); |
b8e1e21f |
111 | my $query = ((@_ > 1) ? {@_} : shift); |
112 | $s_cond = $self->_cond_resolve($query, $attrs); |
113 | } |
114 | $attrs->{_action} = 'convert'; |
115 | my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs); |
116 | $cond = "${s_cond} AND ${cond}" if $s_cond; |
c687b87e |
117 | return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || []}, |
118 | $attrs); |
b8e1e21f |
119 | } |
120 | |
121 | sub create_related { |
122 | my ($self, $rel, $values, $attrs) = @_; |
78bab9ca |
123 | $self->throw( "Can't call create_related as class method" ) |
124 | unless ref $self; |
125 | $self->throw( "create_related needs a hash" ) |
126 | unless (ref $values eq 'HASH'); |
b8e1e21f |
127 | my $rel_obj = $self->_relationships->{$rel}; |
78bab9ca |
128 | $self->throw( "No such relationship ${rel}" ) unless $rel; |
129 | $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" ) |
b8e1e21f |
130 | unless ref $rel_obj->{cond} eq 'HASH'; |
131 | $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' }; |
132 | my %fields = %$values; |
133 | while (my ($k, $v) = each %{$rel_obj->{cond}}) { |
134 | $self->_cond_value($attrs, $k => $v); |
135 | $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0]; |
136 | } |
137 | return $rel_obj->{class}->create(\%fields); |
138 | } |
139 | |
140 | 1; |
34d52be2 |
141 | |
142 | =back |
143 | |
144 | =head1 AUTHORS |
145 | |
146 | Matt S. Trout <perl-stuff@trout.me.uk> |
147 | |
148 | =head1 LICENSE |
149 | |
150 | You may distribute this code under the same terms as Perl itself. |
151 | |
152 | =cut |
153 | |