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