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 $rel_obj->{class}->$meth($cond, @{$attrs->{bind} || []}, $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 $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   $self->throw( "Object $f_obj isn't a ".$rel_obj->{class} )
 179     unless $f_obj->isa($rel_obj->{class});
 180   foreach my $key (keys %$cond) {
 181     next if ref $cond->{$key}; # Skip literals and complex conditions
 182     $self->throw("set_from_related can't handle $key as key")
 183       unless $key =~ m/^foreign\.([^\.]+)$/;
 184     my $val = $f_obj->get_column($1);
 185     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 186       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 187     $self->set_column($1 => $val);
 188   }
 189   return 1;
 190 }
 191
 192 sub update_from_related {
 193   my $self = shift;
 194   $self->set_from_related(@_);
 195   $self->update;
 196 }
 197
 198 1;
 199
 200 =back
 201
 202 =head1 AUTHORS
 203
 204 Matt S. Trout <perl-stuff@trout.me.uk>
 205
 206 =head1 LICENSE
 207
 208 You may distribute this code under the same terms as Perl itself.
 209
 210 =cut
 211