3fef7a34b5aa4805a4565a6814d57a1a5ce6af32
[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 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     }
46     unless ($self->can($value)) {
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;
83   return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || {}});
84 }
85
86 sub create_related {
87   my ($self, $rel, $values, $attrs) = @_;
88   die "Can't call create_related as class method" unless ref $self;
89   die "create_related needs a hash" unless (ref $values eq 'HASH');
90   my $rel_obj = $self->_relationships->{$rel};
91   die "No such relationship ${rel}" unless $rel;
92   die "Can't abstract implicit create for ${rel}, condition not a hash"
93     unless ref $rel_obj->{cond} eq 'HASH';
94   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
95   my %fields = %$values;
96   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
97     $self->_cond_value($attrs, $k => $v);
98     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
99   }
100   return $rel_obj->{class}->create(\%fields);
101 }
102
103 1;