Re: disabling cascading delete

[prev] [thread] [next] [Date index for 2004/05/12]

--=-+NbIib+olWieWBrc3ud5
Content-Type: text/plain
Content-Transfer-Encoding: 7bit

> I'm not against including it in HasMany itself, as it should be safely
> backwards-compatible - although I would like to see some tests in
> that case.

I'm attaching a HasMany.pm with the extra functionality.  Also a
modified 09-has_many.t with relevant checks added.

Replacing both files in the distribution and running 'make test' should
work.

Thanks for considering this.

Regards,

cv

--=-+NbIib+olWieWBrc3ud5
Content-Disposition: attachment; filename=HasMany.pm
Content-Transfer-Encoding: quoted-printable
Content-Type: text/plain; name=HasMany.pm; charset=ISO-8859-1

package Class::DBI::Relationship::HasMany;

use strict;
use warnings;

use base 'Class::DBI::Relationship';

sub remap_arguments {
    my ($proto, $class, $accessor, $f_class, $f_key, $args) =3D @_;
   =20
    my %on_delete_beh =3D ( 'cascade'  =3D> 1,
			  'set-null' =3D> 1,
			  'restrict' =3D> 1,
			  );
   =20
    return $class->_croak("has_many needs an accessor name") unless $access=
or;
    return $class->_croak("has_many needs a foreign class")  unless $f_clas=
s;
    $class->can($accessor)
	and return $class->_carp("$accessor method already exists in $class\n");
   =20
    my @f_method =3D ();
    if (ref $f_class eq "ARRAY") {
	($f_class, @f_method) =3D @$f_class;
    }
    $class->_require_class($f_class);
   =20
    if (ref $f_key eq "HASH") {    # didn't supply f_key, this is really $a=
rgs
	$args  =3D $f_key;
	$f_key =3D "";
    }
   =20
    $f_key ||=3D do {
	my $meta =3D $f_class->meta_info('has_a');
	my ($col) =3D grep $meta->{$_}->foreign_class eq $class, keys %$meta;
	$col || $class->table_alias;
    };

    if (ref $f_key eq "ARRAY") {
	return $class->_croak("Multi-column foreign keys not supported")
	    if @$f_key > 1;
	$f_key =3D $f_key->[0];
    }
   =20
    $args ||=3D {};
    $args->{mapping}     =3D \@f_method;
    $args->{foreign_key} =3D $f_key;
    $args->{order_by} ||=3D $args->{sort};   =20
    warn "sort argumemt to has_many deprecated in favour of order_by"
	if $args->{sort};            =20

    # Make 'cascade' the default on_delete behaviour
    $args->{on_delete} ||=3D "cascade";
   =20
    unless ( exists $on_delete_beh{$args->{on_delete}} ){
	return $class->_croak("Unknown on_delete behavior: $args->{on_delete}");
    }
   =20
    return ($class, $accessor, $f_class, $args);
}

sub _set_up_class_data {
    my $self =3D shift;
    $self->class->_extend_class_data(
				     __hasa_list =3D> $self->foreign_class =3D> $self->args->{foreign_k=
ey});
    $self->SUPER::_set_up_class_data;
}

sub triggers {
    my $self =3D shift;
    if ($self->args->{on_delete} eq "restrict"){
	return (
		before_delete =3D> sub {
		    if ( scalar  $self->foreign_class->search($self->args->{foreign_key} =
=3D> shift->id) ){
			return $self->class->_croak("Deletion restricted for referential integri=
ty");
		    }
		});
=09
    }elsif ($self->args->{on_delete} eq "set-null"){
	return (
		before_delete =3D> sub {
		    foreach ( $self->foreign_class->search($self->args->{foreign_key} =3D=
> shift->id) ){
			$_->set($self->args->{foreign_key}, 0);
			$_->update;
		    }
		});
    }elsif ($self->args->{on_delete} eq "cascade"){
	return (
		before_delete =3D> sub {
		    $self->foreign_class->search($self->args->{foreign_key} =3D> shift->i=
d)
			->delete_all;
		});
    }
}

sub methods {
    my $self     =3D shift;
    my $accessor =3D $self->accessor;
    return (
	    $accessor          =3D> $self->_has_many_method,
	    "add_to_$accessor" =3D> $self->_method_add_to,
	    );
}

sub _method_add_to {
    my $self     =3D shift;
    my $accessor =3D $self->accessor;
    return sub {
	my ($self, $data) =3D @_;
	my $class =3D ref $self
	    or return $self->_croak("add_to_$accessor called as class method");
	return $self->_croak("add_to_$accessor needs data")
	    unless ref $data eq "HASH";
=09
	my $meta =3D $class->meta_info(has_many =3D> $accessor);
	my ($f_class, $f_key, $args) =3D
	    ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
	$data->{$f_key} =3D $self->id;
	$f_class->create($data);
    };
}

sub _has_many_method {
    my $self       =3D shift;
    my $run_search =3D $self->_hm_run_search;
    my @mapping    =3D @{ $self->args->{mapping} } or return $run_search;
    return sub {
	return $run_search->(@_)->set_mapping_method(@mapping)
	    unless wantarray;
	my @ret =3D $run_search->(@_);
	foreach my $meth (@mapping) { @ret =3D map $_->$meth(), @ret }
	return @ret;
    }
}

sub _hm_run_search {
    my $self =3D shift;
    my ($class, $accessor) =3D ($self->class, $self->accessor);
    return sub {
	my ($self, @search_args) =3D @_;
	my $meta =3D $class->meta_info(has_many =3D> $accessor);
	my ($f_class, $f_key, $args) =3D
	    ($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
	if (ref $self) {    # For $artist->cds
	    unshift @search_args, ($f_key =3D> $self->id);
	    push @search_args, { order_by =3D> $args->{order_by} }
	    if defined $args->{order_by};
	    return $f_class->search(@search_args);
	} else {            # For Artist->cds
	    # Cross-table join as class method
	    # This stuff is highly experimental and will probably change beyond
	    # recognition. Use at your own risk...
	    my %kv =3D @search_args;
	    my $query =3D Class::DBI::Query->new({ owner =3D> $f_class });
	    $query->kings($class, $f_class);
	    $query->add_restriction(sprintf "%s.%s =3D %s.%s",
				    $f_class->table_alias, $f_key, $class->table_alias,
				    $class->primary_column);
	    $query->add_restriction("$_ =3D ?") for keys %kv;
	    my $sth =3D $query->run(values %kv);
	    return $f_class->sth_to_objects($sth);
	}
    };
}

1;

--=-+NbIib+olWieWBrc3ud5
Content-Disposition: attachment; filename=09-has_many.t
Content-Transfer-Encoding: quoted-printable
Content-Type: text/x-troff; name=09-has_many.t; charset=ISO-8859-1

use strict;
use Test::More;

BEGIN {
	eval "use DBD::SQLite";
	plan $@ ? (skip_all =3D> 'needs DBD::SQLite for testing') : (tests =3D> 51=
);

	use lib 't/testlib';
	use Film;
	use Actor;
	use Director;
	Director->CONSTRUCT;
	Film->CONSTRUCT;
	Actor->CONSTRUCT;
	Director->has_many(directedfilms =3D> Film =3D> 'Director', { order_by =3D=
> 'title', on_delete =3D> 'restrict' });
	Director->has_many(codirectedfilms =3D> Film =3D> 'CoDirector', { order_by=
 =3D> 'title', on_delete =3D> 'set-null' });
	Film->has_many(actors =3D> Actor =3D> 'Film', { order_by =3D> 'name', on_d=
elete =3D> 'cascade' });
	Actor->has_a(Film =3D> 'Film');
	Film->has_a(Director =3D> 'Director');
	Film->has_a(CoDirector =3D> 'Director');
	is(Actor->primary_column, 'id', "Actor primary OK");
}

ok(Actor->can('Salary'), "Actor table set-up OK");
ok(Film->can('actors'), " and have a suitable actors method in Film");
ok(Director->can('IsInsane'), "Director table set-up OK");
ok(Director->can('directedfilms'), " and have a suitable directedfilms meth=
od in Director");
ok(Director->can('codirectedfilms'), " and have a suitable codirectedfilms =
method in Director");

ok(my $btaste =3D Film->retrieve('Bad Taste'), "We have Bad Taste");

ok(
	my $pvj =3D Actor->create(
		{
			Name   =3D> 'Peter Vere-Jones',
			Film   =3D> undef,
			Salary =3D> '30_000',             # For a voice!
		}
	),
	'create Actor'
);
ok(
	my $pjd =3D Director->create(
		{
			Name   =3D> 'Peter Jackson',   # Yeah, he's also the director
			Birthday   =3D> undef,
			IsInsane =3D> '1',             # no doubt
		}
	),
	'create Director'
);
ok(
	my $mj =3D Director->create(
		{
			Name   =3D> 'Michael Jackson', # whatever
			Birthday   =3D> undef,
			IsInsane =3D> '1',             # no comments
		}
	),
	'create CoDirector'
);

is $pvj->Name, "Peter Vere-Jones", "PVJ name ok";
is $pvj->Film, undef, "No film";
ok $pvj->set_Film($btaste), "Set film";
$pvj->update;
is $pvj->Film->id, $btaste->id, "Actor has film";
is $pjd->Name, "Peter Jackson", "PJ name ok";
is $mj->Name, "Michael Jackson", "MJ name ok";
ok $btaste->set('Director', $pjd), "Set Director";
ok $btaste->set('CoDirector', $mj), "Set CoDirector";
$btaste->update;
is $btaste->Director->id, $pjd->id, "Film Has Director";
is $btaste->CoDirector->id, $mj->id, "Film Has CoDirector";

{
	my @actors =3D $btaste->actors;
	is(@actors, 1, "Bad taste has one actor");
	is($actors[0]->Name, $pvj->Name, " - the correct one");
}
{
	my @dfilms =3D $pjd->directedfilms;
	is(@dfilms, 1, "PJ has directed one film");
	is($dfilms[0]->Title, $btaste->Title, " - the correct one");
}
{
	my @cdfilms =3D $mj->codirectedfilms;
	is(@cdfilms, 1, "MJ has codirected one film");
	is($cdfilms[0]->Title, $btaste->Title, " - the correct one");
}

my %pj_data =3D (
	       Name   =3D> 'Peter Jackson',
	       Salary =3D> '0',               # it's a labour of love
);

eval { my $pj =3D Film->add_to_actors(\%pj_data) };
like $@, qr/class/, "add_to_actors must be object method";

eval { my $pj =3D $btaste->add_to_actors(%pj_data) };
like $@, qr/needs/, "add_to_actors takes hash";

ok(
	my $pj =3D $btaste->add_to_actors(
		{
			Name   =3D> 'Peter Jackson',
			Salary =3D> '0',               # it's a labour of love
		}
	),
	'add_to_actors'
);


is $pj->Name,  "Peter Jackson",    "PJ ok";
is $pvj->Name, "Peter Vere-Jones", "PVJ still ok";

{
	my @actors =3D $btaste->actors;
	is @actors, 2, " - so now we have 2";
	is $actors[0]->Name, $pj->Name,  "PJ first";
	is $actors[1]->Name, $pvj->Name, "PVJ first";
}

eval {
	my @actors =3D $btaste->actors(Name =3D> $pj->Name);
	is @actors, 1, "One actor from restricted (sorted) has_many";
	is $actors[0]->Name, $pj->Name, "It's PJ";
};
is $@, '', "No errors";

my $as =3D Actor->create(
	{
		Name   =3D> 'Arnold Schwarzenegger',
		Film   =3D> 'Terminator 2',
		Salary =3D> '15_000_000'
	}
);


eval { $pjd->delete };
like $@, qr/restricted/, "delete restriction ok";

is($pjd->Name, "Peter Jackson", "Director still there");
is(($pjd->directedfilms)[0]->Title, "Bad Taste", "And his Film still there"=
);

ok($mj->delete, "Delete Michael");
my @directors =3D Director->search(Name =3D> "Michael Jackson");
is(@directors, 0, " - Michael is gone");
is($btaste->CoDirector, 0, "CoDirector is gone");

eval { $btaste->actors($pj, $pvj, $as) };
ok $@, $@;
is($btaste->actors, 2, " - so we still only have 2 actors");

my @bta_before =3D Actor->search(Film =3D> 'Bad Taste');
is(@bta_before, 2, "We have 2 actors in bad taste");
ok($btaste->delete, "Delete bad taste");
my @bta_after =3D Actor->search(Film =3D> 'Bad Taste');
is(@bta_after, 0, " - after deleting there are no actors");

# While we're here, make sure Actors have unreadable mutators and
# unwritable accessors

eval { $as->Name("Paul Reubens") };
ok $@, $@;
eval { my $name =3D $as->set_Name };
ok $@, $@;

is($as->Name, 'Arnold Schwarzenegger', "Arnie's still Arnie");


--=-+NbIib+olWieWBrc3ud5--