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