added tests for required modules, minor documentation update
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Relationship / ManyToMany.pm
1 package # hide from PAUSE
2     DBIx::Class::Relationship::ManyToMany;
3
4 use strict;
5 use warnings;
6
7 sub many_to_many {
8   my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
9
10   $class->throw_exception(
11     "missing relation in many-to-many"
12   ) unless $rel;
13
14   $class->throw_exception(
15     "missing foreign relation in many-to-many"
16   ) unless $f_rel;
17
18   {
19     no strict 'refs';
20     no warnings 'redefine';
21
22     my $add_meth = "add_to_${meth}";
23     my $remove_meth = "remove_from_${meth}";
24     my $set_meth = "set_${meth}";
25     my $rs_meth = "${meth}_rs";
26
27     for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
28       warn "***************************************************************************\n".
29            "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".
30            "***************************************************************************\n"
31         if $class->can($_);
32     }
33
34     $rel_attrs->{alias} ||= $f_rel;
35
36     *{"${class}::${meth}_rs"} = sub {
37       my $self = shift;
38       my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
39       my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
40       my $rs = $self->search_related($rel)->search_related(
41         $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
42       );
43           return $rs;
44     };
45
46         *{"${class}::${meth}"} = sub {
47                 my $self = shift;
48                 my $rs = $self->$rs_meth( @_ );
49                 return (wantarray ? $rs->all : $rs);
50         };
51
52     *{"${class}::${add_meth}"} = sub {
53       my $self = shift;
54       @_ > 0 or $self->throw_exception(
55         "${add_meth} needs an object or hashref"
56       );
57       my $source = $self->result_source;
58       my $schema = $source->schema;
59       my $rel_source_name = $source->relationship_info($rel)->{source};
60       my $rel_source = $schema->resultset($rel_source_name)->result_source;
61       my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source};
62       my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{});
63
64       my $obj;
65       if (ref $_[0]) {
66         if (ref $_[0] eq 'HASH') {
67           $obj = $f_rel_rs->create($_[0]);
68         } else {
69           $obj = $_[0];
70         }
71       } else {
72         $obj = $f_rel_rs->create({@_});
73       }
74
75       my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
76       my $link = $self->search_related($rel)->new_result($link_vals);
77       $link->set_from_related($f_rel, $obj);
78       $link->insert();
79           return $obj;
80     };
81
82     *{"${class}::${set_meth}"} = sub {
83       my $self = shift;
84       @_ > 0 or $self->throw_exception(
85         "{$set_meth} needs a list of objects or hashrefs"
86       );
87       my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_);
88       $self->search_related($rel, {})->delete;
89       $self->$add_meth($_) for (@to_set);
90     };
91
92     *{"${class}::${remove_meth}"} = sub {
93       my $self = shift;
94       @_ > 0 && ref $_[0] ne 'HASH'
95         or $self->throw_exception("${remove_meth} needs an object");
96       my $obj = shift;
97       my $rel_source = $self->search_related($rel)->result_source;
98       my $cond = $rel_source->relationship_info($f_rel)->{cond};
99       my $link_cond = $rel_source->resolve_condition(
100         $cond, $obj, $f_rel
101       );
102       $self->search_related($rel, $link_cond)->delete;
103     };
104
105   }
106 }
107
108 1;