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; |
a9da9b6a |
8 | use Sub::Name 'subname'; |
9 | use Scalar::Util 'blessed'; |
10 | use DBIx::Class::_Util 'fail_on_internal_wantarray'; |
8f4b5c08 |
11 | use namespace::clean; |
12 | |
13 | our %_pod_inherit_config = |
044e70c7 |
14 | ( |
15 | class_map => { 'DBIx::Class::Relationship::ManyToMany' => 'DBIx::Class::Relationship' } |
16 | ); |
17 | |
8973b6f1 |
18 | sub many_to_many { |
78af1010 |
19 | my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_; |
d0ed3b55 |
20 | |
21 | $class->throw_exception( |
22 | "missing relation in many-to-many" |
23 | ) unless $rel; |
24 | |
25 | $class->throw_exception( |
26 | "missing foreign relation in many-to-many" |
27 | ) unless $f_rel; |
28 | |
8973b6f1 |
29 | { |
30 | no strict 'refs'; |
31 | no warnings 'redefine'; |
4b3ab474 |
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 | |
7141bdfc |
60 | $rel_attrs->{alias} ||= $f_rel; |
61 | |
9ab7393f |
62 | |
ddc0a6c8 |
63 | my $rs_meth_name = join '::', $class, $rs_meth; |
8f4b5c08 |
64 | *$rs_meth_name = subname $rs_meth_name, sub { |
9ab7393f |
65 | |
66 | # this little horror is there replicating a deprecation from |
67 | # within search_rs() itself |
68 | shift->search_related_rs($rel) |
69 | ->search_related_rs( |
70 | $f_rel, |
71 | undef, |
72 | ( @_ > 1 and ref $_[-1] eq 'HASH' ) |
73 | ? { %$rel_attrs, %{ pop @_ } } |
74 | : $rel_attrs |
75 | )->search_rs(@_) |
76 | ; |
77 | |
78af1010 |
78 | }; |
4b3ab474 |
79 | |
9ab7393f |
80 | |
ddc0a6c8 |
81 | my $meth_name = join '::', $class, $meth; |
8f4b5c08 |
82 | *$meth_name = subname $meth_name, sub { |
9ab7393f |
83 | |
e89c7968 |
84 | DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray; |
9ab7393f |
85 | |
86 | my $rs = shift->$rs_meth( @_ ); |
87 | |
88 | wantarray ? $rs->all : $rs; |
89 | |
d7a58a29 |
90 | }; |
18788bf2 |
91 | |
9ab7393f |
92 | |
ddc0a6c8 |
93 | my $add_meth_name = join '::', $class, $add_meth; |
8f4b5c08 |
94 | *$add_meth_name = subname $add_meth_name, sub { |
78060df8 |
95 | |
9ab7393f |
96 | ( @_ >= 2 and @_ <= 3 ) or $_[0]->throw_exception( |
97 | "'$add_meth' expects an object or hashref to link to, and an optional hashref of link data" |
3315c8d5 |
98 | ); |
99 | |
9ab7393f |
100 | $_[0]->throw_exception( |
101 | "The optional link data supplied to '$add_meth' is not a hashref (it was previously ignored)" |
102 | ) if $_[2] and ref $_[2] ne 'HASH'; |
3315c8d5 |
103 | |
9ab7393f |
104 | my( $self, $far_obj ) = @_; |
105 | |
106 | my $guard; |
107 | |
108 | # the API needs is always expected to return the far object, possibly |
109 | # creating it in the process |
110 | if( not defined blessed $far_obj ) { |
111 | |
112 | $guard = $self->result_source->schema->storage->txn_scope_guard; |
113 | |
114 | # reify the hash into an actual object |
115 | $far_obj = $self->result_source |
116 | ->related_source( $rel ) |
117 | ->related_source( $f_rel ) |
118 | ->resultset |
119 | ->search_rs( undef, $rel_attrs ) |
120 | ->find_or_create( $far_obj ); |
121 | } |
122 | |
123 | my $link = $self->new_related( |
124 | $rel, |
125 | $_[2] || {}, |
126 | ); |
127 | |
128 | $link->set_from_related( $f_rel, $far_obj ); |
5294fdc6 |
129 | |
303cf522 |
130 | $link->insert(); |
3315c8d5 |
131 | |
9ab7393f |
132 | $guard->commit if $guard; |
133 | |
134 | $far_obj; |
4b3ab474 |
135 | }; |
136 | |
9ab7393f |
137 | |
ddc0a6c8 |
138 | my $set_meth_name = join '::', $class, $set_meth; |
8f4b5c08 |
139 | *$set_meth_name = subname $set_meth_name, sub { |
a4cff052 |
140 | |
b3f358b5 |
141 | my $self = shift; |
a4cff052 |
142 | |
143 | my $set_to = ( ref $_[0] eq 'ARRAY' ) |
144 | ? ( shift @_ ) |
145 | : do { |
146 | carp_unique( |
147 | "Calling '$set_meth' with a list of items to link to is deprecated, use an arrayref instead" |
148 | ); |
149 | |
150 | # gobble up everything from @_ into a new arrayref |
151 | [ splice @_ ] |
152 | } |
153 | ; |
154 | |
155 | # make sure folks are not invoking a bizarre mix of deprecated and curent syntax |
156 | $self->throw_exception( |
157 | "'$set_meth' expects an arrayref of objects or hashrefs to link to, and an optional hashref of link data" |
158 | ) if ( |
159 | @_ > 1 |
160 | or |
161 | ( @_ and ref $_[0] ne 'HASH' ) |
b3f358b5 |
162 | ); |
5294fdc6 |
163 | |
9ab7393f |
164 | my $guard; |
165 | |
166 | # there will only be a single delete() op, unless we have what to set to |
167 | $guard = $self->result_source->schema->storage->txn_scope_guard |
168 | if @$set_to; |
5294fdc6 |
169 | |
f1f9ee17 |
170 | # if there is a where clause in the attributes, ensure we only delete |
171 | # rows that are within the where restriction |
9ab7393f |
172 | $self->search_related( |
173 | $rel, |
174 | ( $rel_attrs->{where} |
175 | ? ( $rel_attrs->{where}, { join => $f_rel } ) |
176 | : () |
177 | ) |
178 | )->delete; |
5294fdc6 |
179 | |
f1f9ee17 |
180 | # add in the set rel objects |
a4cff052 |
181 | $self->$add_meth( |
182 | $_, |
183 | @_, # at this point @_ is either empty or contains a lone link-data hash |
184 | ) for @$set_to; |
5294fdc6 |
185 | |
9ab7393f |
186 | $guard->commit if $guard; |
b3f358b5 |
187 | }; |
188 | |
9ab7393f |
189 | |
ddc0a6c8 |
190 | my $remove_meth_name = join '::', $class, $remove_meth; |
8f4b5c08 |
191 | *$remove_meth_name = subname $remove_meth_name, sub { |
5294fdc6 |
192 | |
9ab7393f |
193 | $_[0]->throw_exception("'$remove_meth' expects an object") |
194 | unless defined blessed $_[1]; |
aa56106b |
195 | |
9ab7393f |
196 | $_[0]->search_related_rs( $rel ) |
197 | ->search_rs( $_[1]->ident_condition( $f_rel ), { join => $f_rel } ) |
198 | ->delete; |
4b3ab474 |
199 | }; |
9ab7393f |
200 | |
8973b6f1 |
201 | } |
202 | } |
203 | |
204 | 1; |