lib/DBIx/Class/Relationship.pm

   1 package DBIx::Class::Relationship;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/Class::Data::Inheritable/;
   7
   8 __PACKAGE__->mk_classdata('_relationships', { } );
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Relationship - 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 =over 4
  25
  26 =cut
  27
  28 sub add_relationship {
  29   my ($class, $rel, $f_class, $cond, $attrs) = @_;
  30   die "Can't create relationship without join condition" unless $cond;
  31   my %rels = %{ $class->_relationships };
  32   $rels{$rel} = { class => $f_class,
  33                   cond  => $cond,
  34                   attrs => $attrs };
  35   $class->_relationships(\%rels);
  36 }
  37
  38 sub _cond_key {
  39   my ($self, $attrs, $key) = @_;
  40   my $action = $attrs->{_action} || '';
  41   if ($action eq 'convert') {
  42     unless ($key =~ s/^foreign\.//) {
  43       $self->throw("Unable to convert relationship to WHERE clause: invalid key ${key}");
  44     }
  45     return $key;
  46   } elsif ($action eq 'join') {
  47     my ($type, $field) = split(/\./, $key);
  48     if ($attrs->{_aliases}{$type}) {
  49       return join('.', $attrs->{_aliases}{$type}, $field);
  50     } else {
  51       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
  52             join(', ', keys %{$attrs->{_aliases}{$type} || {}}) );
  53     }
  54   }
  55   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
  56 }
  57
  58 sub _cond_value {
  59   my ($self, $attrs, $key, $value) = @_;
  60   my $action = $attrs->{_action} || '';
  61   if ($action eq 'convert') {
  62     unless ($value =~ s/^self\.//) {
  63       $self->throw( "Unable to convert relationship to WHERE clause: invalid value ${value}" );
  64     }
  65     unless ($self->_columns->{$value}) {
  66       $self->throw( "Unable to convert relationship to WHERE clause: no such accessor ${value}" );
  67     }
  68     push(@{$attrs->{bind}}, $self->get_column($value));
  69     return '?';
  70   } elsif ($action eq 'join') {
  71     my ($type, $field) = split(/\./, $value);
  72     if ($attrs->{_aliases}{$type}) {
  73       return join('.', $attrs->{_aliases}{$type}, $field);
  74     } else {
  75       $self->throw( "Unable to resolve type ${type}: only have aliases for ".
  76             join(', ', keys %{$attrs->{_aliases}{$type} || {}}) );
  77     }
  78   }
  79
  80   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
  81 }
  82
  83 sub search_related {
  84   my $self = shift;
  85   my $rel = shift;
  86   my $attrs = { };
  87   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
  88     $attrs = { %{ pop(@_) } };
  89   }
  90   my $rel_obj = $self->_relationships->{$rel};
  91   $self->throw( "No such relationship ${rel}" ) unless $rel;
  92   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
  93   my $s_cond;
  94   if (@_) {
  95     $self->throw( "Invalid query: @_" ) if (@_ > 1 && (@_ % 2 == 1));
  96     my $query = ((@_ > 1) ? {@_} : shift);
  97     $s_cond = $self->_cond_resolve($query, $attrs);
  98   }
  99   $attrs->{_action} = 'convert';
 100   my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
 101   $cond = "${s_cond} AND ${cond}" if $s_cond;
 102   return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || []},
 103                                                 $attrs);
 104 }
 105
 106 sub create_related {
 107   my ($self, $rel, $values, $attrs) = @_;
 108   $self->throw( "Can't call create_related as class method" )
 109     unless ref $self;
 110   $self->throw( "create_related needs a hash" )
 111     unless (ref $values eq 'HASH');
 112   my $rel_obj = $self->_relationships->{$rel};
 113   $self->throw( "No such relationship ${rel}" ) unless $rel;
 114   $self->throw( "Can't abstract implicit create for ${rel}, condition not a hash" )
 115     unless ref $rel_obj->{cond} eq 'HASH';
 116   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 117   my %fields = %$values;
 118   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
 119     $self->_cond_value($attrs, $k => $v);
 120     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
 121   }
 122   return $rel_obj->{class}->create(\%fields);
 123 }
 124
 125 1;
 126
 127 =back
 128
 129 =head1 AUTHORS
 130
 131 Matt S. Trout <perl-stuff@trout.me.uk>
 132
 133 =head1 LICENSE
 134
 135 You may distribute this code under the same terms as Perl itself.
 136
 137 =cut
 138