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   eval { $class->_resolve_join($rel, 'me') };
  42
  43   if ($@) { # If the resolve failed, back out and re-throw the error
  44     delete $rels{$rel}; #
  45     $class->_relationships(\%rels);
  46     $class->throw("Error creating relationship $rel: $@");
  47   }
  48   1;
  49 }
  50
  51 sub _resolve_join {
  52   my ($class, $join, $alias) = @_;
  53   if (ref $join eq 'ARRAY') {
  54     return map { $class->_resolve_join($_, $alias) } @$join;
  55   } elsif (ref $join eq 'HASH') {
  56     return map { $class->_resolve_join($_, $alias),
  57                  $class->_relationships->{$_}{class}->_resolve_join($join->{$_}, $_) }
  58            keys %$join;
  59   } elsif (ref $join) {
  60     $class->throw("No idea how to resolve join reftype ".ref $join);
  61   } else {
  62     my $rel_obj = $class->_relationships->{$join};
  63     $class->throw("No such relationship ${join}") unless $rel_obj;
  64     my $j_class = $rel_obj->{class};
  65     my %join = (_action => 'join',
  66          _aliases => { 'self' => $alias, 'foreign' => $join },
  67          _classes => { $alias => $class, $join => $j_class });
  68     my $j_cond = $j_class->resolve_condition($rel_obj->{cond}, \%join);
  69     return [ { $join => $j_class->_table_name,
  70                -join_type => $rel_obj->{attrs}{join_type} || '' }, $j_cond ];
  71   }
  72 }
  73
  74 sub resolve_condition {
  75   my ($self, $cond, $attrs) = @_;
  76   if (ref $cond eq 'HASH') {
  77     my %ret;
  78     foreach my $key (keys %$cond) {
  79       my $val = $cond->{$key};
  80       if (ref $val) {
  81         $self->throw("Can't handle this yet :(");
  82       } else {
  83         $ret{$self->_cond_key($attrs => $key)}
  84           = $self->_cond_value($attrs => $key => $val);
  85       }
  86     }
  87     return \%ret;
  88   } else {
  89    $self->throw("Can't handle this yet :(");
  90   }
  91 }
  92
  93 sub _cond_key {
  94   my ($self, $attrs, $key) = @_;
  95   my $action = $attrs->{_action} || '';
  96   if ($action eq 'convert') {
  97     unless ($key =~ s/^foreign\.//) {
  98       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
  99     }
 100     return $key;
 101   } elsif ($action eq 'join') {
 102     my ($type, $field) = split(/\./, $key);
 103     if (my $alias = $attrs->{_aliases}{$type}) {
 104       my $class = $attrs->{_classes}{$alias};
 105       $self->throw("Unknown column $field on $class as $alias")
 106         unless exists $class->_columns->{$field};
 107       return join('.', $alias, $field);
 108     } else {
 109       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 110             join(', ', keys %{$attrs->{_aliases} || {}}) );
 111     }
 112   }
 113   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
 114 }
 115
 116 sub _cond_value {
 117   my ($self, $attrs, $key, $value) = @_;
 118   my $action = $attrs->{_action} || '';
 119   if ($action eq 'convert') {
 120     unless ($value =~ s/^self\.//) {
 121       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
 122     }
 123     unless ($self->_columns->{$value}) {
 124       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
 125     }
 126     return $self->get_column($value);
 127   } elsif ($action eq 'join') {
 128     my ($type, $field) = split(/\./, $value);
 129     if (my $alias = $attrs->{_aliases}{$type}) {
 130       my $class = $attrs->{_classes}{$alias};
 131       $self->throw("Unknown column $field on $class as $alias")
 132         unless exists $class->_columns->{$field};
 133       return join('.', $alias, $field);
 134     } else {
 135       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 136             join(', ', keys %{$attrs->{_aliases} || {}}) );
 137     }
 138   }
 139
 140   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
 141 }
 142
 143 sub search_related {
 144   my $self = shift;
 145   return $self->_query_related('search', @_);
 146 }
 147
 148 sub count_related {
 149   my $self = shift;
 150   return $self->_query_related('count', @_);
 151 }
 152
 153 sub _query_related {
 154   my $self = shift;
 155   my $meth = shift;
 156   my $rel = shift;
 157   my $attrs = { };
 158   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 159     $attrs = { %{ pop(@_) } };
 160   }
 161   my $rel_obj = $self->_relationships->{$rel};
 162   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 163   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 164
 165   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 166   my $query = ((@_ > 1) ? {@_} : shift);
 167
 168   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 169                                  # to merge into the AST really?
 170   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
 171   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 172   #use Data::Dumper; warn Dumper($query);
 173   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 174   delete $attrs->{_action};
 175   return $self->resolve_class($rel_obj->{class}
 176            )->$meth($query, $attrs);
 177 }
 178
 179 sub create_related {
 180   my $class = shift;
 181   return $class->new_related(@_)->insert;
 182 }
 183
 184 sub new_related {
 185   my ($self, $rel, $values, $attrs) = @_;
 186   $self->throw( "Can't call new_related as class method" )
 187     unless ref $self;
 188   $self->throw( "new_related needs a hash" )
 189     unless (ref $values eq 'HASH');
 190   my $rel_obj = $self->_relationships->{$rel};
 191   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 192   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 193     unless ref $rel_obj->{cond} eq 'HASH';
 194   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 195
 196   my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
 197   $fields{$_} = $values->{$_} for keys %$values;
 198
 199   return $self->resolve_class($rel_obj->{class})->new(\%fields);
 200 }
 201
 202 sub find_related {
 203   my $self = shift;
 204   my $rel = shift;
 205   my $rel_obj = $self->_relationships->{$rel};
 206   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 207   my ($cond) = $self->resolve_condition($rel_obj->{cond}, { _action => 'convert' });
 208   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 209   my $attrs = { };
 210   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 211     $attrs = { %{ pop(@_) } };
 212   }
 213   my $query = ((@_ > 1) ? {@_} : shift);
 214   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 215   return $self->resolve_class($rel_obj->{class})->find($query);
 216 }
 217
 218 sub find_or_create_related {
 219   my $self = shift;
 220   return $self->find_related(@_) || $self->create_related(@_);
 221 }
 222
 223 sub set_from_related {
 224   my ($self, $rel, $f_obj) = @_;
 225   my $rel_obj = $self->_relationships->{$rel};
 226   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 227   my $cond = $rel_obj->{cond};
 228   $self->throw( "set_from_related can only handle a hash condition; the "
 229     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 230       unless ref $cond eq 'HASH';
 231   my $f_class = $self->resolve_class($rel_obj->{class});
 232   $self->throw( "Object $f_obj isn't a ".$f_class )
 233     unless $f_obj->isa($f_class);
 234   foreach my $key (keys %$cond) {
 235     next if ref $cond->{$key}; # Skip literals and complex conditions
 236     $self->throw("set_from_related can't handle $key as key")
 237       unless $key =~ m/^foreign\.([^\.]+)$/;
 238     my $val = $f_obj->get_column($1);
 239     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 240       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 241     $self->set_column($1 => $val);
 242   }
 243   return 1;
 244 }
 245
 246 sub update_from_related {
 247   my $self = shift;
 248   $self->set_from_related(@_);
 249   $self->update;
 250 }
 251
 252 sub delete_related {
 253   my $self = shift;
 254   return $self->search_related(@_)->delete;
 255 }
 256
 257 1;
 258
 259 =back
 260
 261 =head1 AUTHORS
 262
 263 Matt S. Trout <mst@shadowcatsystems.co.uk>
 264
 265 =head1 LICENSE
 266
 267 You may distribute this code under the same terms as Perl itself.
 268
 269 =cut
 270