Better linking in Relatiomship POD
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Relationship / ManyToMany.pm
CommitLineData
75d07914 1package # hide from PAUSE
c0e7b4e5 2 DBIx::Class::Relationship::ManyToMany;
8973b6f1 3
4use strict;
5use warnings;
ddc0a6c8 6use Sub::Name ();
8973b6f1 7
8sub many_to_many {
78af1010 9 my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
d0ed3b55 10
11 $class->throw_exception(
12 "missing relation in many-to-many"
13 ) unless $rel;
14
15 $class->throw_exception(
16 "missing foreign relation in many-to-many"
17 ) unless $f_rel;
18
8973b6f1 19 {
20 no strict 'refs';
21 no warnings 'redefine';
4b3ab474 22
b3f358b5 23 my $add_meth = "add_to_${meth}";
24 my $remove_meth = "remove_from_${meth}";
25 my $set_meth = "set_${meth}";
18788bf2 26 my $rs_meth = "${meth}_rs";
303cf522 27
35210a5d 28 for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
29 warn "***************************************************************************\n".
30 "The many-to-many relationship $meth is trying to create a utility method called $_. This will overwrite the existing method on $class. You almost certainly want to rename your method or the many-to-many relationship, as your method will not be callable (it will use the one from the relationship instead.) YOU HAVE BEEN WARNED\n".
31 "***************************************************************************\n"
32 if $class->can($_);
33 }
34
7141bdfc 35 $rel_attrs->{alias} ||= $f_rel;
36
ddc0a6c8 37 my $rs_meth_name = join '::', $class, $rs_meth;
38 *$rs_meth_name = Sub::Name::subname $rs_meth_name, sub {
0f6ac8bb 39 my $self = shift;
40 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
78060df8 41 my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
18788bf2 42 my $rs = $self->search_related($rel)->search_related(
3a868fb2 43 $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
44 );
18788bf2 45 return $rs;
78af1010 46 };
4b3ab474 47
ddc0a6c8 48 my $meth_name = join '::', $class, $meth;
49 *$meth_name = Sub::Name::subname $meth_name, sub {
18788bf2 50 my $self = shift;
51 my $rs = $self->$rs_meth( @_ );
52 return (wantarray ? $rs->all : $rs);
53 };
54
ddc0a6c8 55 my $add_meth_name = join '::', $class, $add_meth;
56 *$add_meth_name = Sub::Name::subname $add_meth_name, sub {
303cf522 57 my $self = shift;
58 @_ > 0 or $self->throw_exception(
b3f358b5 59 "${add_meth} needs an object or hashref"
303cf522 60 );
61 my $source = $self->result_source;
62 my $schema = $source->schema;
63 my $rel_source_name = $source->relationship_info($rel)->{source};
64 my $rel_source = $schema->resultset($rel_source_name)->result_source;
65 my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source};
78060df8 66 my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{});
67
68 my $obj;
69 if (ref $_[0]) {
70 if (ref $_[0] eq 'HASH') {
71 $obj = $f_rel_rs->create($_[0]);
72 } else {
73 $obj = $_[0];
74 }
75 } else {
76 $obj = $f_rel_rs->create({@_});
77 }
78
3bd6e3e0 79 my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
6cc5b382 80 my $link = $self->search_related($rel)->new_result($link_vals);
303cf522 81 $link->set_from_related($f_rel, $obj);
82 $link->insert();
716c16a0 83 return $obj;
4b3ab474 84 };
85
ddc0a6c8 86 my $set_meth_name = join '::', $class, $set_meth;
87 *$set_meth_name = Sub::Name::subname $set_meth_name, sub {
b3f358b5 88 my $self = shift;
89 @_ > 0 or $self->throw_exception(
90 "{$set_meth} needs a list of objects or hashrefs"
91 );
f72f9361 92 my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_);
b3f358b5 93 $self->search_related($rel, {})->delete;
f72f9361 94 $self->$add_meth($_) for (@to_set);
b3f358b5 95 };
96
ddc0a6c8 97 my $remove_meth_name = join '::', $class, $remove_meth;
98 *$remove_meth_name = Sub::Name::subname $remove_meth_name, sub {
303cf522 99 my $self = shift;
100 @_ > 0 && ref $_[0] ne 'HASH'
b3f358b5 101 or $self->throw_exception("${remove_meth} needs an object");
303cf522 102 my $obj = shift;
103 my $rel_source = $self->search_related($rel)->result_source;
104 my $cond = $rel_source->relationship_info($f_rel)->{cond};
105 my $link_cond = $rel_source->resolve_condition(
106 $cond, $obj, $f_rel
107 );
108 $self->search_related($rel, $link_cond)->delete;
4b3ab474 109 };
110
8973b6f1 111 }
112}
113
1141;