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 | |
10 | sub add_relationship { |
11 | my ($class, $rel, $f_class, $cond, $attrs) = @_; |
12 | my %rels = %{ $class->_relationships }; |
13 | $rels{$rel} = { class => $f_class, |
14 | cond => $cond, |
15 | attrs => $attrs }; |
16 | $class->_relationships(\%rels); |
17 | } |
18 | |
19 | sub _cond_key { |
20 | my ($self, $attrs, $key) = @_; |
21 | my $action = $attrs->{_action} || ''; |
22 | if ($action eq 'convert') { |
23 | unless ($key =~ s/^foreign\.//) { |
24 | die "Unable to convert relationship to WHERE clause: invalid key ${key}"; |
25 | } |
26 | return $key; |
27 | } elsif ($action eq 'join') { |
28 | my ($type, $field) = split(/\./, $key); |
29 | if ($attrs->{_aliases}{$type}) { |
30 | return join('.', $attrs->{_aliases}{$type}, $field); |
31 | } else { |
32 | die "Unable to resolve type ${type}: only have aliases for ". |
33 | join(', ', keys %{$attrs->{_aliases}{$type} || {}}); |
34 | } |
35 | } |
36 | return $self->NEXT::ACTUAL::_cond_key($attrs, $key); |
37 | } |
38 | |
39 | sub _cond_value { |
40 | my ($self, $attrs, $key, $value) = @_; |
41 | my $action = $attrs->{_action} || ''; |
42 | if ($action eq 'convert') { |
43 | unless ($value =~ s/^self\.//) { |
44 | die "Unable to convert relationship to WHERE clause: invalid value ${value}"; |
45 | } |
c687b87e |
46 | unless ($self->_columns->{$value}) { |
b8e1e21f |
47 | die "Unable to convert relationship to WHERE clause: no such accessor ${value}"; |
48 | } |
49 | push(@{$attrs->{bind}}, $self->get_column($value)); |
50 | return '?'; |
51 | } elsif ($action eq 'join') { |
52 | my ($type, $field) = split(/\./, $value); |
53 | if ($attrs->{_aliases}{$type}) { |
54 | return join('.', $attrs->{_aliases}{$type}, $field); |
55 | } else { |
56 | die "Unable to resolve type ${type}: only have aliases for ". |
57 | join(', ', keys %{$attrs->{_aliases}{$type} || {}}); |
58 | } |
59 | } |
60 | |
61 | return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value) |
62 | } |
63 | |
64 | sub search_related { |
65 | my $self = shift; |
66 | my $rel = shift; |
67 | my $attrs = { }; |
68 | if (@_ > 1 && ref $_[$#_] eq 'HASH') { |
69 | $attrs = { %{ pop(@_) } }; |
70 | } |
71 | my $rel_obj = $self->_relationships->{$rel}; |
72 | die "No such relationship ${rel}" unless $rel; |
73 | $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}} }; |
74 | my $s_cond; |
75 | if (@_) { |
76 | die "Invalid query: @_" if (@_ > 1 && (@_ % 2 == 1)); |
77 | my $query = ((@_ > 1) ? {@_} : shift); |
78 | $s_cond = $self->_cond_resolve($query, $attrs); |
79 | } |
80 | $attrs->{_action} = 'convert'; |
81 | my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs); |
82 | $cond = "${s_cond} AND ${cond}" if $s_cond; |
c687b87e |
83 | return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || []}, |
84 | $attrs); |
b8e1e21f |
85 | } |
86 | |
87 | sub create_related { |
88 | my ($self, $rel, $values, $attrs) = @_; |
89 | die "Can't call create_related as class method" unless ref $self; |
90 | die "create_related needs a hash" unless (ref $values eq 'HASH'); |
91 | my $rel_obj = $self->_relationships->{$rel}; |
92 | die "No such relationship ${rel}" unless $rel; |
93 | die "Can't abstract implicit create for ${rel}, condition not a hash" |
94 | unless ref $rel_obj->{cond} eq 'HASH'; |
95 | $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' }; |
96 | my %fields = %$values; |
97 | while (my ($k, $v) = each %{$rel_obj->{cond}}) { |
98 | $self->_cond_value($attrs, $k => $v); |
99 | $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0]; |
100 | } |
101 | return $rel_obj->{class}->create(\%fields); |
102 | } |
103 | |
104 | 1; |