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