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 sub add_relationship {
  11   my ($class, $rel, $f_class, $cond, $attrs) = @_;
  12   my %rels = %{ $class->_relationships };
  13   $rels{$rel} = { class => $f_class,
  14                   cond  => $cond,
  15                   attrs => $attrs };
  16   $class->_relationships(\%rels);
  17 }
  18
  19 sub _cond_key {
  20   my ($self, $attrs, $key) = @_;
  21   my $action = $attrs->{_action} || '';
  22   if ($action eq 'convert') {
  23     unless ($key =~ s/^foreign\.//) {
  24       die "Unable to convert relationship to WHERE clause: invalid key ${key}";
  25     }
  26     return $key;
  27   } elsif ($action eq 'join') {
  28     my ($type, $field) = split(/\./, $key);
  29     if ($attrs->{_aliases}{$type}) {
  30       return join('.', $attrs->{_aliases}{$type}, $field);
  31     } else {
  32       die "Unable to resolve type ${type}: only have aliases for ".
  33             join(', ', keys %{$attrs->{_aliases}{$type} || {}});
  34     }
  35   }
  36   return $self->NEXT::ACTUAL::_cond_key($attrs, $key);
  37 }
  38
  39 sub _cond_value {
  40   my ($self, $attrs, $key, $value) = @_;
  41   my $action = $attrs->{_action} || '';
  42   if ($action eq 'convert') {
  43     unless ($value =~ s/^self\.//) {
  44       die "Unable to convert relationship to WHERE clause: invalid value ${value}";
  45     }
  46     unless ($self->_columns->{$value}) {
  47       die "Unable to convert relationship to WHERE clause: no such accessor ${value}";
  48     }
  49     push(@{$attrs->{bind}}, $self->get_column($value));
  50     return '?';
  51   } elsif ($action eq 'join') {
  52     my ($type, $field) = split(/\./, $value);
  53     if ($attrs->{_aliases}{$type}) {
  54       return join('.', $attrs->{_aliases}{$type}, $field);
  55     } else {
  56       die "Unable to resolve type ${type}: only have aliases for ".
  57             join(', ', keys %{$attrs->{_aliases}{$type} || {}});
  58     }
  59   }
  60
  61   return $self->NEXT::ACTUAL::_cond_value($attrs, $key, $value)
  62 }
  63
  64 sub search_related {
  65   my $self = shift;
  66   my $rel = shift;
  67   my $attrs = { };
  68   if (@_ > 1 && ref $_[$#_] eq 'HASH') {
  69     $attrs = { %{ pop(@_) } };
  70   }
  71   my $rel_obj = $self->_relationships->{$rel};
  72   die "No such relationship ${rel}" unless $rel;
  73   $attrs = { %{$rel_obj->{attrs} || {}}, %{$attrs || {}} };
  74   my $s_cond;
  75   if (@_) {
  76     die "Invalid query: @_" if (@_ > 1 && (@_ % 2 == 1));
  77     my $query = ((@_ > 1) ? {@_} : shift);
  78     $s_cond = $self->_cond_resolve($query, $attrs);
  79   }
  80   $attrs->{_action} = 'convert';
  81   my ($cond) = $self->_cond_resolve($rel_obj->{cond}, $attrs);
  82   $cond = "${s_cond} AND ${cond}" if $s_cond;
  83   return $rel_obj->{class}->retrieve_from_sql($cond, @{$attrs->{bind} || []},
  84                                                 $attrs);
  85 }
  86
  87 sub create_related {
  88   my ($self, $rel, $values, $attrs) = @_;
  89   die "Can't call create_related as class method" unless ref $self;
  90   die "create_related needs a hash" unless (ref $values eq 'HASH');
  91   my $rel_obj = $self->_relationships->{$rel};
  92   die "No such relationship ${rel}" unless $rel;
  93   die "Can't abstract implicit create for ${rel}, condition not a hash"
  94     unless ref $rel_obj->{cond} eq 'HASH';
  95   $attrs = { %{$rel_obj->{attrs}}, %{$attrs || {}}, _action => 'convert' };
  96   my %fields = %$values;
  97   while (my ($k, $v) = each %{$rel_obj->{cond}}) {
  98     $self->_cond_value($attrs, $k => $v);
  99     $fields{$self->_cond_key($attrs, $k)} = (@{delete $attrs->{bind}})[0];
 100   }
 101   return $rel_obj->{class}->create(\%fields);
 102 }
 103
 104 1;