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