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