1package Class::DBI::Relationship::HasMany;
2
3use strict;
4use warnings;
5
6use base 'Class::DBI::Relationship';
7
8sub remap_arguments {
9	my ($proto, $class, $accessor, $f_class, $f_key, $args) = @_;
10
11	return $class->_croak($class->name . " needs an accessor name")
12		unless $accessor;
13	return $class->_croak($class->name . " needs a foreign class")
14		unless $f_class;
15
16	{
17		no strict 'refs';
18		defined &{"$class\::$accessor"}
19			and return $class->_carp("$accessor method already exists in $class\n");
20	}
21
22	my @f_method = ();
23	if (ref $f_class eq "ARRAY") {
24		($f_class, @f_method) = @$f_class;
25	}
26	$class->_require_class($f_class);
27
28	if (ref $f_key eq "HASH") {    # didn't supply f_key, this is really $args
29		$args  = $f_key;
30		$f_key = "";
31	}
32
33	$f_key ||= do {
34		my $meta = $f_class->meta_info('has_a');
35		my ($col) = grep $meta->{$_}->foreign_class eq $class, keys %$meta;
36		$col || $class->table_alias;
37	};
38
39	if (ref $f_key eq "ARRAY") {
40		return $class->_croak("Multi-column foreign keys not supported")
41			if @$f_key > 1;
42		$f_key = $f_key->[0];
43	}
44
45	$args ||= {};
46	$args->{mapping}     = \@f_method;
47	$args->{foreign_key} = $f_key;
48	$args->{order_by} ||= $args->{sort};    # deprecated 0.96
49	warn "sort argument to has_many deprecated in favour of order_by"
50		if $args->{sort};                     # deprecated 0.96
51
52	return ($class, $accessor, $f_class, $args);
53}
54
55sub _set_up_class_data {
56	my $self = shift;
57	$self->class->_extend_class_data(
58		__hasa_list => $self->foreign_class => $self->args->{foreign_key});
59	$self->SUPER::_set_up_class_data;
60}
61
62sub triggers {
63	my $self = shift;
64	if ($self->args->{no_cascade_delete}) {    # old undocumented way
65		warn "no_cascade_delete deprecated in favour of cascade => None";
66		return;
67	}
68	my $strategy = $self->args->{cascade} || "Delete";
69	$strategy = "Class::DBI::Cascade::$strategy" unless $strategy =~ /::/;
70
71	$self->foreign_class->_require_class($strategy);
72	$strategy->can('cascade')
73		or return $self->_croak("$strategy is not a valid Cascade Strategy");
74	my $strat_obj = $strategy->new($self);
75	return (before_delete => sub { $strat_obj->cascade(@_) });
76}
77
78sub methods {
79	my $self     = shift;
80	my $accessor = $self->accessor;
81	return (
82		$accessor          => $self->_has_many_method,
83		"add_to_$accessor" => $self->_method_add_to,
84	);
85}
86
87sub _method_add_to {
88	my $rel      = shift;
89	my $accessor = $rel->accessor;
90	return sub {
91		my ($self, $data) = @_;
92		my $class = ref $self
93			or return $self->_croak("add_to_$accessor called as class method");
94		return $self->_croak("add_to_$accessor needs data")
95			unless ref $data eq "HASH";
96
97		my $meta = $class->meta_info($rel->name => $accessor);
98		my ($f_class, $f_key, $args) =
99			($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
100		$data->{$f_key} = $self->id;
101
102		# See if has_many constraints were defined and auto fill them
103		if (defined $args->{constraint} && ref $args->{constraint} eq 'HASH') {
104			while (my ($k, $v) = each %{ $args->{constraint} }) {
105				$self->_croak(
106					"Can't add_to_$accessor with $k = $data->{$k} (must be $v)")
107					if defined($data->{$k}) && $data->{$k} ne $v;
108				$data->{$k} = $v;
109			}
110		}
111
112		$f_class->insert($data);
113	};
114}
115
116sub _has_many_method {
117	my $self       = shift;
118	my $run_search = $self->_hm_run_search;
119	my @mapping    = @{ $self->args->{mapping} } or return $run_search;
120	return sub {
121		return $run_search->(@_)->set_mapping_method(@mapping)
122			unless wantarray;
123		my @ret = $run_search->(@_);
124		foreach my $meth (@mapping) { @ret = map $_->$meth(), @ret }
125		return @ret;
126		}
127}
128
129sub _hm_run_search {
130	my $rel = shift;
131	my ($class, $accessor) = ($rel->class, $rel->accessor);
132	return sub {
133		my ($self, @search_args) = @_;
134		@search_args = %{ $search_args[0] } if ref $search_args[0] eq "HASH";
135		my $meta = $class->meta_info($rel->name => $accessor);
136		my ($f_class, $f_key, $args) =
137			($meta->foreign_class, $meta->args->{foreign_key}, $meta->args);
138		if (ref $self) {    # For $artist->cds
139			unshift @search_args, %{ $args->{constraint} }
140				if defined($args->{constraint}) && ref $args->{constraint} eq 'HASH';
141			unshift @search_args, ($f_key => $self->id);
142			push @search_args, { order_by => $args->{order_by} }
143				if defined $args->{order_by};
144			return $f_class->search(@search_args);
145		} else {            # For Artist->cds
146			    # Cross-table join as class method
147			    # This stuff is highly experimental and will probably change beyond
148			    # recognition. Use at your own risk...
149			my %kv = @search_args;
150			my $query = Class::DBI::Query->new({ owner => $f_class });
151			$query->kings($class, $f_class);
152			$query->add_restriction(sprintf "%s.%s = %s.%s",
153				$f_class->table_alias, $f_key, $class->table_alias,
154				$class->primary_column);
155			$query->add_restriction("$_ = ?") for keys %kv;
156			my $sth = $query->run(values %kv);
157			return $f_class->sth_to_objects($sth);
158		}
159	};
160}
161
1621;
163