Re: disabling cascading delete

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

--=-YvKlTcII+UWRMhfbB1Lr
Content-Type: text/plain
Content-Transfer-Encoding: 7bit

> One of the nice things about the new relationship plugin mechanism is
> that it will be easy for people to release things like this as
> stand-alone modules.
> 
> Tony
> 

OK, so I just wrote this module (attached).  I'll probably send it to
CPAN, although I still think it wouldn't hurt to include the extra
functionality in Class::DBI::Relationship::MasMany, since the difference
is only a few lines.

I tested it in my app with several cases, and apparently works fine.

Comments?

cv



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

package Class::DBI::Relationship::eHasMany;

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("e_has_many needs an accessor name") unless $acce=
ssor;
    return $class->_croak("e_has_many needs a foreign class")  unless $f_cl=
ass;
    $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->_e_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(e_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 _e_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(e_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;

__END__

=3Dhead1 NAME

     Class::DBI::Relationship::eHasMany - Extended (or Enhanced) HasMany Re=
lationship Class  =20

=3Dhead1 SYNOPSIS

    In your application base class:

     __PACKAGE__->add_relationship_type(
        e_has_many   =3D> "Class::DBI::Relationship::eHasMany",
	       );

=3Dhead1 DESCRIPTION
   =20
     eHasMany is basically the same HasMany relationship included in Class:=
:DBI, with the
     addition of the argument "on_delete", which defines three behaviors at=
 deletion time:
   =20
             'restrict'
             'cascade'
             'set-null'

     This mimics what several DBs offer, without the need to define it at t=
he DB level,=20
     thus losing DB independence.
   =20
     The current (0.96) only option is no_cascade_delete, which is both lim=
ited and=20
     non-optimal, because foreign keys would keep pointing to nonexistent o=
bject ids.

=3Dhead1 CURRENT AUTHOR
   =20
    Carlos Vicente <cvicente@xxxxxxx.xxx> (modified Tony Bowden's HasMany)
   =20
    This functionality was first suggested by Tim Bunce in the CDBI mailing=
 list.

        http://groups.kasei.com/mail/arc/cdbi-talk/2003-02/msg00142.html

=3Dhead1 LICENSE

     This library is free software; you can redistribute it and/or modify
     it under the same terms as Perl itself.

=3Dhead1 SEE ALSO

     L<Class::DBI::Relationship>


--=-YvKlTcII+UWRMhfbB1Lr--