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