1 package # hide from PAUSE
2 DBIx::Class::Relationship::ManyToMany;
8 use DBIx::Class::_Util qw( quote_sub perlstring );
10 # FIXME - this should go away
11 # instead Carp::Skip should export usable keywords or something like that
13 BEGIN { $unique_carper = \&carp_unique }
17 our %_pod_inherit_config =
19 class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
23 my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
25 $class->throw_exception(
26 "missing relation in many-to-many"
29 $class->throw_exception(
30 "missing foreign relation in many-to-many"
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 my @main_meth_qsub_args = (
63 'DBIC_method_is_indirect_sugar',
64 ( keys( %{$rel_attrs||{}} )
65 ? 'DBIC_method_is_m2m_sugar_with_attrs'
66 : 'DBIC_method_is_m2m_sugar'
72 quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args;
73 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
74 shift->%s( @_ )->search;
78 my @extra_meth_qsub_args = (
80 '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
81 '$carp_unique' => \$unique_carper,
84 'DBIC_method_is_indirect_sugar',
85 ( keys( %{$rel_attrs||{}} )
86 ? 'DBIC_method_is_m2m_extra_sugar_with_attrs'
87 : 'DBIC_method_is_m2m_extra_sugar'
93 quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args;
95 DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
97 # allow nested calls from our ->many_to_many, see comment below
98 ( (CORE::caller(1))[3] ne %s )
100 DBIx::Class::_Util::fail_on_internal_call;
102 # this little horror is there replicating a deprecation from
103 # within search_rs() itself
104 shift->related_resultset( %s )
105 ->related_resultset( %s )
108 ( @_ > 1 and ref $_[-1] eq 'HASH' )
109 ? { %%$rel_attrs, %%{ pop @_ } }
115 # the above is the only indirect method, the 3 below have too much logic
116 shift @{$extra_meth_qsub_args[1]{attributes}};
119 quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
121 ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception(
122 "'%1$s' expects an object or hashref to link to, and an optional hashref of link data"
125 $_[0]->throw_exception(
126 "The optional link data supplied to '%1$s' is not a hashref (it was previously ignored)"
127 ) if $_[2] and ref $_[2] ne 'HASH';
129 my( $self, $far_obj ) = @_;
133 # the API is always expected to return the far object, possibly
134 # creating it in the process
135 if( not defined Scalar::Util::blessed( $far_obj ) ) {
137 $guard = $self->result_source->schema->storage->txn_scope_guard;
139 # reify the hash into an actual object
140 $far_obj = $self->result_source
141 ->related_source( q{%2$s} )
142 ->related_source( q{%3$s} )
144 ->search_rs( undef, $rel_attrs )
145 ->find_or_create( $far_obj );
148 my $link = $self->new_related(
153 $link->set_from_related( q{%3$s}, $far_obj );
157 $guard->commit if $guard;
163 quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
167 my $set_to = ( ref $_[0] eq 'ARRAY' )
171 "Calling '%1$s' with a list of items to link to is deprecated, use an arrayref instead"
174 # gobble up everything from @_ into a new arrayref
179 # make sure folks are not invoking a bizarre mix of deprecated and curent syntax
180 $self->throw_exception(
181 "'%1$s' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data"
185 ( defined $_[0] and ref $_[0] ne 'HASH' )
190 # there will only be a single delete() op, unless we have what to set to
191 $guard = $self->result_source->schema->storage->txn_scope_guard
194 # if there is a where clause in the attributes, ensure we only delete
195 # rows that are within the where restriction
196 $self->related_resultset( q{%3$s} )
198 ( $rel_attrs->{where}
199 ? ( $rel_attrs->{where}, { join => q{%4$s} } )
204 # add in the set rel objects
207 @_, # at this point @_ is either empty or contains a lone link-data hash
210 $guard->commit if $guard;
214 # the last method needs no captures - just kill it all with fire
215 $extra_meth_qsub_args[0] = {};
218 quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args;
220 $_[0]->throw_exception("'%1$s' expects an object")
221 unless defined Scalar::Util::blessed( $_[1] );
223 $_[0]->related_resultset( q{%2$s} )
224 ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } )