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