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