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 =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 "use $f_class;";
  46   my %rels = %{ $class->_relationships };
  47   $rels{$rel} = { class => $f_class,
  48                   cond  => $cond,
  49                   attrs => $attrs };
  50   $class->_relationships(\%rels);
  51   #warn %{$f_class->_columns};
  52
  53   return unless eval { %{$f_class->_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     my ($type, $field) = split(/\./, $key);
 116     if (my $alias = $attrs->{_aliases}{$type}) {
 117       my $class = $attrs->{_classes}{$alias};
 118       $self->throw("Unknown column $field on $class as $alias")
 119         unless exists $class->_columns->{$field};
 120       return join('.', $alias, $field);
 121     } else {
 122       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 123             join(', ', keys %{$attrs->{_aliases} || {}}) );
 124     }
 125   }
 126   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
 127 }
 128
 129 sub _cond_value {
 130   my ($self, $attrs, $key, $value) = @_;
 131   my $action = $attrs->{_action} || '';
 132   if ($action eq 'convert') {
 133     unless ($value =~ s/^self\.//) {
 134       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
 135     }
 136     unless ($self->_columns->{$value}) {
 137       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
 138     }
 139     return $self->get_column($value);
 140   } elsif ($action eq 'join') {
 141     my ($type, $field) = split(/\./, $value);
 142     if (my $alias = $attrs->{_aliases}{$type}) {
 143       my $class = $attrs->{_classes}{$alias};
 144       $self->throw("Unknown column $field on $class as $alias")
 145         unless exists $class->_columns->{$field};
 146       return join('.', $alias, $field);
 147     } else {
 148       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 149             join(', ', keys %{$attrs->{_aliases} || {}}) );
 150     }
 151   }
 152
 153   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
 154 }
 155
 156 =item search_related
 157
 158   My::Table->search_related('relname', $cond, $attrs);
 159
 160 =cut
 161
 162 sub search_related {
 163   my $self = shift;
 164   return $self->_query_related('search', @_);
 165 }
 166
 167 =item count_related
 168
 169   My::Table->count_related('relname', $cond, $attrs);
 170
 171 =cut
 172
 173 sub count_related {
 174   my $self = shift;
 175   return $self->_query_related('count', @_);
 176 }
 177
 178 sub _query_related {
 179   my $self = shift;
 180   my $meth = shift;
 181   my $rel = shift;
 182   my $attrs = { };
 183   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 184     $attrs = { %{ pop(@_) } };
 185   }
 186   my $rel_obj = $self->_relationships->{$rel};
 187   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 188   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 189
 190   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 191   my $query = ((@_ > 1) ? {@_} : shift);
 192
 193   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 194                                  # to merge into the AST really?
 195   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
 196   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 197   #use Data::Dumper; warn Dumper($query);
 198   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 199   delete $attrs->{_action};
 200   return $self->resolve_class($rel_obj->{class}
 201            )->$meth($query, $attrs);
 202 }
 203
 204 =item create_related
 205
 206   My::Table->create_related('relname', \%col_data);
 207
 208 =cut
 209
 210 sub create_related {
 211   my $class = shift;
 212   return $class->new_related(@_)->insert;
 213 }
 214
 215 =item new_related
 216
 217   My::Table->new_related('relname', \%col_data);
 218
 219 =cut
 220
 221 sub new_related {
 222   my ($self, $rel, $values, $attrs) = @_;
 223   $self->throw( "Can't call new_related as class method" )
 224     unless ref $self;
 225   $self->throw( "new_related needs a hash" )
 226     unless (ref $values eq 'HASH');
 227   my $rel_obj = $self->_relationships->{$rel};
 228   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 229   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 230     unless ref $rel_obj->{cond} eq 'HASH';
 231   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 232
 233   my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
 234   $fields{$_} = $values->{$_} for keys %$values;
 235
 236   return $self->resolve_class($rel_obj->{class})->new(\%fields);
 237 }
 238
 239 =item find_related
 240
 241   My::Table->find_related('relname', @pri_vals | \%pri_vals);
 242
 243 =cut
 244
 245 sub find_related {
 246   my $self = shift;
 247   my $rel = shift;
 248   my $rel_obj = $self->_relationships->{$rel};
 249   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 250   my ($cond) = $self->resolve_condition($rel_obj->{cond}, { _action => 'convert' });
 251   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 252   my $attrs = { };
 253   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 254     $attrs = { %{ pop(@_) } };
 255   }
 256   my $query = ((@_ > 1) ? {@_} : shift);
 257   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 258   return $self->resolve_class($rel_obj->{class})->find($query);
 259 }
 260
 261 =item find_or_create_related
 262
 263   My::Table->find_or_create_related('relname', \%col_data);
 264
 265 =cut
 266
 267 sub find_or_create_related {
 268   my $self = shift;
 269   return $self->find_related(@_) || $self->create_related(@_);
 270 }
 271
 272 =item set_from_related
 273
 274   My::Table->set_from_related('relname', $rel_obj);
 275
 276 =cut
 277
 278 sub set_from_related {
 279   my ($self, $rel, $f_obj) = @_;
 280   my $rel_obj = $self->_relationships->{$rel};
 281   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 282   my $cond = $rel_obj->{cond};
 283   $self->throw( "set_from_related can only handle a hash condition; the "
 284     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 285       unless ref $cond eq 'HASH';
 286   my $f_class = $self->resolve_class($rel_obj->{class});
 287   $self->throw( "Object $f_obj isn't a ".$f_class )
 288     unless $f_obj->isa($f_class);
 289   foreach my $key (keys %$cond) {
 290     next if ref $cond->{$key}; # Skip literals and complex conditions
 291     $self->throw("set_from_related can't handle $key as key")
 292       unless $key =~ m/^foreign\.([^\.]+)$/;
 293     my $val = $f_obj->get_column($1);
 294     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 295       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 296     $self->set_column($1 => $val);
 297   }
 298   return 1;
 299 }
 300
 301 =item update_from_related
 302
 303   My::Table->update_from_related('relname', $rel_obj);
 304
 305 =cut
 306
 307 sub update_from_related {
 308   my $self = shift;
 309   $self->set_from_related(@_);
 310   $self->update;
 311 }
 312
 313 =item delete_related
 314
 315   My::Table->delete_related('relname', $cond, $attrs);
 316
 317 =cut
 318
 319 sub delete_related {
 320   my $self = shift;
 321   return $self->search_related(@_)->delete;
 322 }
 323
 324 1;
 325
 326 =back
 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