Protect several resolve_relationship_condition() callsites
[dbsrgits/DBIx-Class.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 DBIx::Class::Carp;
8 use DBIx::Class::_Util qw( quote_sub perlstring );
9
10 # FIXME - this should go away
11 # instead Carp::Skip should export usable keywords or something like that
12 my $unique_carper;
13 BEGIN { $unique_carper = \&carp_unique }
14
15 use namespace::clean;
16
17 our %_pod_inherit_config =
18   (
19    class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' }
20   );
21
22 sub many_to_many {
23   my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
24
25   $class->throw_exception(
26     "missing relation in many-to-many"
27   ) unless $rel;
28
29   $class->throw_exception(
30     "missing foreign relation in many-to-many"
31   ) unless $f_rel;
32
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";
37
38     for ($add_meth, $remove_meth, $set_meth, $rs_meth) {
39       if ( $class->can ($_) ) {
40         carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK};
41
42 ***************************************************************************
43 The many-to-many relationship '$meth' is trying to create a utility method
44 called $_.
45 This will completely overwrite one such already existing method on class
46 $class.
47
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
50 accessible anymore.
51
52 To disable this warning set to a true value the environment variable
53 DBIC_OVERWRITE_HELPER_METHODS_OK
54
55 ***************************************************************************
56 EOW
57       }
58     }
59
60     my @main_meth_qsub_args = (
61       {},
62       { attributes => [
63         'DBIC_method_is_indirect_sugar',
64         ( keys( %{$rel_attrs||{}} )
65           ? 'DBIC_method_is_m2m_sugar_with_attrs'
66           : 'DBIC_method_is_m2m_sugar'
67         ),
68       ] },
69     );
70
71
72     quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args;
73
74       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call;
75       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
76
77       my $rs = shift->%s( @_ );
78
79       wantarray ? $rs->all : $rs;
80 EOC
81
82
83     my @extra_meth_qsub_args = (
84       {
85         '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } },
86         '$carp_unique' => \$unique_carper,
87       },
88       { attributes => [
89         'DBIC_method_is_indirect_sugar',
90         ( keys( %{$rel_attrs||{}} )
91           ? 'DBIC_method_is_m2m_extra_sugar_with_attrs'
92           : 'DBIC_method_is_m2m_extra_sugar'
93         ),
94       ] },
95     );
96
97
98     quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args;
99
100       DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS
101         and
102       # allow nested calls from our ->many_to_many, see comment below
103       ( (CORE::caller(1))[3] ne %s )
104         and
105       DBIx::Class::_Util::fail_on_internal_call;
106
107       # this little horror is there replicating a deprecation from
108       # within search_rs() itself
109       shift->related_resultset( %s )
110             ->related_resultset( %s )
111              ->search_rs (
112                undef,
113                ( @_ > 1 and ref $_[-1] eq 'HASH' )
114                  ? { %%$rel_attrs, %%{ pop @_ } }
115                  : $rel_attrs
116              )->search_rs(@_)
117       ;
118 EOC
119
120     # the above is the only indirect method, the 3 below have too much logic
121     shift @{$extra_meth_qsub_args[1]{attributes}};
122
123
124     quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
125
126       ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception(
127         "'%1$s' expects an object or hashref to link to, and an optional hashref of link data"
128       );
129
130       $_[0]->throw_exception(
131         "The optional link data supplied to '%1$s' is not a hashref (it was previously ignored)"
132       ) if $_[2] and ref $_[2] ne 'HASH';
133
134       my( $self, $far_obj ) = @_;
135
136       my $guard;
137
138       # the API is always expected to return the far object, possibly
139       # creating it in the process
140       if( not defined Scalar::Util::blessed( $far_obj ) ) {
141
142         $guard = $self->result_source->schema->storage->txn_scope_guard;
143
144         # reify the hash into an actual object
145         $far_obj = $self->result_source
146                          ->related_source( q{%2$s} )
147                           ->related_source( q{%3$s} )
148                            ->resultset
149                             ->search_rs( undef, $rel_attrs )
150                              ->find_or_create( $far_obj );
151       }
152
153       my $link = $self->new_related(
154         q{%2$s},
155         $_[2] || {},
156       );
157
158       $link->set_from_related( q{%3$s}, $far_obj );
159
160       $link->insert();
161
162       $guard->commit if $guard;
163
164       $far_obj;
165 EOC
166
167
168     quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args;
169
170       my $self = shift;
171
172       my $set_to = ( ref $_[0] eq 'ARRAY' )
173         ? ( shift @_ )
174         : do {
175           $carp_unique->(
176             "Calling '%1$s' with a list of items to link to is deprecated, use an arrayref instead"
177           );
178
179           # gobble up everything from @_ into a new arrayref
180           [ splice @_ ]
181         }
182       ;
183
184       # make sure folks are not invoking a bizarre mix of deprecated and curent syntax
185       $self->throw_exception(
186         "'%1$s' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data"
187       ) if (
188         @_ > 1
189           or
190         ( defined $_[0] and ref $_[0] ne 'HASH' )
191       );
192
193       my $guard;
194
195       # there will only be a single delete() op, unless we have what to set to
196       $guard = $self->result_source->schema->storage->txn_scope_guard
197         if @$set_to;
198
199       # if there is a where clause in the attributes, ensure we only delete
200       # rows that are within the where restriction
201       $self->related_resultset( q{%3$s} )
202             ->search_rs(
203               ( $rel_attrs->{where}
204                 ? ( $rel_attrs->{where}, { join => q{%4$s} } )
205                 : ()
206               )
207             )->delete;
208
209       # add in the set rel objects
210       $self->%2$s(
211         $_,
212         @_, # at this point @_ is either empty or contains a lone link-data hash
213       ) for @$set_to;
214
215       $guard->commit if $guard;
216 EOC
217
218
219     # the last method needs no captures - just kill it all with fire
220     $extra_meth_qsub_args[0] = {};
221
222
223     quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args;
224
225       $_[0]->throw_exception("'%1$s' expects an object")
226         unless defined Scalar::Util::blessed( $_[1] );
227
228       $_[0]->related_resultset( q{%2$s} )
229             ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } )
230              ->delete;
231 EOC
232
233 }
234
235 1;