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