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