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_or_create_related {
 186   my $self = shift;
 187   return ($self->search_related(@_))[0] || $self->create_related(@_);
 188 }
 189
 190 sub set_from_related {
 191   my ($self, $rel, $f_obj) = @_;
 192   my $rel_obj = $self->_relationships->{$rel};
 193   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 194   my $cond = $rel_obj->{cond};
 195   $self->throw( "set_from_related can only handle a hash condition; the "
 196     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 197       unless ref $cond eq 'HASH';
 198   my $f_class = $self->resolve_class($rel_obj->{class});
 199   $self->throw( "Object $f_obj isn't a ".$f_class )
 200     unless $f_obj->isa($f_class);
 201   foreach my $key (keys %$cond) {
 202     next if ref $cond->{$key}; # Skip literals and complex conditions
 203     $self->throw("set_from_related can't handle $key as key")
 204       unless $key =~ m/^foreign\.([^\.]+)$/;
 205     my $val = $f_obj->get_column($1);
 206     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 207       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 208     $self->set_column($1 => $val);
 209   }
 210   return 1;
 211 }
 212
 213 sub update_from_related {
 214   my $self = shift;
 215   $self->set_from_related(@_);
 216   $self->update;
 217 }
 218
 219 sub delete_related {
 220   my $self = shift;
 221   return $self->search_related(@_)->delete;
 222 }
 223
 224 1;
 225
 226 =back
 227
 228 =head1 AUTHORS
 229
 230 Matt S. Trout <mst@shadowcatsystems.co.uk>
 231
 232 =head1 LICENSE
 233
 234 You may distribute this code under the same terms as Perl itself.
 235
 236 =cut
 237