File Coverage

blib/lib/Class/DBI/Frozen/301/Relationship/HasMany.pm

Criterion	Covered	Total	%
statement	47	80	58.7
branch	10	32	31.2
condition	3	8	37.5
subroutine	10	14	71.4
pod	0	3	0.0
total	70	137	51.0

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) = @_;

	return $class->_croak("has_many needs an accessor name") unless $accessor;
	return $class->_croak("has_many needs a foreign class")  unless $f_class;
	$class->can($accessor)
		and return $class->_carp("$accessor method already exists in $class\n");

	my @f_method = ();
	if (ref $f_class eq "ARRAY") {
		($f_class, @f_method) = @$f_class;
	}
	$class->_require_class($f_class);

	if (ref $f_key eq "HASH") {    # didn't supply f_key, this is really $args
		$args  = $f_key;
		$f_key = "";
	}

	$f_key ||= do {
		my $meta = $f_class->meta_info('has_a');
		my ($col) = 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 = $f_key->[0];
	}

	$args ||= {};
	$args->{mapping}     = \@f_method;
	$args->{foreign_key} = $f_key;
	$args->{order_by} ||= $args->{sort};    # deprecated 0.96
	warn "sort argumemt to has_many deprecated in favour of order_by"
		if $args->{sort};                     # deprecated 0.96

	return ($class, $accessor, $f_class, $args);
}

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

sub triggers {
	my $self = shift;
	return if $self->args->{no_cascade_delete};    # undocumented and untestsd!
	return (
		before_delete => sub {
			$self->foreign_class->search($self->args->{foreign_key} => shift->id)
				->delete_all;
		});
}

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

sub _method_add_to {
	my $self     = shift;
	my $accessor = $self->accessor;
	return sub {
		my ($self, $data) = @_;
		my $class = 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";

		my $meta = $class->meta_info(has_many => $accessor);
		my ($f_class, $f_key, $args) =
			($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
		$data->{$f_key} = $self->id;
		$f_class->create($data);
	};
}

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

sub _hm_run_search {
	my $self = shift;
	my ($class, $accessor) = ($self->class, $self->accessor);
	return sub {
		my ($self, @search_args) = @_;
		my $meta = $class->meta_info(has_many => $accessor);
		my ($f_class, $f_key, $args) =
			($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
		if (ref $self) {    # For $artist->cds
			unshift @search_args, ($f_key => $self->id);
			push @search_args, { order_by => $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 = @search_args;
			my $query = Class::DBI::Query->new({ owner => $f_class });
			$query->kings($class, $f_class);
			$query->add_restriction(sprintf "%s.%s = %s.%s",
				$f_class->table_alias, $f_key, $class->table_alias,
				$class->primary_column);
			$query->add_restriction("$_ = ?") for keys %kv;
			my $sth = $query->run(values %kv);
			return $f_class->sth_to_objects($sth);
		}
	};
}

1;