lib/DBIx/Class/Relationship/Base.pm

   1 package DBIx::Class::Relationship::Base;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class/;
   7
   8 __PACKAGE__->mk_classdata('_relationships', { } );
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Relationship::Base - 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 =item add_relationship
  27
  28   __PACKAGE__->add_relationship('relname', 'Foreign::Class', $cond, $attrs);
  29
  30 The condition needs to be an SQL::Abstract-style representation of the
  31 join between the tables - for example if you're creating a rel from Foo to Bar
  32
  33   { 'foreign.foo_id' => 'self.id' }
  34
  35 will result in a JOIN clause like
  36
  37   foo me JOIN bar bar ON bar.foo_id = me.id
  38
  39 =cut
  40
  41 sub add_relationship {
  42   my ($class, $rel, $f_class, $cond, $attrs) = @_;
  43   die "Can't create relationship without join condition" unless $cond;
  44   $attrs ||= {};
  45   eval "require $f_class;";
  46   if ($@) {
  47     $class->throw($@) unless $@ =~ /Can't locate/;
  48   }
  49   my %rels = %{ $class->_relationships };
  50   $rels{$rel} = { class => $f_class,
  51                   cond  => $cond,
  52                   attrs => $attrs };
  53   $class->_relationships(\%rels);
  54
  55   return unless eval { $f_class->can('columns'); }; # Foreign class not loaded
  56   eval { $class->_resolve_join($rel, 'me') };
  57
  58   if ($@) { # If the resolve failed, back out and re-throw the error
  59     delete $rels{$rel}; #
  60     $class->_relationships(\%rels);
  61     $class->throw("Error creating relationship $rel: $@");
  62   }
  63   1;
  64 }
  65
  66 sub _resolve_join {
  67   my ($class, $join, $alias) = @_;
  68   if (ref $join eq 'ARRAY') {
  69     return map { $class->_resolve_join($_, $alias) } @$join;
  70   } elsif (ref $join eq 'HASH') {
  71     return map { $class->_resolve_join($_, $alias),
  72                  $class->_relationships->{$_}{class}->_resolve_join($join->{$_}, $_) }
  73            keys %$join;
  74   } elsif (ref $join) {
  75     $class->throw("No idea how to resolve join reftype ".ref $join);
  76   } else {
  77     my $rel_obj = $class->_relationships->{$join};
  78     $class->throw("No such relationship ${join}") unless $rel_obj;
  79     my $j_class = $rel_obj->{class};
  80     my %join = (_action => 'join',
  81          _aliases => { 'self' => $alias, 'foreign' => $join },
  82          _classes => { $alias => $class, $join => $j_class });
  83     my $j_cond = $j_class->resolve_condition($rel_obj->{cond}, \%join);
  84     return [ { $join => $j_class->_table_name,
  85                -join_type => $rel_obj->{attrs}{join_type} || '' }, $j_cond ];
  86   }
  87 }
  88
  89 sub resolve_condition {
  90   my ($self, $cond, $attrs) = @_;
  91   if (ref $cond eq 'HASH') {
  92     my %ret;
  93     foreach my $key (keys %$cond) {
  94       my $val = $cond->{$key};
  95       if (ref $val) {
  96         $self->throw("Can't handle this yet :(");
  97       } else {
  98         $ret{$self->_cond_key($attrs => $key)}
  99           = $self->_cond_value($attrs => $key => $val);
 100       }
 101     }
 102     return \%ret;
 103   } else {
 104    $self->throw("Can't handle this yet :(");
 105   }
 106 }
 107
 108 sub _cond_key {
 109   my ($self, $attrs, $key) = @_;
 110   my $action = $attrs->{_action} || '';
 111   if ($action eq 'convert') {
 112     unless ($key =~ s/^foreign\.//) {
 113       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
 114     }
 115     return $key;
 116   } elsif ($action eq 'join') {
 117     return $key unless $key =~ /\./;
 118     my ($type, $field) = split(/\./, $key);
 119     if (my $alias = $attrs->{_aliases}{$type}) {
 120       my $class = $attrs->{_classes}{$alias};
 121       $self->throw("Unknown column $field on $class as $alias")
 122         unless $class->has_column($field);
 123       return join('.', $alias, $field);
 124     } else {
 125       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 126             join(', ', keys %{$attrs->{_aliases} || {}}) );
 127     }
 128   }
 129   return $self->next::method($attrs, $key);
 130 }
 131
 132 sub _cond_value {
 133   my ($self, $attrs, $key, $value) = @_;
 134   my $action = $attrs->{_action} || '';
 135   if ($action eq 'convert') {
 136     unless ($value =~ s/^self\.//) {
 137       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
 138     }
 139     unless ($self->has_column($value)) {
 140       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
 141     }
 142     return $self->get_column($value);
 143   } elsif ($action eq 'join') {
 144     return $key unless $key =~ /\./;
 145     my ($type, $field) = split(/\./, $value);
 146     if (my $alias = $attrs->{_aliases}{$type}) {
 147       my $class = $attrs->{_classes}{$alias};
 148       $self->throw("Unknown column $field on $class as $alias")
 149         unless $class->has_column($field);
 150       return join('.', $alias, $field);
 151     } else {
 152       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 153             join(', ', keys %{$attrs->{_aliases} || {}}) );
 154     }
 155   }
 156
 157   return $self->next::method($attrs, $key, $value)
 158 }
 159
 160 =item search_related
 161
 162   My::Table->search_related('relname', $cond, $attrs);
 163
 164 =cut
 165
 166 sub search_related {
 167   my $self = shift;
 168   return $self->_query_related('search', @_);
 169 }
 170
 171 =item count_related
 172
 173   My::Table->count_related('relname', $cond, $attrs);
 174
 175 =cut
 176
 177 sub count_related {
 178   my $self = shift;
 179   return $self->_query_related('count', @_);
 180 }
 181
 182 sub _query_related {
 183   my $self = shift;
 184   my $meth = shift;
 185   my $rel = shift;
 186   my $attrs = { };
 187   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 188     $attrs = { %{ pop(@_) } };
 189   }
 190   my $rel_obj = $self->_relationships->{$rel};
 191   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 192   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 193
 194   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 195   my $query = ((@_ > 1) ? {@_} : shift);
 196
 197   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 198                                  # to merge into the AST really?
 199   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
 200   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 201   #use Data::Dumper; warn Dumper($query);
 202   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 203   delete $attrs->{_action};
 204   return $self->resolve_class($rel_obj->{class}
 205            )->$meth($query, $attrs);
 206 }
 207
 208 =item create_related
 209
 210   My::Table->create_related('relname', \%col_data);
 211
 212 =cut
 213
 214 sub create_related {
 215   my $class = shift;
 216   return $class->new_related(@_)->insert;
 217 }
 218
 219 =item new_related
 220
 221   My::Table->new_related('relname', \%col_data);
 222
 223 =cut
 224
 225 sub new_related {
 226   my ($self, $rel, $values, $attrs) = @_;
 227   $self->throw( "Can't call new_related as class method" )
 228     unless ref $self;
 229   $self->throw( "new_related needs a hash" )
 230     unless (ref $values eq 'HASH');
 231   my $rel_obj = $self->_relationships->{$rel};
 232   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 233   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 234     unless ref $rel_obj->{cond} eq 'HASH';
 235   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 236
 237   my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
 238   $fields{$_} = $values->{$_} for keys %$values;
 239
 240   return $self->resolve_class($rel_obj->{class})->new(\%fields);
 241 }
 242
 243 =item find_related
 244
 245   My::Table->find_related('relname', @pri_vals | \%pri_vals);
 246
 247 =cut
 248
 249 sub find_related {
 250   my $self = shift;
 251   my $rel = shift;
 252   my $rel_obj = $self->_relationships->{$rel};
 253   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 254   my ($cond) = $self->resolve_condition($rel_obj->{cond}, { _action => 'convert' });
 255   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 256   my $attrs = { };
 257   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 258     $attrs = { %{ pop(@_) } };
 259   }
 260   my $query = ((@_ > 1) ? {@_} : shift);
 261   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 262   return $self->resolve_class($rel_obj->{class})->find($query);
 263 }
 264
 265 =item find_or_create_related
 266
 267   My::Table->find_or_create_related('relname', \%col_data);
 268
 269 =cut
 270
 271 sub find_or_create_related {
 272   my $self = shift;
 273   return $self->find_related(@_) || $self->create_related(@_);
 274 }
 275
 276 =item set_from_related
 277
 278   My::Table->set_from_related('relname', $rel_obj);
 279
 280 =cut
 281
 282 sub set_from_related {
 283   my ($self, $rel, $f_obj) = @_;
 284   my $rel_obj = $self->_relationships->{$rel};
 285   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 286   my $cond = $rel_obj->{cond};
 287   $self->throw( "set_from_related can only handle a hash condition; the "
 288     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 289       unless ref $cond eq 'HASH';
 290   my $f_class = $self->resolve_class($rel_obj->{class});
 291   $self->throw( "Object $f_obj isn't a ".$f_class )
 292     unless $f_obj->isa($f_class);
 293   foreach my $key (keys %$cond) {
 294     next if ref $cond->{$key}; # Skip literals and complex conditions
 295     $self->throw("set_from_related can't handle $key as key")
 296       unless $key =~ m/^foreign\.([^\.]+)$/;
 297     my $val = $f_obj->get_column($1);
 298     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 299       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 300     $self->set_column($1 => $val);
 301   }
 302   return 1;
 303 }
 304
 305 =item update_from_related
 306
 307   My::Table->update_from_related('relname', $rel_obj);
 308
 309 =cut
 310
 311 sub update_from_related {
 312   my $self = shift;
 313   $self->set_from_related(@_);
 314   $self->update;
 315 }
 316
 317 =item delete_related
 318
 319   My::Table->delete_related('relname', $cond, $attrs);
 320
 321 =cut
 322
 323 sub delete_related {
 324   my $self = shift;
 325   return $self->search_related(@_)->delete;
 326 }
 327
 328 1;
 329
 330 =back
 331
 332 =head1 AUTHORS
 333
 334 Matt S. Trout <mst@shadowcatsystems.co.uk>
 335
 336 =head1 LICENSE
 337
 338 You may distribute this code under the same terms as Perl itself.
 339
 340 =cut
 341