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