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