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