1package # hide from PAUSE
2    DBIx::Class::Relationship::ManyToMany;
3
4use strict;
5use warnings;
6
7use Carp::Clan qw/^DBIx::Class/;
8use Sub::Name ();
9
10our %_pod_inherit_config =
11  (
12   class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
13  );
14
15sub 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***************************************************************************
40The many-to-many relationship '$meth' is trying to create a utility method
41called $_.
42This will completely overwrite one such already existing method on class
43$class.
44
45You almost certainly want to rename your method or the many-to-many
46relationship, as the functionality of the original method will not be
47accessible anymore.
48
49To disable this warning set to a true value the environment variable
50DBIC_OVERWRITE_HELPER_METHODS_OK
51
52***************************************************************************
53EOW
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
1431;
144