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', |
63 | ] }, |
64 | ); |
65 | |
66 | |
67 | quote_sub "${class}::${meth}", sprintf( <<'EOC', $rs_meth ), @main_meth_qsub_args; |
d46eac43 |
68 | |
69 | DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and DBIx::Class::_Util::fail_on_internal_call; |
70 | DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray; |
71 | |
72 | my $rs = shift->%s( @_ ); |
73 | |
74 | wantarray ? $rs->all : $rs; |
75 | EOC |
76 | |
77 | |
1b822bd3 |
78 | my @extra_meth_qsub_args = ( |
79 | { |
80 | '$rel_attrs' => \{ alias => $f_rel, %{ $rel_attrs||{} } }, |
81 | '$carp_unique' => \$cu, |
82 | }, |
83 | { attributes => [ |
84 | 'DBIC_method_is_indirect_sugar', |
85 | ] }, |
86 | ); |
69831300 |
87 | |
d46eac43 |
88 | |
1b822bd3 |
89 | quote_sub "${class}::${rs_meth}", sprintf( <<'EOC', map { perlstring $_ } ( "${class}::${meth}", $rel, $f_rel ) ), @extra_meth_qsub_args; |
d99f2db7 |
90 | |
91 | DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS |
92 | and |
93 | # allow nested calls from our ->many_to_many, see comment below |
94 | ( (CORE::caller(1))[3] ne %s ) |
95 | and |
96 | DBIx::Class::_Util::fail_on_internal_call; |
69831300 |
97 | |
98 | # this little horror is there replicating a deprecation from |
99 | # within search_rs() itself |
d99f2db7 |
100 | shift->related_resultset( %s ) |
101 | ->related_resultset( %s ) |
e5053694 |
102 | ->search_rs ( |
103 | undef, |
104 | ( @_ > 1 and ref $_[-1] eq 'HASH' ) |
105 | ? { %%$rel_attrs, %%{ pop @_ } } |
106 | : $rel_attrs |
107 | )->search_rs(@_) |
69831300 |
108 | ; |
11e469d9 |
109 | EOC |
4b3ab474 |
110 | |
1b822bd3 |
111 | # the above is the only indirect method, the 3 below have too much logic |
112 | shift @{$extra_meth_qsub_args[1]{attributes}}; |
69831300 |
113 | |
1b822bd3 |
114 | |
115 | quote_sub "${class}::${add_meth}", sprintf( <<'EOC', $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; |
78060df8 |
116 | |
69831300 |
117 | ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception( |
11e469d9 |
118 | "'%1$s' expects an object or hashref to link to, and an optional hashref of link data" |
86ed11c9 |
119 | ); |
120 | |
69831300 |
121 | $_[0]->throw_exception( |
11e469d9 |
122 | "The optional link data supplied to '%1$s' is not a hashref (it was previously ignored)" |
69831300 |
123 | ) if $_[2] and ref $_[2] ne 'HASH'; |
86ed11c9 |
124 | |
69831300 |
125 | my( $self, $far_obj ) = @_; |
126 | |
127 | my $guard; |
128 | |
d46eac43 |
129 | # the API is always expected to return the far object, possibly |
69831300 |
130 | # creating it in the process |
11e469d9 |
131 | if( not defined Scalar::Util::blessed( $far_obj ) ) { |
69831300 |
132 | |
133 | $guard = $self->result_source->schema->storage->txn_scope_guard; |
134 | |
135 | # reify the hash into an actual object |
136 | $far_obj = $self->result_source |
11e469d9 |
137 | ->related_source( q{%2$s} ) |
138 | ->related_source( q{%3$s} ) |
69831300 |
139 | ->resultset |
140 | ->search_rs( undef, $rel_attrs ) |
141 | ->find_or_create( $far_obj ); |
142 | } |
143 | |
144 | my $link = $self->new_related( |
11e469d9 |
145 | q{%2$s}, |
69831300 |
146 | $_[2] || {}, |
147 | ); |
148 | |
11e469d9 |
149 | $link->set_from_related( q{%3$s}, $far_obj ); |
12d4ace4 |
150 | |
303cf522 |
151 | $link->insert(); |
86ed11c9 |
152 | |
69831300 |
153 | $guard->commit if $guard; |
154 | |
155 | $far_obj; |
11e469d9 |
156 | EOC |
4b3ab474 |
157 | |
69831300 |
158 | |
1b822bd3 |
159 | quote_sub "${class}::${set_meth}", sprintf( <<'EOC', $set_meth, $add_meth, $rel, $f_rel ), @extra_meth_qsub_args; |
8a67d9cf |
160 | |
b3f358b5 |
161 | my $self = shift; |
8a67d9cf |
162 | |
163 | my $set_to = ( ref $_[0] eq 'ARRAY' ) |
164 | ? ( shift @_ ) |
165 | : do { |
11e469d9 |
166 | $carp_unique->( |
167 | "Calling '%1$s' with a list of items to link to is deprecated, use an arrayref instead" |
8a67d9cf |
168 | ); |
169 | |
170 | # gobble up everything from @_ into a new arrayref |
171 | [ splice @_ ] |
172 | } |
173 | ; |
174 | |
175 | # make sure folks are not invoking a bizarre mix of deprecated and curent syntax |
176 | $self->throw_exception( |
11e469d9 |
177 | "'%1$s' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data" |
8a67d9cf |
178 | ) if ( |
179 | @_ > 1 |
180 | or |
2d9a96fd |
181 | ( defined $_[0] and ref $_[0] ne 'HASH' ) |
b3f358b5 |
182 | ); |
12d4ace4 |
183 | |
69831300 |
184 | my $guard; |
185 | |
186 | # there will only be a single delete() op, unless we have what to set to |
187 | $guard = $self->result_source->schema->storage->txn_scope_guard |
188 | if @$set_to; |
12d4ace4 |
189 | |
f1f9ee17 |
190 | # if there is a where clause in the attributes, ensure we only delete |
191 | # rows that are within the where restriction |
e5053694 |
192 | $self->related_resultset( q{%3$s} ) |
193 | ->search_rs( |
194 | ( $rel_attrs->{where} |
195 | ? ( $rel_attrs->{where}, { join => q{%4$s} } ) |
196 | : () |
197 | ) |
198 | )->delete; |
12d4ace4 |
199 | |
f1f9ee17 |
200 | # add in the set rel objects |
11e469d9 |
201 | $self->%2$s( |
8a67d9cf |
202 | $_, |
203 | @_, # at this point @_ is either empty or contains a lone link-data hash |
204 | ) for @$set_to; |
12d4ace4 |
205 | |
69831300 |
206 | $guard->commit if $guard; |
11e469d9 |
207 | EOC |
b3f358b5 |
208 | |
1b822bd3 |
209 | quote_sub "${class}::${remove_meth}", sprintf( <<'EOC', $remove_meth, $rel, $f_rel ), @extra_meth_qsub_args; |
12d4ace4 |
210 | |
11e469d9 |
211 | $_[0]->throw_exception("'%1$s' expects an object") |
212 | unless defined Scalar::Util::blessed( $_[1] ); |
aa56106b |
213 | |
e5053694 |
214 | $_[0]->related_resultset( q{%2$s} ) |
11e469d9 |
215 | ->search_rs( $_[1]->ident_condition( q{%3$s} ), { join => q{%3$s} } ) |
69831300 |
216 | ->delete; |
11e469d9 |
217 | EOC |
69831300 |
218 | |
8973b6f1 |
219 | } |
220 | |
221 | 1; |