File Coverage

blib/lib/Class/DBI/Cascade/Fail.pm
Criterion Covered Total %
statement 12 12 100.0
branch 2 2 100.0
condition n/a
subroutine 4 4 100.0
pod 1 1 100.0
total 19 19 100.0


line stmt bran cond sub pod time code
1             package Class::DBI::Cascade::Fail;
2              
3             =head1 NAME
4            
5             Class::DBI::Cascade::Fail - Do not cascade if foreign objects exist
6            
7             =head1 DESCRIPTION
8            
9             This is a Cascading Delete strategy that will throw an error if any
10             object about to be deleted still has any other objects pointing at it.
11            
12             =cut
13              
14 1     1   14 use strict;
  1         10  
  1         17  
15 1     1   16 use warnings;
  1         9  
  1         16  
16              
17 1     1   16 use base 'Class::DBI::Cascade::None';
  1         9  
  1         16  
18              
19             sub cascade {
20 3     3 1 43 my ($self, $obj) = @_;
21 3 100       47 my $refs = $self->foreign_for($obj)->count or return;
22 2         59 $self->{_rel}->foreign_class->_croak(
23             "$refs objects still refer to $obj. Deletion failed");
24             }
25              
26             1;
27