[Dbix-class] bug in delete_all: CascadeActions::delete removes parent before children

Peter Rabbitson rabbit+list at rabbit.us
Fri Oct 24 22:32:04 BST 2008


Noel Burton-Krahn wrote:
> DBIx's cascading delete_all (in DBIx::Class::ResultSet) it broken,
> because it deletes the parent table before it deletes the children.
> The database will throw a referential integrity exception when the
> parent is deleted before the children.    I've attached a test program
> below.  Here's a fixed version in
> DBIx-Class-0.08010/lib/DBIx/Class/Relationship/CascadeActions.pm:
> 
> Regards,
> Noel Burton-Krahn
> 
> ###################################
> # fixed DBIx/Class/Relationship/CascadeActions.pm in DBIx-Class-0.08010
> 
> sub delete {
>   my ($self, @rest) = @_;
> 
>   # delete from tables that depend on me first
>   my $source = $self->result_source;
>   my %rels = map { $_ => $source->relationship_info($_) }
> $source->relationships;
>   my @cascade = grep { $rels{$_}{attrs}{cascade_delete} } keys %rels;
>   foreach my $rel (@cascade) {
>     $self->search_related($rel)->delete_all;
>   }
> 
>   # delete me
>   return $self->next::method(@rest) unless ref $self;
>     # I'm just ignoring this for class deletes because hell, the db should
>     # be handling this anyway. Assuming we have joins we probably actually
>     # *could* do them, but I'd rather not.
> 
>   my $ret = $self->next::method(@rest);
> 
>   return $ret;
> }
> 
> 
> 
> # Test program
> ###################################
> #! /usr/bin/perl -w
> =head1 NAME
> 
>  dbix_cascade_delete.t - reproduce DBIx's failure in delete_all
> 
> =head1 DESCRIPTION
> 
> DBIx::Class::ResultSet::delete_all fails in version 0.08010 because it
> deletes the parent before the children
> 
> =head1 AUTHOR
> 
> Noel Burton-Krahn <noel at burton-krahn.com>
> 
> =cut
> 
> use strict;
> use warnings;
> 
> #--------------------
> package My::DBIx::Class;
> use base qw/DBIx::Class/;
> 
> __PACKAGE__->load_components(qw/PK::Auto Core/);
> 
> use overload '""' => 'dump';
> 
> sub dump {
> 	my($self) = shift;
> 	return join(" ", map { "$_=" . $self->get_column($_) } $self->columns);
> }
> 
> #--------------------
> package MySchema::Person;
> use base qw/My::DBIx::Class/;
> __PACKAGE__->table('person');
> __PACKAGE__->add_columns(qw(person_id name));
> __PACKAGE__->set_primary_key('person_id');
> __PACKAGE__->has_many(address => 'MySchema::Address', 'person_id');
> 
> #--------------------
> package MySchema::Address;
> use base  qw/My::DBIx::Class/;
> __PACKAGE__->table('address');
> __PACKAGE__->add_columns(qw(address_id person_id address));
> __PACKAGE__->set_primary_key('address_id');
> __PACKAGE__->belongs_to(person => 'MySchema::Person', 'person_id');
> 
> #--------------------
> package MySchema;
> use base qw/DBIx::Class::Schema/;
> 
> __PACKAGE__->load_classes({
> 	'MySchema' => [ qw(Person Address) ],
> });
> 
> #--------------------
> package Test::DbixCascaseDelete;
> use Test::More tests => 16;
> 
> # create a mysql database to test with
> system(<<'EOS');
> mysqladmin -f drop mytest >/dev/null 2>&1
> 
> mysqladmin create mytest
> 
> mysql mytest <<ESQL
> create table person (
>   person_id INT NOT NULL AUTO_INCREMENT PRIMARY KEY
>   ,name VARCHAR(1024) NOT NULL
> ) ENGINE=INNODB;
> 
> create table address (
>   address_id INT NOT NULL AUTO_INCREMENT PRIMARY KEY
>   ,person_id INT NOT NULL
>   ,address VARCHAR(1024) NOT NULL
>   ,FOREIGN KEY (person_id) REFERENCES person (person_id)
> ) ENGINE=INNODB;
> ESQL
> 
> #mysql mytest <<ESQL
> #show tables;
> #show create table person;
> #show create table address;
> #ESQL
> 
> EOS
> 	;
> is($?, 0, "create database");
> 
> # connect
> my $schema = MySchema->connect("dbi:mysql:mytest", 'script', 'tlby14')
> or die("connect: $!");
> ok($schema, "connect to db");
> 
> #$schema->storage->debug(1);
> 
> my $rs;
> my $person;
> 
> $person = $schema->resultset('Person')->create({ name => 'fred'});
> ok($person, "create Person: $person");
> 
> $rs = $schema->resultset('Person')->search();
> while( my $row = $rs->next() ) {
> 	$person = $row;
> }
> ok($rs, "found Person: $person");
> 
> my $address;
> for my $i (1..3) {
> 	$address = $schema->resultset('Address')->create({ person => $person,
> address => "fred's address $i"});
> 	ok($address, "create Address: $address");
> }
> 
> $rs = $schema->resultset('Address')->search({ person_id =>
> $person->person_id });
> while( my $row = $rs->next ) {
> 	$address = $row;
> 	ok($address, "found created Address: $address");
> }
> 
> ok($address->person, "address->person: " . $address->person->dump);
> 
> $rs = $person->address_rs;
> while( my $row = $rs->next ) {
> 	$address = $row;
> 	ok($address, "person->address: $address");
> }
> 
> $rs = $schema->resultset('Person')->search({ name => 'fred'});
> 
> $rs->delete_all;
> ok(1, "delete_all");
> 
> is($rs->count, 0, "Person really gone");
> 

Please submit the lonely pieces of code above as a real diff against
dbic trunk[1], so the actual set of changes is clearly visible
(facilitates review and potential inclusion).

Cheers

[1]: svn co http://dev.catalyst.perl.org/repos/bast/DBIx-Class/0.08/trunk



More information about the DBIx-Class mailing list