Commit | Line | Data |
75d07914 |
1 | package # hide from PAUSE |
c0e7b4e5 |
2 | DBIx::Class::Relationship::ManyToMany; |
8973b6f1 |
3 | |
4 | use strict; |
5 | use warnings; |
b234e9d9 |
6 | |
70c28808 |
7 | use DBIx::Class::Carp; |
d99f2db7 |
8 | use DBIx::Class::_Util qw( quote_sub perlstring ); |
11e469d9 |
9 | |
e5c63829 |
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 } |
11e469d9 |
14 | |
8f4b5c08 |
15 | use namespace::clean; |
16 | |
17 | our %_pod_inherit_config = |
044e70c7 |
18 | ( |
19 | class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' } |
20 | ); |
21 | |
8973b6f1 |
22 | sub many_to_many { |
78af1010 |
23 | my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_; |
d0ed3b55 |
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 | |
b3f358b5 |
33 | my $add_meth = "add_to_${meth}"; |
34 | my $remove_meth = "remove_from_${meth}"; |
35 | my $set_meth = "set_${meth}"; |
18788bf2 |
36 | my $rs_meth = "${meth}_rs"; |
303cf522 |
37 | |
35210a5d |
38 | for ($add_meth, $remove_meth, $set_meth, $rs_meth) { |
d81b2771 |
39 | if ( $class->can ($_) ) { |
b7d1831a |
40 | carp (<<"EOW") unless $ENV{DBIC_OVERWRITE_HELPER_METHODS_OK}; |
b234e9d9 |
41 | |
35678f0b |
42 | *************************************************************************** |
b234e9d9 |
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. |
d81b2771 |
47 | |
b234e9d9 |
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. |
d81b2771 |
51 | |
b7d1831a |
52 | To disable this warning set to a true value the environment variable |
53 | DBIC_OVERWRITE_HELPER_METHODS_OK |
35678f0b |
54 | |
35678f0b |
55 | *************************************************************************** |
56 | EOW |
d81b2771 |
57 | } |
35210a5d |
58 | } |
59 | |
1b822bd3 |
60 | my @main_meth_qsub_args = ( |
61 | {}, |
62 | { attributes => [ |
63 | 'DBIC_method_is_indirect_sugar', |
09d8fb4a |
64 | ( keys( %{$rel_attrs||{}} ) |
65 | ? 'DBIC_method_is_m2m_sugar_with_attrs' |
66 | : 'DBIC_method_is_m2m_sugar' |
67 | ), |
1b822bd3 |
68 | ] }, |
69 | ); |
70 | |
71 | |
72 | quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args; |
d46eac43 |
73 | DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; |
13fd7cde |
74 | shift->%s( @_ )->search; |
d46eac43 |
75 | EOC |
76 | |
77 | |
1b822bd3 |
78 | my @extra_meth_qsub_args = ( |
79 | { |
80 | '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, |
e5c63829 |
81 | '$carp_unique' => \$unique_carper, |
1b822bd3 |
82 | }, |
83 | { attributes => [ |
84 | 'DBIC_method_is_indirect_sugar', |
09d8fb4a |
85 | ( keys( %{$rel_attrs||{}} ) |
86 | ? 'DBIC_method_is_m2m_extra_sugar_with_attrs' |
87 | : 'DBIC_method_is_m2m_extra_sugar' |
88 | ), |
1b822bd3 |
89 | ] }, |
90 | ); |
69831300 |
91 | |
d46eac43 |
92 | |
1b822bd3 |
93 | quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args; |
d99f2db7 |
94 | |
95 | DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS |
96 | and |
97 | # allow nested calls from our ->many_to_many, see comment below |
98 | ( (CORE::caller(1))[3] ne %s ) |
99 | and |
100 | DBIx::Class::_Util::fail_on_internal_call; |
69831300 |
101 | |
102 | # this little horror is there replicating a deprecation from |
103 | # within search_rs() itself |
d99f2db7 |
104 | shift->related_resultset( %s ) |
105 | ->related_resultset( %s ) |
e5053694 |
106 | ->search_rs ( |
107 | undef, |
108 | ( @_ > 1 and ref $_[-1] eq 'HASH' ) |
109 | ? { %%$rel_attrs, %%{ pop @_ } } |
110 | : $rel_attrs |
111 | )->search_rs(@_) |
69831300 |
112 | ; |
11e469d9 |
113 | EOC |
4b3ab474 |
114 | |
1b822bd3 |
115 | # the above is the only indirect method, the 3 below have too much logic |
116 | shift @{$extra_meth_qsub_args[1]{attributes}}; |
69831300 |
117 | |
1b822bd3 |
118 | |
119 | quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; |
78060df8 |
120 | |
69831300 |
121 | ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception( |
11e469d9 |
122 | "'%1$s' expects an object or hashref to link to, and an optional hashref of link data" |
86ed11c9 |
123 | ); |
124 | |
69831300 |
125 | $_[0]->throw_exception( |
11e469d9 |
126 | "The optional link data supplied to '%1$s' is not a hashref (it was previously ignored)" |
69831300 |
127 | ) if $_[2] and ref $_[2] ne 'HASH'; |
86ed11c9 |
128 | |
69831300 |
129 | my( $self, $far_obj ) = @_; |
130 | |
131 | my $guard; |
132 | |
d46eac43 |
133 | # the API is always expected to return the far object, possibly |
69831300 |
134 | # creating it in the process |
11e469d9 |
135 | if( not defined Scalar::Util::blessed( $far_obj ) ) { |
69831300 |
136 | |
137 | $guard = $self->result_source->schema->storage->txn_scope_guard; |
138 | |
139 | # reify the hash into an actual object |
140 | $far_obj = $self->result_source |
11e469d9 |
141 | ->related_source( q{%2$s} ) |
142 | ->related_source( q{%3$s} ) |
69831300 |
143 | ->resultset |
144 | ->search_rs( undef, $rel_attrs ) |
145 | ->find_or_create( $far_obj ); |
146 | } |
147 | |
148 | my $link = $self->new_related( |
11e469d9 |
149 | q{%2$s}, |
69831300 |
150 | $_[2] || {}, |
151 | ); |
152 | |
11e469d9 |
153 | $link->set_from_related( q{%3$s}, $far_obj ); |
12d4ace4 |
154 | |
303cf522 |
155 | $link->insert(); |
86ed11c9 |
156 | |
69831300 |
157 | $guard->commit if $guard; |
158 | |
159 | $far_obj; |
11e469d9 |
160 | EOC |
4b3ab474 |
161 | |
69831300 |
162 | |
1b822bd3 |
163 | quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; |
8a67d9cf |
164 | |
b3f358b5 |
165 | my $self = shift; |
8a67d9cf |
166 | |
167 | my $set_to = ( ref $_[0] eq 'ARRAY' ) |
168 | ? ( shift @_ ) |
169 | : do { |
11e469d9 |
170 | $carp_unique->( |
171 | "Calling '%1$s' with a list of items to link to is deprecated, use an arrayref instead" |
8a67d9cf |
172 | ); |
173 | |
174 | # gobble up everything from @_ into a new arrayref |
175 | [ splice @_ ] |
176 | } |
177 | ; |
178 | |
179 | # make sure folks are not invoking a bizarre mix of deprecated and curent syntax |
180 | $self->throw_exception( |
11e469d9 |
181 | "'%1$s' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data" |
8a67d9cf |
182 | ) if ( |
183 | @_ > 1 |
184 | or |
2d9a96fd |
185 | ( defined $_[0] and ref $_[0] ne 'HASH' ) |
b3f358b5 |
186 | ); |
12d4ace4 |
187 | |
69831300 |
188 | my $guard; |
189 | |
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 |
192 | if @$set_to; |
12d4ace4 |
193 | |
f1f9ee17 |
194 | # if there is a where clause in the attributes, ensure we only delete |
195 | # rows that are within the where restriction |
e5053694 |
196 | $self->related_resultset( q{%3$s} ) |
197 | ->search_rs( |
198 | ( $rel_attrs->{where} |
199 | ? ( $rel_attrs->{where}, { join => q{%4$s} } ) |
200 | : () |
201 | ) |
202 | )->delete; |
12d4ace4 |
203 | |
f1f9ee17 |
204 | # add in the set rel objects |
11e469d9 |
205 | $self->%2$s( |
8a67d9cf |
206 | $_, |
207 | @_, # at this point @_ is either empty or contains a lone link-data hash |
208 | ) for @$set_to; |
12d4ace4 |
209 | |
69831300 |
210 | $guard->commit if $guard; |
11e469d9 |
211 | EOC |
b3f358b5 |
212 | |
09d8fb4a |
213 | |
214 | # the last method needs no captures - just kill it all with fire |
215 | $extra_meth_qsub_args[0] = {}; |
216 | |
217 | |
1b822bd3 |
218 | quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args; |
12d4ace4 |
219 | |
11e469d9 |
220 | $_[0]->throw_exception("'%1$s' expects an object") |
221 | unless defined Scalar::Util::blessed( $_[1] ); |
aa56106b |
222 | |
e5053694 |
223 | $_[0]->related_resultset( q{%2$s} ) |
11e469d9 |
224 | ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } ) |
69831300 |
225 | ->delete; |
11e469d9 |
226 | EOC |
69831300 |
227 | |
8973b6f1 |
228 | } |
229 | |
230 | 1; |