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 =head2 register_relationship($relname, $rel_info)
  73
  74 Registers a relationship on the class
  75
  76 =cut
  77
  78 sub register_relationship { }
  79
  80 =head2 search_related
  81
  82   My::Table->search_related('relname', $cond, $attrs);
  83
  84 =cut
  85
  86 sub search_related {
  87   return shift->related_resultset(shift)->search(@_);
  88 }
  89
  90 =head2 count_related
  91
  92   $obj->count_related('relname', $cond, $attrs);
  93
  94 =cut
  95
  96 sub count_related {
  97   my $self = shift;
  98   return $self->search_related(@_)->count;
  99 }
 100
 101 =head2 create_related
 102
 103   My::Table->create_related('relname', \%col_data);
 104
 105 =cut
 106
 107 sub create_related {
 108   my $self = shift;
 109   my $rel = shift;
 110   my $obj = $self->search_related($rel)->create(@_);
 111   delete $self->{related_resultsets}->{$rel};
 112   return $obj;
 113 }
 114
 115 =head2 new_related
 116
 117   My::Table->new_related('relname', \%col_data);
 118
 119 =cut
 120
 121 sub new_related {
 122   my ($self, $rel, $values, $attrs) = @_;
 123   return $self->search_related($rel)->new($values, $attrs);
 124 }
 125
 126 =head2 find_related
 127
 128   My::Table->find_related('relname', @pri_vals | \%pri_vals);
 129
 130 =cut
 131
 132 sub find_related {
 133   my $self = shift;
 134   my $rel = shift;
 135   return $self->search_related($rel)->find(@_);
 136 }
 137
 138 =head2 find_or_create_related
 139
 140   My::Table->find_or_create_related('relname', \%col_data);
 141
 142 =cut
 143
 144 sub find_or_create_related {
 145   my $self = shift;
 146   return $self->find_related(@_) || $self->create_related(@_);
 147 }
 148
 149 =head2 set_from_related
 150
 151   My::Table->set_from_related('relname', $rel_obj);
 152
 153 =cut
 154
 155 sub set_from_related {
 156   my ($self, $rel, $f_obj) = @_;
 157   my $rel_obj = $self->relationship_info($rel);
 158   $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
 159   my $cond = $rel_obj->{cond};
 160   $self->throw_exception( "set_from_related can only handle a hash condition; the "
 161     ."condition for $rel is of type ".(ref $cond ? ref $cond : 'plain scalar'))
 162       unless ref $cond eq 'HASH';
 163   my $f_class = $self->result_source->schema->class($rel_obj->{class});
 164   $self->throw_exception( "Object $f_obj isn't a ".$f_class )
 165     unless $f_obj->isa($f_class);
 166   $self->set_columns(
 167     $self->result_source->resolve_condition(
 168        $rel_obj->{cond}, $f_obj, $rel));
 169   return 1;
 170 }
 171
 172 =head2 update_from_related
 173
 174   My::Table->update_from_related('relname', $rel_obj);
 175
 176 =cut
 177
 178 sub update_from_related {
 179   my $self = shift;
 180   $self->set_from_related(@_);
 181   $self->update;
 182 }
 183
 184 =head2 delete_related
 185
 186   My::Table->delete_related('relname', $cond, $attrs);
 187
 188 =cut
 189
 190 sub delete_related {
 191   my $self = shift;
 192   my $obj = $self->search_related(@_)->delete;
 193   delete $self->{related_resultsets}->{$_[0]};
 194   return $obj;
 195 }
 196
 197 1;
 198
 199 =head2 related_resultset($name)
 200
 201 Returns a L<DBIx::Class::ResultSet> for the relationship named $name.
 202
 203   $rs = My::Table->related_resultset('related_table');
 204
 205 =cut
 206
 207 sub related_resultset {
 208   my $self = shift;
 209   $self->throw_exception("Can't call *_related as class methods") unless ref $self;
 210   my $rel = shift;
 211   $self->{related_resultsets} ||= {};
 212   #use Data::Dumper; warn "related_resultsets: ", Dumper $self->{related_resultsets};
 213   my $resultsets = $self->{related_resultsets};
 214   if( !exists $resultsets->{$rel} ) {
 215
 216     #warn "creating related resultset for relation '$rel'", \$self;
 217     my $source = $self->result_source;
 218     # if relation exists but resultset doesn't, create the resultset
 219
 220     my $attrs = { };
 221     if (@_ > 1 && ref $_[$#_] eq 'HASH') {
 222       $attrs = { %{ pop(@_) } };
 223     }
 224
 225     my $rel_obj = $self->relationship_info($rel);
 226     $self->throw_exception( "No such relationship ${rel}" ) unless $rel_obj;
 227     $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
 228
 229     $self->throw_exception( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
 230     my $query = ((@_ > 1) ? {@_} : shift);
 231
 232     my ($cond) = $self->result_source->resolve_condition($rel_obj->{cond}, $rel, $self);
 233     if (ref $cond eq 'ARRAY') {
 234       $cond = [ map { my %hash;
 235         foreach my $key (keys %{$_}) {
 236           unless ($key =~ m/\./) {
 237             $hash{"me.$key"} = $_->{$key};
 238           } else {
 239            $hash{$key} = $_->{$key};
 240           }
 241         }; \%hash; } @$cond ];
 242       } else {
 243       foreach my $key (keys %$cond) {
 244         unless ($key =~ m/\./) {
 245           $cond->{"me.$key"} = delete $cond->{$key};
 246         }
 247       }
 248     }
 249     $query = ($query ? { '-and' => [ $cond, $query ] } : $cond);
 250     #use Data::Dumper; warn Dumper($cond);
 251     #warn $rel_obj->{class}." $meth $cond ".join(', ', @{$attrs->{bind}||[]});
 252     $resultsets->{$rel} =
 253       $self->result_source->related_source($rel)->resultset->search($query, $attrs);
 254   }
 255   return $resultsets->{$rel};
 256 }
 257
 258 =head1 AUTHORS
 259
 260 Matt S. Trout <mst@shadowcatsystems.co.uk>
 261
 262 =head1 LICENSE
 263
 264 You may distribute this code under the same terms as Perl itself.
 265
 266 =cut
 267