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