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