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