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) = @_;
 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     return $key;
 149   } elsif ($action eq 'join') {
 150     return $key unless $key =~ /\./;
 151     my ($type, $field) = split(/\./, $key);
 152     if (my $alias = $attrs->{_aliases}{$type}) {
 153       my $class = $attrs->{_classes}{$alias};
 154       $self->throw("Unknown column $field on $class as $alias")
 155         unless $class->has_column($field);
 156       return join('.', $alias, $field);
 157     } else {
 158       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 159             join(', ', keys %{$attrs->{_aliases} || {}}) );
 160     }
 161   }
 162   return $self->next::method($attrs, $key);
 163 }
 164
 165 sub _cond_value {
 166   my ($self, $attrs, $key, $value) = @_;
 167   my $action = $attrs->{_action} || '';
 168   if ($action eq 'convert') {
 169     unless ($value =~ s/^self\.//) {
 170       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
 171     }
 172     unless ($self->has_column($value)) {
 173       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
 174     }
 175     return $self->get_column($value);
 176   } elsif ($action eq 'join') {
 177     return $key unless $key =~ /\./;
 178     my ($type, $field) = split(/\./, $value);
 179     if (my $alias = $attrs->{_aliases}{$type}) {
 180       my $class = $attrs->{_classes}{$alias};
 181       $self->throw("Unknown column $field on $class as $alias")
 182         unless $class->has_column($field);
 183       return join('.', $alias, $field);
 184     } else {
 185       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 186             join(', ', keys %{$attrs->{_aliases} || {}}) );
 187     }
 188   }
 189
 190   return $self->next::method($attrs, $key, $value)
 191 }
 192
 193 =head2 search_related
 194
 195   My::Table->search_related('relname', $cond, $attrs);
 196
 197 =cut
 198
 199 sub search_related {
 200   my $self = shift;
 201   return $self->_query_related('search', @_);
 202 }
 203
 204 =head2 count_related
 205
 206   My::Table->count_related('relname', $cond, $attrs);
 207
 208 =cut
 209
 210 sub count_related {
 211   my $self = shift;
 212   return $self->_query_related('count', @_);
 213 }
 214
 215 sub _query_related {
 216   my $self = shift;
 217   my $meth = shift;
 218   my $rel = shift;
 219   my $attrs = { };
 220   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 221     $attrs = { %{ pop(@_) } };
 222   }
 223   my $rel_obj = $self->_relationships->{$rel};
 224   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 225   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 226
 227   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 228   my $query = ((@_ > 1) ? {@_} : shift);
 229
 230   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 231                                  # to merge into the AST really?
 232   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
 233   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 234   #use Data::Dumper; warn Dumper($query);
 235   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 236   delete $attrs->{_action};
 237   return $self->resolve_class($rel_obj->{class}
 238            )->$meth($query, $attrs);
 239 }
 240
 241 =head2 create_related
 242
 243   My::Table->create_related('relname', \%col_data);
 244
 245 =cut
 246
 247 sub create_related {
 248   my $class = shift;
 249   return $class->new_related(@_)->insert;
 250 }
 251
 252 =head2 new_related
 253
 254   My::Table->new_related('relname', \%col_data);
 255
 256 =cut
 257
 258 sub new_related {
 259   my ($self, $rel, $values, $attrs) = @_;
 260   $self->throw( "Can't call new_related as class method" )
 261     unless ref $self;
 262   $self->throw( "new_related needs a hash" )
 263     unless (ref $values eq 'HASH');
 264   my $rel_obj = $self->_relationships->{$rel};
 265   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 266   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 267     unless ref $rel_obj->{cond} eq 'HASH';
 268   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 269
 270   my %fields = %{$self->resolve_condition($rel_obj->{cond},$attrs)};
 271   $fields{$_} = $values->{$_} for keys %$values;
 272
 273   return $self->resolve_class($rel_obj->{class})->new(\%fields);
 274 }
 275
 276 =head2 find_related
 277
 278   My::Table->find_related('relname', @pri_vals | \%pri_vals);
 279
 280 =cut
 281
 282 sub find_related {
 283   my $self = shift;
 284   my $rel = shift;
 285   my $rel_obj = $self->_relationships->{$rel};
 286   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 287   my ($cond) = $self->resolve_condition($rel_obj->{cond}, { _action => 'convert' });
 288   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 289   my $attrs = { };
 290   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 291     $attrs = { %{ pop(@_) } };
 292   }
 293   my $query = ((@_ > 1) ? {@_} : shift);
 294   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 295   return $self->resolve_class($rel_obj->{class})->find($query);
 296 }
 297
 298 =head2 find_or_create_related
 299
 300   My::Table->find_or_create_related('relname', \%col_data);
 301
 302 =cut
 303
 304 sub find_or_create_related {
 305   my $self = shift;
 306   return $self->find_related(@_) || $self->create_related(@_);
 307 }
 308
 309 =head2 set_from_related
 310
 311   My::Table->set_from_related('relname', $rel_obj);
 312
 313 =cut
 314
 315 sub set_from_related {
 316   my ($self, $rel, $f_obj) = @_;
 317   my $rel_obj = $self->_relationships->{$rel};
 318   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 319   my $cond = $rel_obj->{cond};
 320   $self->throw( "set_from_related can only handle a hash condition; the "
 321     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 322       unless ref $cond eq 'HASH';
 323   my $f_class = $self->resolve_class($rel_obj->{class});
 324   $self->throw( "Object $f_obj isn't a ".$f_class )
 325     unless $f_obj->isa($f_class);
 326   foreach my $key (keys %$cond) {
 327     next if ref $cond->{$key}; # Skip literals and complex conditions
 328     $self->throw("set_from_related can't handle $key as key")
 329       unless $key =~ m/^foreign\.([^\.]+)$/;
 330     my $val = $f_obj->get_column($1);
 331     $self->throw("set_from_related can't handle ".$cond->{$key}." as value")
 332       unless $cond->{$key} =~ m/^self\.([^\.]+)$/;
 333     $self->set_column($1 => $val);
 334   }
 335   return 1;
 336 }
 337
 338 =head2 update_from_related
 339
 340   My::Table->update_from_related('relname', $rel_obj);
 341
 342 =cut
 343
 344 sub update_from_related {
 345   my $self = shift;
 346   $self->set_from_related(@_);
 347   $self->update;
 348 }
 349
 350 =head2 delete_related
 351
 352   My::Table->delete_related('relname', $cond, $attrs);
 353
 354 =cut
 355
 356 sub delete_related {
 357   my $self = shift;
 358   return $self->search_related(@_)->delete;
 359 }
 360
 361 1;
 362
 363 =head1 AUTHORS
 364
 365 Matt S. Trout <mst@shadowcatsystems.co.uk>
 366
 367 =head1 LICENSE
 368
 369 You may distribute this code under the same terms as Perl itself.
 370
 371 =cut
 372