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