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
   9   my $self_key;
  10
  11   if (ref $f_class eq 'ARRAY') {
  12     ($f_class, $self_key) = @$f_class;
  13   }
  14
  15   if (!$self_key || $self_key eq 'id') {
  16     my ($pri, $too_many) = keys %{ $class->_primaries };
  17     $class->throw( "has_many only works with a single primary key; ${class} has more" )
  18       if $too_many;
  19     $self_key = $pri;
  20   }
  21
  22   eval "require $f_class";
  23
  24   if (ref $f_key eq 'HASH') { $args = $f_key; undef $f_key; };
  25
  26   #unless ($f_key) { Not selective enough. Removed pending fix.
  27   #  ($f_rel) = grep { $_->{class} && $_->{class} eq $class }
  28   #               $f_class->_relationships;
  29   #}
  30
  31   unless ($f_key) {
  32     #warn join(', ', %{ $f_class->_columns });
  33     $class =~ /([^\:]+)$/;
  34     #warn $1;
  35     $f_key = lc $1 if $f_class->_columns->{lc $1};
  36   }
  37
  38   $class->throw( "Unable to resolve foreign key for has_many from ${class} to ${f_class}" )
  39     unless $f_key;
  40   $class->throw( "No such column ${f_key} on foreign class ${f_class}" )
  41     unless $f_class->_columns->{$f_key};
  42   $class->add_relationship($rel, $f_class,
  43                             { "foreign.${f_key}" => "self.${self_key}" },
  44                             { _type => 'has_many', %{$args || {}} } );
  45   {
  46     no strict 'refs';
  47     *{"${class}::${rel}"} = sub { shift->search_related($rel, @_); };
  48     *{"${class}::add_to_${rel}"} = sub { shift->create_related($rel, @_); };
  49   }
  50   return 1;
  51 }
  52
  53 sub delete {
  54   my ($self, @rest) = @_;
  55   return $self->NEXT::ACTUAL::delete(@rest) unless ref $self;
  56     # I'm just ignoring this for class deletes because hell, the db should
  57     # be handling this anyway. Assuming we have joins we probably actually
  58     # *could* do them, but I'd rather not.
  59
  60   my $ret = $self->NEXT::ACTUAL::delete(@rest);
  61
  62   my %rels = %{ $self->_relationships };
  63   my @hm = grep { $rels{$_}{attrs}{_type}
  64                    && $rels{$_}{attrs}{_type} eq 'has_many' } keys %rels;
  65   foreach my $has_many (@hm) {
  66     unless ($rels{$has_many}->{attrs}{no_cascade_delete}) {
  67       $_->delete for $self->search_related($has_many)
  68     }
  69   }
  70   return $ret;
  71 }
  72 1;