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       die "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       die "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       die "Unable to convert relationship to WHERE clause: invalid value ${value}";
  63     }
  64     unless ($self->_columns->{$value}) {
  65       die "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       die "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   die "No such relationship ${rel}" unless $rel;
  91   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
  92   my $s_cond;
  93   if (@_) {
  94     die "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   die "Can't call create_related as class method" unless ref $self;
 108   die "create_related needs a hash" unless (ref $values eq 'HASH');
 109   my $rel_obj = $self->_relationships->{$rel};
 110   die "No such relationship ${rel}" unless $rel;
 111   die "Can't abstract implicit create for ${rel}, condition not a hash"
 112     unless ref $rel_obj->{cond} eq 'HASH';
 113   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
 114   my %fields = %$values;
 115   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
 116     $self->_cond_value($attrs, $k => $v);
 117     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
 118   }
 119   return $rel_obj->{class}->create(\%fields);
 120 }
 121
 122 1;
 123
 124 =back
 125
 126 =head1 AUTHORS
 127
 128 Matt S. Trout <perl-stuff@trout.me.uk>
 129
 130 =head1 LICENSE
 131
 132 You may distribute this code under the same terms as Perl itself.
 133
 134 =cut
 135