lib/DBIx/Class/Relationship/CascadeActions.pm

   1 package # hide from PAUSE
   2     DBIx::Class::Relationship::CascadeActions;
   3
   4 use strict;
   5 use warnings;
   6
   7 our %_pod_inherit_config =
   8   (
   9    class_map => { 'DBIx::Class::Relationship::CascadeActions' => 'DBIx::Class::Relationship' }
  10   );
  11
  12 sub delete {
  13   my ($self, @rest) = @_;
  14   return $self->next::method(@rest) unless ref $self;
  15     # I'm just ignoring this for class deletes because hell, the db should
  16     # be handling this anyway. Assuming we have joins we probably actually
  17     # *could* do them, but I'd rather not.
  18
  19   my $ret = $self->next::method(@rest);
  20
  21   my $source = $self->result_source;
  22   my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
  23   my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
  24   foreach my $rel (@cascade) {
  25     $self->search_related($rel)->delete_all;
  26   }
  27   return $ret;
  28 }
  29
  30 sub update {
  31   my ($self, @rest) = @_;
  32   return $self->next::method(@rest) unless ref $self;
  33     # Because update cascades on a class *really* don't make sense!
  34
  35   my $ret = $self->next::method(@rest);
  36
  37   my $source = $self->result_source;
  38   my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
  39   my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
  40   foreach my $rel (@cascade) {
  41     next if (
  42       $rels{$rel}{attrs}{accessor}
  43         &&
  44       $rels{$rel}{attrs}{accessor} eq 'single'
  45         &&
  46       !exists($self->{_relationship_data}{$rel})
  47     );
  48     $_->update for grep defined, $self->$rel;
  49   }
  50   return $ret;
  51 }
  52
  53 1;