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   return $self->_query_related('search', @_);
 108 }
 109
 110 sub count_related {
 111   my $self = shift;
 112   return $self->_query_related('count', @_);
 113 }
 114
 115 sub _query_related {
 116   my $self = shift;
 117   my $meth = shift;
 118   my $rel = shift;
 119   my $attrs = { };
 120   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 121     $attrs = { %{ pop(@_) } };
 122   }
 123   my $rel_obj = $self->_relationships->{$rel};
 124   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 125   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 126
 127   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 128   my $query = ((@_ > 1) ? {@_} : shift);
 129
 130   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 131                                  # to merge into the AST really?
 132   my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
 133   $query = ($query ? { '-and' => [ \$cond, $query ] } : \$cond);
 134   #use Data::Dumper; warn Dumper($query);
 135   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}});
 136   delete $attrs->{_action};
 137   return $self->resolve_class($rel_obj->{class}
 138            )->$meth($query, $attrs);
 139 }
 140
 141 sub create_related {
 142   my $class = shift;
 143   return $class->new_related(@_)->insert;
 144 }
 145
 146 sub new_related {
 147   my ($self, $rel, $values, $attrs) = @_;
 148   $self->throw( "Can't call new_related as class method" )
 149     unless ref $self;
 150   $self->throw( "new_related needs a hash" )
 151     unless (ref $values eq 'HASH');
 152   my $rel_obj = $self->_relationships->{$rel};
 153   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 154   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 155     unless ref $rel_obj->{cond} eq 'HASH';
 156   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 157   my %fields = %$values;
 158   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
 159     $self->_cond_value($attrs, $k => $v);
 160     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
 161   }
 162   return $self->resolve_class($rel_obj->{class})->new(\%fields);
 163 }
 164
 165 sub find_or_create_related {
 166   my $self = shift;
 167   return ($self->search_related(@_))[0] || $self->create_related(@_);
 168 }
 169
 170 sub set_from_related {
 171   my ($self, $rel, $f_obj) = @_;
 172   my $rel_obj = $self->_relationships->{$rel};
 173   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 174   my $cond = $rel_obj->{cond};
 175   $self->throw( "set_from_related can only handle a hash condition; the "
 176     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 177       unless ref $cond eq 'HASH';
 178   my $f_class = $self->resolve_class($rel_obj->{class});
 179   $self->throw( "Object $f_obj isn't a ".$f_class )
 180     unless $f_obj->isa($f_class);
 181   foreach my $key (keys %$cond) {
 182     next if ref $cond->{$key}; # Skip literals and complex conditions
 183     $self->throw("set_from_related can't handle $key as key")
 184       unless $key =~ m/^foreign\.([^\.]+)$/;
 185     my $val = $f_obj->get_column($1);
 186     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 187       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 188     $self->set_column($1 => $val);
 189   }
 190   return 1;
 191 }
 192
 193 sub update_from_related {
 194   my $self = shift;
 195   $self->set_from_related(@_);
 196   $self->update;
 197 }
 198
 199 sub delete_related {
 200   my $self = shift;
 201   return $self->search_related(@_)->delete;
 202 }
 203
 204 1;
 205
 206 =back
 207
 208 =head1 AUTHORS
 209
 210 Matt S. Trout <perl-stuff@trout.me.uk>
 211
 212 =head1 LICENSE
 213
 214 You may distribute this code under the same terms as Perl itself.
 215
 216 =cut
 217