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

[Noel Burton-Krahn]

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");