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 <[EMAIL PROTECTED]> > > =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 _______________________________________________ List: http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class IRC: irc.perl.org#dbix-class SVN: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/ Searchable Archive: http://www.grokbase.com/group/dbix-class@lists.scsys.co.uk