lib/DBIx/Class/Relationship/Base.pm

   1 package DBIx::Class::Relationship::Base;
   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->resolve_condition($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 resolve_condition {
  55   my ($self, $cond, $attrs) = @_;
  56   if (ref $cond eq 'HASH') {
  57     my %ret;
  58     foreach my $key (keys %$cond) {
  59       my $val = $cond->{$key};
  60       if (ref $val) {
  61         $self->throw("Can't handle this yet :(");
  62       } else {
  63         $ret{$self->_cond_key($attrs => $key)}
  64           = $self->_cond_value($attrs => $key => $val);
  65       }
  66     }
  67     return \%ret;
  68   } else {
  69    $self->throw("Can't handle this yet :(");
  70   }
  71 }
  72
  73 sub _cond_key {
  74   my ($self, $attrs, $key) = @_;
  75   my $action = $attrs->{_action} || '';
  76   if ($action eq 'convert') {
  77     unless ($key =~ s/^foreign\.//) {
  78       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
  79     }
  80     return $key;
  81   } elsif ($action eq 'join') {
  82     my ($type, $field) = split(/\./, $key);
  83     if (my $alias = $attrs->{_aliases}{$type}) {
  84       my $class = $attrs->{_classes}{$alias};
  85       $self->throw("Unknown column $field on $class as $alias")
  86         unless exists $class->_columns->{$field};
  87       return join('.', $alias, $field);
  88     } else {
  89       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
  90             join(', ', keys %{$attrs->{_aliases} || {}}) );
  91     }
  92   }
  93   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
  94 }
  95
  96 sub _cond_value {
  97   my ($self, $attrs, $key, $value) = @_;
  98   my $action = $attrs->{_action} || '';
  99   if ($action eq 'convert') {
 100     unless ($value =~ s/^self\.//) {
 101       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
 102     }
 103     unless ($self->_columns->{$value}) {
 104       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
 105     }
 106     return $self->get_column($value);
 107   } elsif ($action eq 'join') {
 108     my ($type, $field) = split(/\./, $value);
 109     if (my $alias = $attrs->{_aliases}{$type}) {
 110       my $class = $attrs->{_classes}{$alias};
 111       $self->throw("Unknown column $field on $class as $alias")
 112         unless exists $class->_columns->{$field};
 113       my $ret = join('.', $alias, $field);
 114       # return { '=' => \$ret }; # SQL::Abstract doesn't handle this yet :(
 115       $ret = " = ${ret}";
 116       return \$ret;
 117     } else {
 118       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 119             join(', ', keys %{$attrs->{_aliases} || {}}) );
 120     }
 121   }
 122
 123   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
 124 }
 125
 126 sub search_related {
 127   my $self = shift;
 128   return $self->_query_related('search', @_);
 129 }
 130
 131 sub count_related {
 132   my $self = shift;
 133   return $self->_query_related('count', @_);
 134 }
 135
 136 sub _query_related {
 137   my $self = shift;
 138   my $meth = shift;
 139   my $rel = shift;
 140   my $attrs = { };
 141   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 142     $attrs = { %{ pop(@_) } };
 143   }
 144   my $rel_obj = $self->_relationships->{$rel};
 145   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 146   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 147
 148   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 149   my $query = ((@_ > 1) ? {@_} : shift);
 150
 151   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 152                                  # to merge into the AST really?
 153   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
 154   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 155   #use Data::Dumper; warn Dumper($query);
 156   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 157   delete $attrs->{_action};
 158   return $self->resolve_class($rel_obj->{class}
 159            )->$meth($query, $attrs);
 160 }
 161
 162 sub create_related {
 163   my $class = shift;
 164   return $class->new_related(@_)->insert;
 165 }
 166
 167 sub new_related {
 168   my ($self, $rel, $values, $attrs) = @_;
 169   $self->throw( "Can't call new_related as class method" )
 170     unless ref $self;
 171   $self->throw( "new_related needs a hash" )
 172     unless (ref $values eq 'HASH');
 173   my $rel_obj = $self->_relationships->{$rel};
 174   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 175   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 176     unless ref $rel_obj->{cond} eq 'HASH';
 177   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 178
 179   my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
 180   $fields{$_} = $values->{$_} for keys %$values;
 181
 182   return $self->resolve_class($rel_obj->{class})->new(\%fields);
 183 }
 184
 185 sub find_related {
 186   my $self = shift;
 187   my $rel = shift;
 188   my $rel_obj = $self->_relationships->{$rel};
 189   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 190   my ($cond) = $self->resolve_condition($rel_obj->{cond}, { _action => 'convert' });
 191   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 192   my $attrs = { };
 193   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 194     $attrs = { %{ pop(@_) } };
 195   }
 196   my $query = ((@_ > 1) ? {@_} : shift);
 197   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 198   return $self->resolve_class($rel_obj->{class})->find($query);
 199 }
 200
 201 sub find_or_create_related {
 202   my $self = shift;
 203   return $self->find_related(@_) || $self->create_related(@_);
 204 }
 205
 206 sub set_from_related {
 207   my ($self, $rel, $f_obj) = @_;
 208   my $rel_obj = $self->_relationships->{$rel};
 209   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 210   my $cond = $rel_obj->{cond};
 211   $self->throw( "set_from_related can only handle a hash condition; the "
 212     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 213       unless ref $cond eq 'HASH';
 214   my $f_class = $self->resolve_class($rel_obj->{class});
 215   $self->throw( "Object $f_obj isn't a ".$f_class )
 216     unless $f_obj->isa($f_class);
 217   foreach my $key (keys %$cond) {
 218     next if ref $cond->{$key}; # Skip literals and complex conditions
 219     $self->throw("set_from_related can't handle $key as key")
 220       unless $key =~ m/^foreign\.([^\.]+)$/;
 221     my $val = $f_obj->get_column($1);
 222     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 223       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 224     $self->set_column($1 => $val);
 225   }
 226   return 1;
 227 }
 228
 229 sub update_from_related {
 230   my $self = shift;
 231   $self->set_from_related(@_);
 232   $self->update;
 233 }
 234
 235 sub delete_related {
 236   my $self = shift;
 237   return $self->search_related(@_)->delete;
 238 }
 239
 240 1;
 241
 242 =back
 243
 244 =head1 AUTHORS
 245
 246 Matt S. Trout <mst@shadowcatsystems.co.uk>
 247
 248 =head1 LICENSE
 249
 250 You may distribute this code under the same terms as Perl itself.
 251
 252 =cut
 253