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