Clarification cascade_* attribute defaults documentation
[dbsrgits/DBIx-Class-Historic.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 use Carp::Clan qw/^DBIx::Class/;
8 use Sub::Name ();
9
10 our %_pod_inherit_config = 
11   (
12    class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
13   );
14
15 sub many_to_many {
16   my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
17
18   $class->throw_exception(
19     "missing relation in many-to-many"
20   ) unless $rel;
21
22   $class->throw_exception(
23     "missing foreign relation in many-to-many"
24   ) unless $f_rel;
25
26   {
27     no strict 'refs';
28     no warnings 'redefine';
29
30     my $add_meth = "add_to_${meth}";
31     my $remove_meth = "remove_from_${meth}";
32     my $set_meth = "set_${meth}";
33     my $rs_meth = "${meth}_rs";
34
35     for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
36       if ( $class->can ($_) ) {
37         carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
38
39 ***************************************************************************
40 The many-to-many relationship '$meth' is trying to create a utility method
41 called $_.
42 This will completely overwrite one such already existing method on class
43 $class.
44
45 You almost certainly want to rename your method or the many-to-many
46 relationship, as the functionality of the original method will not be
47 accessible anymore.
48
49 To disable this warning set to a true value the environment variable
50 DBIC_OVERWRITE_HELPER_METHODS_OK
51
52 ***************************************************************************
53 EOW
54       }
55     }
56
57     $rel_attrs->{alias} ||= $f_rel;
58
59     my $rs_meth_name = join '::', $class, $rs_meth;
60     *$rs_meth_name = Sub::Name::subname $rs_meth_name, sub {
61       my $self = shift;
62       my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
63       my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
64       my $rs = $self->search_related($rel)->search_related(
65         $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
66       );
67       return $rs;
68     };
69
70     my $meth_name = join '::', $class, $meth;
71     *$meth_name = Sub::Name::subname $meth_name, sub {
72       my $self = shift;
73       my $rs = $self->$rs_meth( @_ );
74       return (wantarray ? $rs->all : $rs);
75     };
76
77     my $add_meth_name = join '::', $class, $add_meth;
78     *$add_meth_name = Sub::Name::subname $add_meth_name, sub {
79       my $self = shift;
80       @_ > 0 or $self->throw_exception(
81         "${add_meth} needs an object or hashref"
82       );
83       my $source = $self->result_source;
84       my $schema = $source->schema;
85       my $rel_source_name = $source->relationship_info($rel)->{source};
86       my $rel_source = $schema->resultset($rel_source_name)->result_source;
87       my $f_rel_source_name = $rel_source->relationship_info($f_rel)->{source};
88       my $f_rel_rs = $schema->resultset($f_rel_source_name)->search({}, $rel_attrs||{});
89
90       my $obj;
91       if (ref $_[0]) {
92         if (ref $_[0] eq 'HASH') {
93           $obj = $f_rel_rs->find_or_create($_[0]);
94         } else {
95           $obj = $_[0];
96         }
97       } else {
98         $obj = $f_rel_rs->find_or_create({@_});
99       }
100
101       my $link_vals = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
102       my $link = $self->search_related($rel)->new_result($link_vals);
103       $link->set_from_related($f_rel, $obj);
104       $link->insert();
105       return $obj;
106     };
107
108     my $set_meth_name = join '::', $class, $set_meth;
109     *$set_meth_name = Sub::Name::subname $set_meth_name, sub {
110       my $self = shift;
111       @_ > 0 or $self->throw_exception(
112         "{$set_meth} needs a list of objects or hashrefs"
113       );
114       my @to_set = (ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_);
115       # if there is a where clause in the attributes, ensure we only delete
116       # rows that are within the where restriction
117       if ($rel_attrs && $rel_attrs->{where}) {
118         $self->search_related( $rel, $rel_attrs->{where},{join => $f_rel})->delete;
119       } else {
120         $self->search_related( $rel, {} )->delete;
121       }
122       # add in the set rel objects
123       $self->$add_meth($_, ref($_[1]) ? $_[1] : {}) for (@to_set);
124     };
125
126     my $remove_meth_name = join '::', $class, $remove_meth;
127     *$remove_meth_name = Sub::Name::subname $remove_meth_name, sub {
128       my $self = shift;
129       @_ > 0 && ref $_[0] ne 'HASH'
130         or $self->throw_exception("${remove_meth} needs an object");
131       my $obj = shift;
132       my $rel_source = $self->search_related($rel)->result_source;
133       my $cond = $rel_source->relationship_info($f_rel)->{cond};
134       my $link_cond = $rel_source->_resolve_condition(
135         $cond, $obj, $f_rel
136       );
137       $self->search_related($rel, $link_cond)->delete;
138     };
139
140   }
141 }
142
143 1;