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