lib/DBIx/Class/CDBICompat/HasMany.pm

   1 package DBIx::Class::CDBICompat::HasMany;
   2
   3 use strict;
   4 use warnings;
   5
   6 sub has_many {
   7   my ($class, $rel, $f_class, $f_key, $args) = @_;
   8   #die "No such column ${col}" unless $class->_columns->{$col};
   9   eval "require $f_class";
  10   my ($pri, $too_many) = keys %{ $class->_primaries };
  11   die "has_many only works with a single primary key; ${class} has more"
  12     if $too_many;
  13   if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; };
  14   unless ($f_key) {
  15     ($f_key) = grep { $f_class && $_->{class} eq $class }
  16                  $f_class->_relationships;
  17   }
  18   die "Unable to resolve foreign key for has_many from ${class} to ${f_class}"
  19     unless $f_key;
  20   die "No such column ${f_key} on foreign class ${f_class}"
  21     unless $f_class->_columns->{$f_key};
  22   $class->add_relationship($rel, $f_class,
  23                             { "foreign.${f_key}" => "self.${pri}" },
  24                             { _type => 'has_many', %{$args || {}} } );
  25   {
  26     no strict 'refs';
  27     *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); };
  28     *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); };
  29   }
  30   return 1;
  31 }
  32
  33 sub delete {
  34   my ($self, @rest) = @_;
  35   return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
  36     # I'm just ignoring this for class deletes because hell, the db should
  37     # be handling this anyway. Assuming we have joins we probably actually
  38     # *could* do them, but I'd rather not.
  39
  40   my $ret = $self->NEXT::ACTUAL::delete(@rest);
  41
  42   my %rels = %{ $self->_relationships };
  43   my @hm = grep { $rels{$_}{attrs}{_type}
  44                    && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
  45   foreach my $has_many (@hm) {
  46     $_->delete for $self->search_related($has_many);
  47   }
  48   return $ret;
  49 }
  50 1;