lib/DBIx/Class/Relationship/CascadeActions.pm

   1 package # hide from PAUSE
   2     DBIx::Class::Relationship::CascadeActions;
   3
   4 use strict;
   5 use warnings;
   6 use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
   7 use namespace::clean;
   8
   9 our %_pod_inherit_config =
  10   (
  11    class_map => { 'DBIx::Class::Relationship::CascadeActions' => 'DBIx::Class::Relationship' }
  12   );
  13
  14 sub delete {
  15   my ($self, @rest) = @_;
  16   return $self->next::method(@rest) unless ref $self;
  17     # I'm just ignoring this for class deletes because hell, the db should
  18     # be handling this anyway. Assuming we have joins we probably actually
  19     # *could* do them, but I'd rather not.
  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
  25   if (@cascade) {
  26     my $guard = $source->schema->txn_scope_guard;
  27
  28     my $ret = $self->next::method(@rest);
  29
  30     foreach my $rel (@cascade) {
  31       if( my $rel_rs = eval{ $self->search_related($rel) } ) {
  32         $rel_rs->delete_all;
  33       } else {
  34         carp "Skipping cascade delete on relationship '$rel' - related resultsource '$rels{$rel}{class}' is not registered with this schema";
  35         next;
  36       }
  37     }
  38
  39     $guard->commit;
  40     return $ret;
  41   }
  42
  43   $self->next::method(@rest);
  44 }
  45
  46 sub update {
  47   my ($self, @rest) = @_;
  48   return $self->next::method(@rest) unless ref $self;
  49     # Because update cascades on a class *really* don't make sense!
  50
  51   my $source = $self->result_source;
  52   my %rels = map { $_ => $source->relationship_info($_) } $source->relationships;
  53   my @cascade = grep { $rels{$_}{attrs}{cascade_update} } keys %rels;
  54
  55   if (@cascade) {
  56     my $guard = $source->schema->txn_scope_guard;
  57
  58     my $ret = $self->next::method(@rest);
  59
  60     foreach my $rel (@cascade) {
  61       next if (
  62         $rels{$rel}{attrs}{accessor}
  63           &&
  64         $rels{$rel}{attrs}{accessor} eq 'single'
  65           &&
  66         !exists($self->{_relationship_data}{$rel})
  67       );
  68       $_->update for grep defined, $self->$rel;
  69     }
  70
  71     $guard->commit;
  72     return $ret;
  73   }
  74
  75   $self->next::method(@rest);
  76 }
  77
  78 1;