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