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   shift->result_source->add_relationship(@_);
  76 }
  77
  78 sub relationships {
  79   shift->result_source->relationships(@_);
  80 }
  81
  82 sub relationship_info {
  83   shift->result_source->relationship_info(@_);
  84 }
  85
  86 sub _resolve_join {
  87   my ($class, $join, $alias) = @_;
  88   if (ref $join eq 'ARRAY') {
  89     return map { $class->_resolve_join($_, $alias) } @$join;
  90   } elsif (ref $join eq 'HASH') {
  91     return map { $class->_resolve_join($_, $alias),
  92                  $class->relationship_info($_)->{class}->_resolve_join($join->{$_}, $_) }
  93            keys %$join;
  94   } elsif (ref $join) {
  95     $class->throw("No idea how to resolve join reftype ".ref $join);
  96   } else {
  97     my $rel_obj = $class->relationship_info($join);
  98     #use Data::Dumper; warn Dumper($class->result_source) unless $rel_obj;
  99     $class->throw("No such relationship ${join}") unless $rel_obj;
 100     my $j_class = $rel_obj->{class};
 101     my %join = (_action => 'join',
 102          _aliases => { 'self' => $alias, 'foreign' => $join },
 103          _classes => { $alias => $class, $join => $j_class });
 104     my $j_cond = $j_class->resolve_condition($rel_obj->{cond}, \%join);
 105     return [ { $join => $j_class->_table_name,
 106                -join_type => $rel_obj->{attrs}{join_type} || '' }, $j_cond ];
 107   }
 108 }
 109
 110 sub resolve_condition {
 111   my ($self, $cond, $attrs) = @_;
 112   if (ref $cond eq 'HASH') {
 113     my %ret;
 114     foreach my $key (keys %$cond) {
 115       my $val = $cond->{$key};
 116       if (ref $val) {
 117         $self->throw("Can't handle this yet :(");
 118       } else {
 119         $ret{$self->_cond_key($attrs => $key)}
 120           = $self->_cond_value($attrs => $key => $val);
 121       }
 122     }
 123     return \%ret;
 124   } else {
 125    $self->throw("Can't handle this yet :(");
 126   }
 127 }
 128
 129 sub _cond_key {
 130   my ($self, $attrs, $key, $alias) = @_;
 131   my $action = $attrs->{_action} || '';
 132   if ($action eq 'convert') {
 133     unless ($key =~ s/^foreign\.//) {
 134       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
 135     }
 136     if (defined (my $alias = $attrs->{_aliases}{foreign})) {
 137       return "${alias}.${key}";
 138     } else {
 139       return $key;
 140     }
 141   } elsif ($action eq 'join') {
 142     return $key unless $key =~ /\./;
 143     my ($type, $field) = split(/\./, $key);
 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   return $self->next::method($attrs, $key);
 155 }
 156
 157 sub _cond_value {
 158   my ($self, $attrs, $key, $value) = @_;
 159   my $action = $attrs->{_action} || '';
 160   if ($action eq 'convert') {
 161     unless ($value =~ s/^self\.//) {
 162       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
 163     }
 164     unless ($self->has_column($value)) {
 165       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
 166     }
 167     return $self->get_column($value);
 168   } elsif ($action eq 'join') {
 169     return $key unless $key =~ /\./;
 170     my ($type, $field) = split(/\./, $value);
 171     if (my $alias = $attrs->{_aliases}{$type}) {
 172       my $class = $attrs->{_classes}{$alias};
 173       $self->throw("Unknown column $field on $class as $alias")
 174         unless $class->has_column($field);
 175       return join('.', $alias, $field);
 176     } else {
 177       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
 178             join(', ', keys %{$attrs->{_aliases} || {}}) );
 179     }
 180   }
 181
 182   return $self->next::method($attrs, $key, $value)
 183 }
 184
 185 =head2 search_related
 186
 187   My::Table->search_related('relname', $cond, $attrs);
 188
 189 =cut
 190
 191 sub search_related {
 192   my $self = shift;
 193   my $rel = shift;
 194   my $attrs = { };
 195   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 196     $attrs = { %{ pop(@_) } };
 197   }
 198   my $rel_obj = $self->relationship_info($rel);
 199   $self->throw( "No such relationship ${rel}" ) unless $rel_obj;
 200   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 201
 202   $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 203   my $query = ((@_ > 1) ? {@_} : shift);
 204
 205   $attrs->{_action} = 'convert'; # shouldn't we resolve the cond to something
 206                                  # to merge into the AST really?
 207   my ($cond) = $self->resolve_condition($rel_obj->{cond}, $attrs);
 208   $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 209   #use Data::Dumper; warn Dumper($query);
 210   #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 211   delete $attrs->{_action};
 212   return $self->result_source->schema->resultset($rel_obj->{class}
 213            )->search($query, $attrs);
 214 }
 215
 216 =head2 count_related
 217
 218   My::Table->count_related('relname', $cond, $attrs);
 219
 220 =cut
 221
 222 sub count_related {
 223   my $self = shift;
 224   return $self->search_related(@_)->count;
 225 }
 226
 227 =head2 create_related
 228
 229   My::Table->create_related('relname', \%col_data);
 230
 231 =cut
 232
 233 sub create_related {
 234   my $class = shift;
 235   my $rel = shift;
 236   return $class->search_related($rel)->create(@_);
 237 }
 238
 239 =head2 new_related
 240
 241   My::Table->new_related('relname', \%col_data);
 242
 243 =cut
 244
 245 sub new_related {
 246   my ($self, $rel, $values, $attrs) = @_;
 247   return $self->search_related($rel)->new($values, $attrs);
 248 }
 249
 250 =head2 find_related
 251
 252   My::Table->find_related('relname', @pri_vals | \%pri_vals);
 253
 254 =cut
 255
 256 sub find_related {
 257   my $self = shift;
 258   my $rel = shift;
 259   return $self->search_related($rel)->find(@_);
 260 }
 261
 262 =head2 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 =head2 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->relationship_info($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->result_source->schema->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 =head2 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 =head2 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 =head1 AUTHORS
 328
 329 Matt S. Trout <mst@shadowcatsystems.co.uk>
 330
 331 =head1 LICENSE
 332
 333 You may distribute this code under the same terms as Perl itself.
 334
 335 =cut
 336