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 =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
  28 sub add_relationship {
  29   my ($class, $rel, $f_class, $cond, $attrs) = @_;
  30   die "Can't create relationship without join condition" unless $cond;
  31   $attrs ||= {};
  32   eval "use $f_class;";
  33   my %rels = %{ $class->_relationships };
  34   $rels{$rel} = { class => $f_class,
  35                   cond  => $cond,
  36                   attrs => $attrs };
  37   $class->_relationships(\%rels);
  38   #warn %{$f_class->_columns};
  39
  40   return unless eval { %{$f_class->_columns}; }; # Foreign class not loaded
  41   my %join = (%$attrs, _action => 'join',
  42     _aliases => { 'self' => 'me', 'foreign' => $rel },
  43     _classes => { 'me' => $class, $rel => $f_class });
  44   eval { $class->_cond_resolve($cond, \%join) };
  45
  46   if ($@) { # If the resolve failed, back out and re-throw the error
  47     delete $rels{$rel}; #
  48     $class->_relationships(\%rels);
  49     $class->throw("Error creating relationship $rel: $@");
  50   }
  51   1;
  52 }
  53
  54 sub _cond_key {
  55   my ($self, $attrs, $key) = @_;
  56   my $action = $attrs->{_action} || '';
  57   if ($action eq 'convert') {
  58     unless ($key =~ s/^foreign\.//) {
  59       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
  60     }
  61     return $key;
  62   } elsif ($action eq 'join') {
  63     my ($type, $field) = split(/\./, $key);
  64     if (my $alias = $attrs->{_aliases}{$type}) {
  65       my $class = $attrs->{_classes}{$alias};
  66       $self->throw("Unknown column $field on $class as $alias")
  67         unless exists $class->_columns->{$field};
  68       return join('.', $alias, $field);
  69     } else {
  70       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
  71             join(', ', keys %{$attrs->{_aliases} || {}}) );
  72     }
  73   }
  74   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
  75 }
  76
  77 sub _cond_value {
  78   my ($self, $attrs, $key, $value) = @_;
  79   my $action = $attrs->{_action} || '';
  80   if ($action eq 'convert') {
  81     unless ($value =~ s/^self\.//) {
  82       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
  83     }
  84     unless ($self->_columns->{$value}) {
  85       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
  86     }
  87     push(@{$attrs->{bind}}, $self->get_column($value));
  88     return '?';
  89   } elsif ($action eq 'join') {
  90     my ($type, $field) = split(/\./, $value);
  91     if (my $alias = $attrs->{_aliases}{$type}) {
  92       my $class = $attrs->{_classes}{$alias};
  93       $self->throw("Unknown column $field on $class as $alias")
  94         unless exists $class->_columns->{$field};
  95       return join('.', $alias, $field);
  96     } else {
  97       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
  98             join(', ', keys %{$attrs->{_aliases} || {}}) );
  99     }
 100   }
 101
 102   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
 103 }
 104
 105 sub search_related {
 106   my $self = shift;
 107   $self->_from_sql_related('retrieve', @_);
 108 }
 109
 110 sub count_related {
 111   my $self = shift;
 112   $self->_from_sql_related('count', @_);
 113 }
 114
 115 sub _from_sql_related {
 116   my $self = shift;
 117   my $op = shift;
 118   my $meth = "${op}_from_sql";
 119   my $rel = shift;
 120   my $attrs = { };
 121   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 122     $attrs = { %{ pop(@_) } };
 123   }
 124   my $rel_obj = $self->_relationships->{$rel};
 125   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 126   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 127   my $s_cond;
 128   if (@_) {
 129     $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 130     my $query = ((@_ > 1) ? {@_} : shift);
 131     $s_cond = $self->_cond_resolve($query, $attrs);
 132   }
 133   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 134                                  # to merge into the AST really?
 135   my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
 136   $cond = "${s_cond} AND ${cond}" if $s_cond;
 137   return $rel_obj->{class}->$meth($cond, @{$attrs->{bind} || []}, $attrs);
 138 }
 139
 140 sub create_related {
 141   my $class = shift;
 142   return $class->new_related(@_)->insert;
 143 }
 144
 145 sub new_related {
 146   my ($self, $rel, $values, $attrs) = @_;
 147   $self->throw( "Can't call new_related as class method" )
 148     unless ref $self;
 149   $self->throw( "new_related needs a hash" )
 150     unless (ref $values eq 'HASH');
 151   my $rel_obj = $self->_relationships->{$rel};
 152   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 153   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 154     unless ref $rel_obj->{cond} eq 'HASH';
 155   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 156   my %fields = %$values;
 157   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
 158     $self->_cond_value($attrs, $k => $v);
 159     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
 160   }
 161   return $rel_obj->{class}->new(\%fields);
 162 }
 163
 164 sub find_or_create_related {
 165   my $self = shift;
 166   return ($self->search_related(@_))[0] || $self->create_related(@_);
 167 }
 168
 169 sub set_from_related {
 170   my ($self, $rel, $f_obj) = @_;
 171   my $rel_obj = $self->_relationships->{$rel};
 172   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 173   my $cond = $rel_obj->{cond};
 174   $self->throw( "set_from_related can only handle a hash condition; the "
 175     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 176       unless ref $cond eq 'HASH';
 177   $self->throw( "Object $f_obj isn't a ".$rel_obj->{class} )
 178     unless $f_obj->isa($rel_obj->{class});
 179   foreach my $key (keys %$cond) {
 180     next if ref $cond->{$key}; # Skip literals and complex conditions
 181     $self->throw("set_from_related can't handle $key as key")
 182       unless $key =~ m/^foreign\.([^\.]+)$/;
 183     my $val = $f_obj->get_column($1);
 184     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 185       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 186     $self->set_column($1 => $val);
 187   }
 188   return 1;
 189 }
 190
 191 sub update_from_related {
 192   my $self = shift;
 193   $self->set_from_related(@_);
 194   $self->update;
 195 }
 196
 197 1;
 198
 199 =back
 200
 201 =head1 AUTHORS
 202
 203 Matt S. Trout <perl-stuff@trout.me.uk>
 204
 205 =head1 LICENSE
 206
 207 You may distribute this code under the same terms as Perl itself.
 208
 209 =cut
 210