1 package # hide from PAUSE
2 DBIx::Class::Relationship::ManyToMany;
8 use Sub::Name 'subname';
9 use Scalar::Util 'blessed';
10 use DBIx::Class::_Util 'fail_on_internal_wantarray';
13 our %_pod_inherit_config =
15 class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
19 my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
21 $class->throw_exception(
22 "missing relation in many-to-many"
25 $class->throw_exception(
26 "missing foreign relation in many-to-many"
31 no warnings 'redefine';
33 my $add_meth = "add_to_${meth}";
34 my $remove_meth = "remove_from_${meth}";
35 my $set_meth = "set_${meth}";
36 my $rs_meth = "${meth}_rs";
38 for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
39 if ( $class->can ($_) ) {
40 carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
42 ***************************************************************************
43 The many-to-many relationship '$meth' is trying to create a utility method
45 This will completely overwrite one such already existing method on class
48 You almost certainly want to rename your method or the many-to-many
49 relationship, as the functionality of the original method will not be
52 To disable this warning set to a true value the environment variable
53 DBIC_OVERWRITE_HELPER_METHODS_OK
55 ***************************************************************************
60 $rel_attrs->{alias} ||= $f_rel;
62 my $rs_meth_name = join '::', $class, $rs_meth;
63 *$rs_meth_name = subname $rs_meth_name, sub {
65 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
66 my $rs = $self->search_related($rel)->search_related(
67 $f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs }
72 my $meth_name = join '::', $class, $meth;
73 *$meth_name = subname $meth_name, sub {
74 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray;
76 my $rs = $self->$rs_meth( @_ );
77 return (wantarray ? $rs->all : $rs);
80 my $add_meth_name = join '::', $class, $add_meth;
81 *$add_meth_name = subname $add_meth_name, sub {
83 @_ or $self->throw_exception(
84 "${add_meth} needs an object or hashref"
87 my $link = $self->new_related( $rel,
88 ( @_ > 1 && ref $_[-1] eq 'HASH' )
93 my $far_obj = defined blessed $_[0]
95 : $self->result_source
96 ->related_source( $rel )
97 ->related_source( $f_rel )
98 ->resultset->search_rs( {}, $rel_attrs||{} )
99 ->find_or_create( ref $_[0] eq 'HASH' ? $_[0] : {@_} )
102 $link->set_from_related($f_rel, $far_obj);
109 my $set_meth_name = join '::', $class, $set_meth;
110 *$set_meth_name = subname $set_meth_name, sub {
112 @_ > 0 or $self->throw_exception(
113 "{$set_meth} needs a list of objects or hashrefs"
116 my $guard = $self->result_source->schema->storage->txn_scope_guard;
118 # if there is a where clause in the attributes, ensure we only delete
119 # rows that are within the where restriction
121 if ($rel_attrs && $rel_attrs->{where}) {
122 $self->search_related( $rel, $rel_attrs->{where},{join => $f_rel})->delete;
124 $self->search_related( $rel, {} )->delete;
126 # add in the set rel objects
127 $self->$add_meth($_, ref($_[1]) ? $_[1] : {})
128 for ( ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_ );
133 my $remove_meth_name = join '::', $class, $remove_meth;
134 *$remove_meth_name = subname $remove_meth_name, sub {
135 my ($self, $obj) = @_;
137 $self->throw_exception("${remove_meth} needs an object")
138 unless blessed ($obj);
140 $self->search_related_rs($rel)->search_rs(
141 $obj->ident_condition( $f_rel ),