line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
10
|
|
|
10
|
|
1381688
|
use strict; |
|
10
|
|
|
|
|
95
|
|
|
10
|
|
|
|
|
309
|
|
2
|
10
|
|
|
10
|
|
49
|
use warnings; |
|
10
|
|
|
|
|
19
|
|
|
10
|
|
|
|
|
518
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package DBIx::Class::ResultSet::RecursiveUpdate; |
5
|
|
|
|
|
|
|
$DBIx::Class::ResultSet::RecursiveUpdate::VERSION = '0.40'; |
6
|
|
|
|
|
|
|
# ABSTRACT: like update_or_create - but recursive |
7
|
|
|
|
|
|
|
|
8
|
10
|
|
|
10
|
|
50
|
use base qw(DBIx::Class::ResultSet); |
|
10
|
|
|
|
|
20
|
|
|
10
|
|
|
|
|
7200
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
sub recursive_update { |
11
|
62
|
|
|
62
|
1
|
6889063
|
my ( $self, $updates, $attrs ) = @_; |
12
|
|
|
|
|
|
|
|
13
|
62
|
|
|
|
|
255
|
my $fixed_fields; |
14
|
|
|
|
|
|
|
my $unknown_params_ok; |
15
|
62
|
|
|
|
|
0
|
my $m2m_force_set_rel; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# 0.21+ api |
18
|
62
|
100
|
100
|
|
|
559
|
if ( defined $attrs && ref $attrs eq 'HASH' ) { |
|
|
100
|
66
|
|
|
|
|
19
|
5
|
|
|
|
|
17
|
$fixed_fields = $attrs->{fixed_fields}; |
20
|
5
|
|
|
|
|
13
|
$unknown_params_ok = $attrs->{unknown_params_ok}; |
21
|
5
|
|
|
|
|
12
|
$m2m_force_set_rel = $attrs->{m2m_force_set_rel}; |
22
|
|
|
|
|
|
|
} |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# pre 0.21 api |
25
|
|
|
|
|
|
|
elsif ( defined $attrs && ref $attrs eq 'ARRAY' ) { |
26
|
1
|
|
|
|
|
17
|
$fixed_fields = $attrs; |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
62
|
|
|
|
|
334
|
return DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update( |
30
|
|
|
|
|
|
|
resultset => $self, |
31
|
|
|
|
|
|
|
updates => $updates, |
32
|
|
|
|
|
|
|
fixed_fields => $fixed_fields, |
33
|
|
|
|
|
|
|
unknown_params_ok => $unknown_params_ok, |
34
|
|
|
|
|
|
|
m2m_force_set_rel => $m2m_force_set_rel, |
35
|
|
|
|
|
|
|
); |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
package DBIx::Class::ResultSet::RecursiveUpdate::Functions; |
39
|
|
|
|
|
|
|
$DBIx::Class::ResultSet::RecursiveUpdate::Functions::VERSION = '0.40'; |
40
|
10
|
|
|
10
|
|
398807
|
use Carp::Clan qw/^DBIx::Class|^HTML::FormHandler|^Try::Tiny/; |
|
10
|
|
|
|
|
15208
|
|
|
10
|
|
|
|
|
59
|
|
41
|
10
|
|
|
10
|
|
1108
|
use Scalar::Util qw( blessed ); |
|
10
|
|
|
|
|
22
|
|
|
10
|
|
|
|
|
537
|
|
42
|
10
|
|
|
10
|
|
4602
|
use List::MoreUtils qw/ any all none /; |
|
10
|
|
|
|
|
96096
|
|
|
10
|
|
|
|
|
69
|
|
43
|
10
|
|
|
10
|
|
10111
|
use Try::Tiny; |
|
10
|
|
|
|
|
23
|
|
|
10
|
|
|
|
|
559
|
|
44
|
10
|
|
|
10
|
|
4438
|
use Data::Dumper::Concise; |
|
10
|
|
|
|
|
57921
|
|
|
10
|
|
|
|
|
944
|
|
45
|
|
|
|
|
|
|
|
46
|
10
|
|
|
10
|
|
69
|
use constant DEBUG => 0; |
|
10
|
|
|
|
|
26
|
|
|
10
|
|
|
|
|
39383
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub recursive_update { |
49
|
217
|
|
|
217
|
|
1621084
|
my %params = @_; |
50
|
|
|
|
|
|
|
my ( $self, $updates, $fixed_fields, $object, $resolved, $if_not_submitted, |
51
|
|
|
|
|
|
|
$unknown_params_ok, $m2m_force_set_rel ) |
52
|
|
|
|
|
|
|
= @params{ |
53
|
217
|
|
|
|
|
1129
|
qw/resultset updates fixed_fields object resolved if_not_submitted unknown_params_ok m2m_force_set_rel/ |
54
|
|
|
|
|
|
|
}; |
55
|
217
|
|
100
|
|
|
924
|
$resolved ||= {}; |
56
|
217
|
|
|
|
|
1554
|
$ENV{DBIC_NULLABLE_KEY_NOWARN} = 1; |
57
|
|
|
|
|
|
|
|
58
|
217
|
|
|
|
|
863
|
my $source = $self->result_source; |
59
|
|
|
|
|
|
|
|
60
|
217
|
50
|
|
|
|
761
|
croak "first parameter needs to be defined" |
61
|
|
|
|
|
|
|
unless defined $updates; |
62
|
|
|
|
|
|
|
|
63
|
217
|
50
|
|
|
|
728
|
croak "first parameter needs to be a hashref" |
64
|
|
|
|
|
|
|
unless ref($updates) eq 'HASH'; |
65
|
|
|
|
|
|
|
|
66
|
217
|
50
|
66
|
|
|
736
|
croak 'fixed fields needs to be an arrayref' |
67
|
|
|
|
|
|
|
if defined $fixed_fields && ref $fixed_fields ne 'ARRAY'; |
68
|
|
|
|
|
|
|
|
69
|
217
|
|
|
|
|
360
|
DEBUG and warn "recursive_update: " . $source->name . "\n"; |
70
|
217
|
100
|
|
|
|
605
|
DEBUG and warn "object passed, skipping find" . |
71
|
|
|
|
|
|
|
(defined $object->id |
72
|
|
|
|
|
|
|
? " (id " . $object->id . ")\n" |
73
|
|
|
|
|
|
|
: "\n") |
74
|
|
|
|
|
|
|
if defined $object; |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# always warn about additional parameters if storage debugging is enabled |
77
|
217
|
100
|
|
|
|
814
|
$unknown_params_ok = 0 |
78
|
|
|
|
|
|
|
if $source->storage->debug; |
79
|
|
|
|
|
|
|
|
80
|
217
|
50
|
33
|
|
|
10029
|
if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) { |
81
|
0
|
|
|
|
|
0
|
return $updates; |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
|
84
|
217
|
|
|
|
|
725
|
my @pks = $source->primary_columns; |
85
|
217
|
|
|
|
|
1343
|
my %pk_kvs; |
86
|
217
|
|
|
|
|
503
|
for my $colname (@pks) { |
87
|
279
|
100
|
66
|
|
|
1145
|
if (exists $updates->{$colname} && defined $updates->{$colname}) { |
88
|
139
|
|
|
|
|
337
|
$pk_kvs{$colname} = $updates->{$colname}; |
89
|
139
|
|
|
|
|
295
|
next; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
$pk_kvs{$colname} = $resolved->{$colname} |
92
|
140
|
100
|
100
|
|
|
796
|
if exists $resolved->{$colname} && defined $resolved->{$colname}; |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
# support the special case where a method on the related row |
95
|
|
|
|
|
|
|
# populates one or more primary key columns and we don't have |
96
|
|
|
|
|
|
|
# all primary key values already |
97
|
|
|
|
|
|
|
# see DBSchema::Result::DVD relationship keysbymethod |
98
|
217
|
|
|
|
|
336
|
DEBUG and warn "pk columns so far: " . join (', ', |
99
|
|
|
|
|
|
|
sort keys %pk_kvs) . "\n"; |
100
|
|
|
|
|
|
|
my @non_pk_columns = grep { |
101
|
217
|
|
|
|
|
915
|
my $colname = $_; |
|
409
|
|
|
|
|
768
|
|
102
|
409
|
|
|
263
|
|
2417
|
none { $colname eq $_ } keys %pk_kvs |
|
263
|
|
|
|
|
1075
|
|
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
sort keys %$updates; |
105
|
217
|
|
|
|
|
435
|
DEBUG and warn "non-pk columns: " . join (', ', |
106
|
|
|
|
|
|
|
@non_pk_columns) . "\n"; |
107
|
217
|
100
|
66
|
|
|
955
|
if ( scalar keys %pk_kvs != scalar @pks && @non_pk_columns) { |
108
|
80
|
|
|
|
|
290
|
DEBUG and warn "not all primary keys available, trying " . |
109
|
|
|
|
|
|
|
"object creation\n"; |
110
|
|
|
|
|
|
|
# new_result throws exception if non column values are passed |
111
|
|
|
|
|
|
|
# because we want to also support e.g. a BUILDARGS method that |
112
|
|
|
|
|
|
|
# populates primary key columns from an additional value |
113
|
|
|
|
|
|
|
# filter out all relationships |
114
|
|
|
|
|
|
|
my @non_rel_columns = grep { |
115
|
80
|
|
100
|
|
|
227
|
!is_m2m( $self, $_ ) |
|
187
|
|
|
|
|
2156
|
|
116
|
|
|
|
|
|
|
&& !$source->has_relationship($_) |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
sort keys %$updates; |
119
|
|
|
|
|
|
|
my %non_rel_updates = map { |
120
|
80
|
|
|
|
|
1748
|
$_ => $updates->{$_} |
|
121
|
|
|
|
|
358
|
|
121
|
|
|
|
|
|
|
} @non_rel_columns; |
122
|
|
|
|
|
|
|
# transform columns specified by their accessor name |
123
|
80
|
|
|
|
|
250
|
my %columns_by_accessor = _get_columns_by_accessor($self); |
124
|
80
|
|
|
|
|
357
|
for my $accessor_name (sort keys %columns_by_accessor) { |
125
|
367
|
|
|
|
|
546
|
my $colname = $columns_by_accessor{$accessor_name}->{name}; |
126
|
367
|
100
|
100
|
|
|
828
|
if ($accessor_name ne $colname |
127
|
|
|
|
|
|
|
&& exists $non_rel_updates{$accessor_name}) { |
128
|
12
|
|
|
|
|
16
|
DEBUG and warn "renaming column accessor " . |
129
|
|
|
|
|
|
|
"'$accessor_name' to column name '$colname'\n"; |
130
|
|
|
|
|
|
|
$non_rel_updates{$colname} = delete |
131
|
12
|
|
|
|
|
34
|
$non_rel_updates{$accessor_name}; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
} |
134
|
80
|
|
|
|
|
139
|
DEBUG and warn "using all non-rel updates for object " . |
135
|
|
|
|
|
|
|
"construction: " . Dumper(\%non_rel_updates); |
136
|
|
|
|
|
|
|
# the object creation might fail because of non-column and |
137
|
|
|
|
|
|
|
# non-constructor handled parameters which shouldn't break RU |
138
|
|
|
|
|
|
|
try { |
139
|
80
|
|
|
80
|
|
4663
|
my $row = $self->new_result(\%non_rel_updates); |
140
|
77
|
|
|
|
|
8542
|
for my $colname (@pks) { |
141
|
|
|
|
|
|
|
next |
142
|
83
|
100
|
|
|
|
274
|
if exists $pk_kvs{$colname}; |
143
|
|
|
|
|
|
|
|
144
|
79
|
100
|
66
|
|
|
2193
|
if ($row->can($colname) |
145
|
|
|
|
|
|
|
&& defined $row->$colname) { |
146
|
6
|
|
|
|
|
89
|
DEBUG and warn "missing pk column $colname exists " . |
147
|
|
|
|
|
|
|
"and defined on object\n"; |
148
|
6
|
|
|
|
|
94
|
$pk_kvs{$colname} = $row->$colname; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
else { |
151
|
73
|
|
|
|
|
1969
|
DEBUG and warn "missing pk column $colname doesn't " |
152
|
|
|
|
|
|
|
. "exist or isn't defined on object, aborting\n"; |
153
|
73
|
|
|
|
|
257
|
last; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
} |
157
|
|
|
|
|
|
|
catch { |
158
|
3
|
|
|
3
|
|
4499
|
DEBUG and warn "object construction failed, ignoring: |
159
|
|
|
|
|
|
|
$_\n"; |
160
|
80
|
|
|
|
|
679
|
}; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# check if row can be found in resultset cache |
164
|
217
|
100
|
100
|
|
|
3392
|
if ( !defined $object && scalar keys %pk_kvs == scalar @pks ) { |
165
|
122
|
|
|
|
|
435
|
my $cached_rows = $self->get_cache; |
166
|
122
|
100
|
|
|
|
611
|
if (defined $cached_rows) { |
167
|
4
|
|
|
|
|
10
|
DEBUG and warn "find in cache\n"; |
168
|
4
|
|
|
|
|
16
|
$object = _get_matching_row(\%pk_kvs, $cached_rows) |
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
|
172
|
217
|
|
|
|
|
868
|
$updates = { %$updates, %$resolved }; |
173
|
|
|
|
|
|
|
|
174
|
217
|
|
|
|
|
645
|
my %fixed_fields = map { $_ => 1 } @$fixed_fields; |
|
2
|
|
|
|
|
8
|
|
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# add the resolved columns to the updates hashref |
177
|
217
|
|
|
|
|
553
|
my %all_pks = ( %pk_kvs, %fixed_fields ); |
178
|
|
|
|
|
|
|
|
179
|
217
|
100
|
100
|
|
|
1095
|
if ( !defined $object && scalar keys %all_pks == scalar @pks) { |
180
|
118
|
|
|
|
|
214
|
DEBUG and warn "find by pk\n"; |
181
|
118
|
|
|
|
|
766
|
$object = $self->find( \%all_pks, { key => 'primary' } ); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
217
|
100
|
|
|
|
358142
|
unless (defined $object) { |
185
|
91
|
|
|
|
|
161
|
DEBUG and warn "create new row\n"; |
186
|
91
|
|
|
|
|
346
|
$object = $self->new_result( {} ); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
# direct column accessors |
190
|
217
|
|
|
|
|
7751
|
my %columns; |
191
|
|
|
|
|
|
|
|
192
|
|
|
|
|
|
|
# relations that that should be done before the row is inserted into the |
193
|
|
|
|
|
|
|
# database like belongs_to |
194
|
|
|
|
|
|
|
my %pre_updates; |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# relations that that should be done after the row is inserted into the |
197
|
|
|
|
|
|
|
# database like has_many, might_have and has_one |
198
|
217
|
|
|
|
|
0
|
my %post_updates; |
199
|
217
|
|
|
|
|
0
|
my %other_methods; |
200
|
217
|
|
|
|
|
0
|
my %m2m_accessors; |
201
|
217
|
|
|
|
|
693
|
my %columns_by_accessor = _get_columns_by_accessor($self); |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# this section determines to what each key/value pair maps to, |
204
|
|
|
|
|
|
|
# column or relationship |
205
|
217
|
|
|
|
|
926
|
for my $name ( sort keys %$updates ) { |
206
|
|
|
|
|
|
|
DEBUG and warn "updating $name to " |
207
|
502
|
|
|
|
|
1108
|
. ($updates->{$name} // '[undef]') . "\n"; |
208
|
|
|
|
|
|
|
# columns |
209
|
502
|
100
|
100
|
|
|
1945
|
if ( exists $columns_by_accessor{$name} && |
|
|
|
100
|
|
|
|
|
210
|
|
|
|
|
|
|
!( $source->has_relationship($name) && ref( $updates->{$name} ) ) ) { |
211
|
359
|
|
|
|
|
2418
|
$columns{$name} = $updates->{$name}; |
212
|
359
|
|
|
|
|
666
|
next; |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# relationships |
216
|
143
|
100
|
|
|
|
1076
|
if ( $source->has_relationship($name) ) { |
217
|
114
|
100
|
|
|
|
652
|
if ( _master_relation_cond( $self, $name ) ) { |
218
|
64
|
|
|
|
|
170
|
$pre_updates{$name} = $updates->{$name}; |
219
|
64
|
|
|
|
|
155
|
next; |
220
|
|
|
|
|
|
|
} |
221
|
|
|
|
|
|
|
else { |
222
|
50
|
|
|
|
|
122
|
$post_updates{$name} = $updates->{$name}; |
223
|
50
|
|
|
|
|
118
|
next; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# many-to-many helper accessors |
228
|
29
|
100
|
|
|
|
276
|
if ( is_m2m( $self, $name ) ) { |
229
|
24
|
|
|
|
|
518
|
DEBUG and warn "is m2m\n"; |
230
|
|
|
|
|
|
|
# Transform m2m data into recursive has_many data |
231
|
|
|
|
|
|
|
# if IntrospectableM2M is in use. |
232
|
|
|
|
|
|
|
# |
233
|
|
|
|
|
|
|
# This removes the overhead related to deleting and |
234
|
|
|
|
|
|
|
# re-adding all relationships. |
235
|
24
|
100
|
100
|
|
|
524
|
if ( !$m2m_force_set_rel && $source->result_class->can('_m2m_metadata') ) { |
236
|
17
|
|
|
|
|
714
|
my $meta = $source->result_class->_m2m_metadata->{$name}; |
237
|
17
|
|
|
|
|
771
|
my $bridge_rel = $meta->{relation}; |
238
|
17
|
|
|
|
|
46
|
my $foreign_rel = $meta->{foreign_relation}; |
239
|
|
|
|
|
|
|
|
240
|
|
|
|
|
|
|
$post_updates{$bridge_rel} = [ |
241
|
|
|
|
|
|
|
map { |
242
|
39
|
|
|
|
|
110
|
{ $foreign_rel => $_ } |
243
|
17
|
|
|
|
|
34
|
} @{ $updates->{$name} } |
|
17
|
|
|
|
|
55
|
|
244
|
|
|
|
|
|
|
]; |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
# Fall back to set_$rel if IntrospectableM2M |
247
|
|
|
|
|
|
|
# is not available. (removing and re-adding all relationships) |
248
|
|
|
|
|
|
|
else { |
249
|
7
|
|
|
|
|
154
|
$m2m_accessors{$name} = $updates->{$name}; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
24
|
|
|
|
|
78
|
next; |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# accessors |
256
|
5
|
100
|
66
|
|
|
128
|
if ( $object->can($name) && not $source->has_relationship($name) ) { |
257
|
2
|
|
|
|
|
16
|
$other_methods{$name} = $updates->{$name}; |
258
|
2
|
|
|
|
|
6
|
next; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# unknown |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
# don't throw a warning instead of an exception to give users |
264
|
|
|
|
|
|
|
# time to adapt to the new API |
265
|
|
|
|
|
|
|
carp( |
266
|
3
|
100
|
|
|
|
24
|
"No such column, relationship, many-to-many helper accessor or " . |
267
|
|
|
|
|
|
|
"generic accessor '$name' on '" . $source->name . "'" |
268
|
|
|
|
|
|
|
) unless $unknown_params_ok; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
# first update columns and other accessors |
273
|
|
|
|
|
|
|
# so that later related records can be found |
274
|
217
|
|
|
|
|
718
|
for my $name ( sort keys %columns ) { |
275
|
347
|
|
|
|
|
22943
|
$object->$name( $columns{$name} ); |
276
|
|
|
|
|
|
|
} |
277
|
211
|
|
|
|
|
20202
|
for my $name ( sort keys %other_methods ) { |
278
|
2
|
|
|
|
|
11
|
$object->$name( $other_methods{$name} ); |
279
|
|
|
|
|
|
|
} |
280
|
211
|
|
|
|
|
833
|
for my $name ( sort keys %pre_updates ) { |
281
|
62
|
|
|
|
|
1520
|
_update_relation( $self, $name, $pre_updates{$name}, $object, $if_not_submitted, 0 ); |
282
|
|
|
|
|
|
|
} |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
# $self->_delete_empty_auto_increment($object); |
285
|
|
|
|
|
|
|
# don't allow insert to recurse to related objects |
286
|
|
|
|
|
|
|
# do the recursion ourselves |
287
|
|
|
|
|
|
|
# $object->{_rel_in_storage} = 1; |
288
|
|
|
|
|
|
|
# Update if %other_methods because of possible custom update method |
289
|
207
|
|
|
|
|
20338
|
my $in_storage = $object->in_storage; |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
# preserve related resultsets as DBIx::Class::Row->update clears them |
292
|
|
|
|
|
|
|
# yes, this directly accesses a row attribute, but no API exists and in |
293
|
|
|
|
|
|
|
# the hope to get the recursive_update feature into core DBIx::Class this |
294
|
|
|
|
|
|
|
# is the easiest solution |
295
|
207
|
|
|
|
|
521
|
my $related_resultsets = $object->{related_resultsets}; |
296
|
|
|
|
|
|
|
|
297
|
207
|
100
|
66
|
|
|
1493
|
$object->update_or_insert if ( $object->is_changed || keys %other_methods ); |
298
|
|
|
|
|
|
|
|
299
|
|
|
|
|
|
|
# restore related resultsets |
300
|
206
|
|
|
|
|
1314535
|
$object->{related_resultsets} = $related_resultsets; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
# this is needed to populate all columns in the row object because |
303
|
|
|
|
|
|
|
# otherwise _resolve_condition in _update_relation fails if a foreign key |
304
|
|
|
|
|
|
|
# column isn't loaded |
305
|
206
|
100
|
|
|
|
736
|
if (not $in_storage) { |
306
|
103
|
|
|
|
|
179
|
DEBUG and warn "discard_changes for created row\n"; |
307
|
103
|
|
|
|
|
1062
|
$object->discard_changes; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# updating many_to_many |
311
|
206
|
|
|
|
|
466040
|
for my $name ( sort keys %m2m_accessors ) { |
312
|
7
|
|
|
|
|
12
|
DEBUG and warn "updating m2m $name\n"; |
313
|
7
|
|
|
|
|
22
|
my $value = $m2m_accessors{$name}; |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
# TODO: only first pk col is used |
316
|
7
|
|
|
|
|
30
|
my ($pk) = _get_pk_for_related( $self, $name ); |
317
|
7
|
|
|
|
|
53
|
my @rows; |
318
|
7
|
|
|
|
|
37
|
my $rel_source = $object->$name->result_source; |
319
|
7
|
|
|
|
|
21884
|
my @updates; |
320
|
7
|
50
|
33
|
|
|
144
|
if ( defined $value && ref $value eq 'ARRAY' ) { |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
321
|
7
|
|
|
|
|
13
|
@updates = @{$value}; |
|
7
|
|
|
|
|
22
|
|
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
elsif ( defined $value && !ref $value ) { |
324
|
0
|
|
|
|
|
0
|
@updates = ($value); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
elsif ( defined $value ) { |
327
|
0
|
|
|
|
|
0
|
carp "value of many-to-many rel '$name' must be an arrayref or scalar: $value"; |
328
|
|
|
|
|
|
|
} |
329
|
7
|
|
|
|
|
21
|
for my $elem (@updates) { |
330
|
16
|
50
|
33
|
|
|
21664
|
if ( blessed($elem) && $elem->isa('DBIx::Class::Row') ) { |
|
|
100
|
|
|
|
|
|
331
|
0
|
|
|
|
|
0
|
push @rows, $elem; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
elsif ( ref $elem eq 'HASH' ) { |
334
|
5
|
|
|
|
|
19
|
push @rows, |
335
|
|
|
|
|
|
|
recursive_update( |
336
|
|
|
|
|
|
|
resultset => $rel_source->resultset, |
337
|
|
|
|
|
|
|
updates => $elem |
338
|
|
|
|
|
|
|
); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
else { |
341
|
11
|
|
|
|
|
38
|
push @rows, $rel_source->resultset->find( { $pk => $elem } ); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
} |
344
|
7
|
|
|
|
|
17332
|
my $set_meth = 'set_' . $name; |
345
|
7
|
|
|
|
|
44
|
$object->$set_meth( \@rows ); |
346
|
|
|
|
|
|
|
} |
347
|
206
|
|
|
|
|
366694
|
for my $name ( sort keys %post_updates ) { |
348
|
58
|
|
|
|
|
16526
|
_update_relation( $self, $name, $post_updates{$name}, $object, $if_not_submitted, $in_storage ); |
349
|
|
|
|
|
|
|
} |
350
|
201
|
|
|
|
|
215921
|
delete $ENV{DBIC_NULLABLE_KEY_NOWARN}; |
351
|
201
|
|
|
|
|
2222
|
return $object; |
352
|
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# returns DBIx::Class::ResultSource::column_info as a hash indexed by column accessor || name |
355
|
|
|
|
|
|
|
sub _get_columns_by_accessor { |
356
|
321
|
|
|
321
|
|
553
|
my $self = shift; |
357
|
321
|
|
|
|
|
711
|
my $source = $self->result_source; |
358
|
321
|
|
|
|
|
485
|
my %columns; |
359
|
321
|
|
|
|
|
1228
|
for my $name ( $source->columns ) { |
360
|
1354
|
|
|
|
|
4823
|
my $info = $source->column_info($name); |
361
|
1354
|
|
|
|
|
10826
|
$info->{name} = $name; |
362
|
1354
|
|
66
|
|
|
4515
|
$columns{ $info->{accessor} || $name } = $info; |
363
|
|
|
|
|
|
|
} |
364
|
321
|
|
|
|
|
1587
|
return %columns; |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
sub _get_matching_row { |
368
|
67
|
|
|
67
|
|
219
|
my ($kvs, $rows) = @_; |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
return |
371
|
67
|
50
|
|
|
|
185
|
unless defined $rows; |
372
|
|
|
|
|
|
|
|
373
|
67
|
50
|
|
|
|
207
|
croak 'key/value need to be a hashref' |
374
|
|
|
|
|
|
|
unless ref $kvs eq 'HASH'; |
375
|
|
|
|
|
|
|
|
376
|
67
|
50
|
|
|
|
201
|
croak 'key/value needs to have at least one pair' |
377
|
|
|
|
|
|
|
if keys %$kvs == 0; |
378
|
|
|
|
|
|
|
|
379
|
67
|
50
|
|
|
|
247
|
croak 'rows need to be an arrayref' |
380
|
|
|
|
|
|
|
unless ref $rows eq 'ARRAY'; |
381
|
|
|
|
|
|
|
|
382
|
67
|
50
|
|
|
|
180
|
unless ($rows) { |
383
|
0
|
|
|
|
|
0
|
DEBUG and warn "skipping because no rows passed\n"; |
384
|
0
|
|
|
|
|
0
|
return; |
385
|
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
|
|
387
|
67
|
|
|
|
|
125
|
my $matching_row; |
388
|
|
|
|
|
|
|
|
389
|
|
|
|
|
|
|
my @matching_rows; |
390
|
67
|
|
|
|
|
210
|
for my $row (@$rows) { |
391
|
|
|
|
|
|
|
push @matching_rows, $row |
392
|
165
|
|
|
165
|
|
700
|
if all { $kvs->{$_} eq $row->get_column($_) } |
393
|
134
|
100
|
|
|
|
1676
|
grep { !ref $kvs->{$_} } |
|
237
|
|
|
|
|
653
|
|
394
|
|
|
|
|
|
|
sort keys %$kvs; |
395
|
|
|
|
|
|
|
} |
396
|
67
|
100
|
|
|
|
603
|
DEBUG and warn "multiple matching rows: " . scalar @matching_rows . "\n" |
397
|
|
|
|
|
|
|
if @matching_rows > 1; |
398
|
67
|
100
|
|
|
|
280
|
$matching_row = $matching_rows[0] |
399
|
|
|
|
|
|
|
if scalar @matching_rows == 1; |
400
|
|
|
|
|
|
|
DEBUG and warn "matching row found for: " . Dumper($kvs) . " in " . |
401
|
67
|
100
|
|
|
|
172
|
Dumper([map { { $_->get_columns } } @$rows]) . "\n" |
402
|
|
|
|
|
|
|
if defined $matching_row; |
403
|
|
|
|
|
|
|
DEBUG and warn "matching row not found for: " . Dumper($kvs) . " in " . |
404
|
67
|
100
|
|
|
|
157
|
Dumper([map { { $_->get_columns } } @$rows]) . "\n" |
405
|
|
|
|
|
|
|
unless defined $matching_row; |
406
|
|
|
|
|
|
|
|
407
|
67
|
|
|
|
|
159
|
return $matching_row; |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
# Arguments: $rs, $name, $updates, $row, $if_not_submitted, $row_existed |
411
|
|
|
|
|
|
|
sub _update_relation { |
412
|
120
|
|
|
120
|
|
407
|
my ( $self, $name, $updates, $object, $if_not_submitted, $row_existed ) = @_; |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# this should never happen because we're checking the paramters passed to |
415
|
|
|
|
|
|
|
# recursive_update, but just to be sure... |
416
|
120
|
50
|
|
|
|
3102
|
$object->throw_exception("No such relationship '$name'") |
417
|
|
|
|
|
|
|
unless $object->has_relationship($name); |
418
|
|
|
|
|
|
|
|
419
|
120
|
|
|
|
|
24112
|
DEBUG and warn "_update_relation: $name\n"; |
420
|
|
|
|
|
|
|
|
421
|
120
|
|
|
|
|
492
|
my $info = $object->result_source->relationship_info($name); |
422
|
120
|
|
|
|
|
1358
|
my $attrs = $info->{attrs}; |
423
|
|
|
|
|
|
|
|
424
|
|
|
|
|
|
|
# get a related resultset without a condition |
425
|
120
|
|
|
|
|
592
|
my $related_resultset = $self->related_resultset($name)->result_source->resultset; |
426
|
120
|
|
|
|
|
149707
|
my $resolved; |
427
|
120
|
50
|
|
|
|
682
|
if ( $self->result_source->can('_resolve_condition') ) { |
428
|
120
|
|
|
|
|
507
|
$resolved = $self->result_source->_resolve_condition( $info->{cond}, $name, $object, $name ); |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
else { |
431
|
0
|
|
|
|
|
0
|
$self->throw_exception("result_source must support _resolve_condition"); |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
120
|
100
|
66
|
|
|
33459
|
$resolved = {} |
435
|
|
|
|
|
|
|
if defined $DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION && |
436
|
|
|
|
|
|
|
$DBIx::Class::ResultSource::UNRESOLVABLE_CONDITION == $resolved; |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
# This is a hack. I'm not sure that this will handle most |
439
|
|
|
|
|
|
|
# custom code conditions yet. This needs tests. |
440
|
120
|
|
|
|
|
307
|
my @rel_cols; |
441
|
120
|
50
|
|
|
|
427
|
if ( ref $info->{cond} eq 'CODE' ) { |
442
|
0
|
|
|
|
|
0
|
my $new_resolved; |
443
|
|
|
|
|
|
|
# remove 'me.' from keys in returned hashref |
444
|
0
|
|
|
|
|
0
|
while ( my ( $key, $value ) = each %$resolved ) { |
445
|
0
|
|
|
|
|
0
|
$key =~ s/^me\.//; |
446
|
0
|
|
|
|
|
0
|
$new_resolved->{$key} = $value; |
447
|
0
|
|
|
|
|
0
|
push @rel_cols, $key; |
448
|
|
|
|
|
|
|
} |
449
|
0
|
|
|
|
|
0
|
$resolved = $new_resolved; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
else { |
452
|
120
|
|
|
|
|
233
|
@rel_cols = sort keys %{ $info->{cond} }; |
|
120
|
|
|
|
|
452
|
|
453
|
120
|
|
|
|
|
277
|
map { s/^foreign\.// } @rel_cols; |
|
120
|
|
|
|
|
569
|
|
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
# find out if all related columns are nullable |
457
|
120
|
|
|
|
|
441
|
my $all_fks_nullable = 1; |
458
|
120
|
|
|
|
|
304
|
for my $rel_col (@rel_cols) { |
459
|
|
|
|
|
|
|
$all_fks_nullable = 0 |
460
|
120
|
100
|
|
|
|
512
|
unless $related_resultset->result_source->column_info($rel_col)->{is_nullable}; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
120
|
100
|
|
|
|
2195
|
$if_not_submitted = $all_fks_nullable ? 'set_to_null' : 'delete' |
|
|
100
|
|
|
|
|
|
464
|
|
|
|
|
|
|
unless defined $if_not_submitted; |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# the only valid datatype for a has_many rels is an arrayref |
467
|
120
|
100
|
66
|
|
|
758
|
if ( $attrs->{accessor} eq 'multi' ) { |
|
|
50
|
|
|
|
|
|
468
|
50
|
|
|
|
|
91
|
DEBUG and warn "has_many: $name\n"; |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# handle undef like empty arrayref |
471
|
50
|
100
|
|
|
|
163
|
$updates = [] |
472
|
|
|
|
|
|
|
unless defined $updates; |
473
|
50
|
50
|
|
|
|
182
|
$self->throw_exception("data for has_many relationship '$name' must be an arrayref") |
474
|
|
|
|
|
|
|
unless ref $updates eq 'ARRAY'; |
475
|
|
|
|
|
|
|
|
476
|
50
|
|
|
|
|
127
|
my @updated_objs; |
477
|
|
|
|
|
|
|
my @related_rows; |
478
|
|
|
|
|
|
|
# newly created rows can't have related rows |
479
|
50
|
100
|
|
|
|
238
|
if ($row_existed) { |
480
|
28
|
|
|
|
|
585
|
@related_rows = $object->$name; |
481
|
28
|
|
|
|
|
93817
|
DEBUG and warn "got related rows: " . scalar @related_rows . "\n"; |
482
|
|
|
|
|
|
|
} |
483
|
50
|
|
|
|
|
180
|
my $related_result_source = $related_resultset->result_source; |
484
|
50
|
|
|
|
|
171
|
my @pks = $related_result_source->primary_columns; |
485
|
|
|
|
|
|
|
|
486
|
50
|
|
|
|
|
441
|
for my $sub_updates ( @{$updates} ) { |
|
50
|
|
|
|
|
147
|
|
487
|
86
|
|
|
|
|
156
|
DEBUG and warn "updating related row\n"; |
488
|
86
|
|
|
|
|
172
|
my %pk_kvs; |
489
|
|
|
|
|
|
|
# detect the special case where the primary key of a currently not |
490
|
|
|
|
|
|
|
# related row is passed in the updates hash |
491
|
86
|
|
|
|
|
210
|
for my $colname (@pks) { |
492
|
144
|
100
|
66
|
|
|
616
|
if (exists $sub_updates->{$colname} && defined $sub_updates->{$colname}) { |
493
|
67
|
|
|
|
|
152
|
$pk_kvs{$colname} = $sub_updates->{$colname}; |
494
|
67
|
|
|
|
|
136
|
next; |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
$pk_kvs{$colname} = $resolved->{$colname} |
497
|
|
|
|
|
|
|
if exists $resolved->{$colname} |
498
|
77
|
100
|
100
|
|
|
456
|
&& defined $resolved->{$colname}; |
499
|
|
|
|
|
|
|
} |
500
|
86
|
|
|
|
|
186
|
my $related_object; |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# support the special case where a method on the related row |
503
|
|
|
|
|
|
|
# populates one or more primary key columns and we don't have |
504
|
|
|
|
|
|
|
# all primary key values already |
505
|
|
|
|
|
|
|
# see DBSchema::Result::DVD relationship keysbymethod |
506
|
86
|
|
|
|
|
144
|
DEBUG and warn "pk columns so far: " . join (', ', |
507
|
|
|
|
|
|
|
sort keys %pk_kvs) . "\n"; |
508
|
|
|
|
|
|
|
my @non_pk_columns = grep { |
509
|
86
|
|
|
|
|
389
|
my $colname = $_; |
|
114
|
|
|
|
|
244
|
|
510
|
114
|
|
|
103
|
|
794
|
none { $colname eq $_ } keys %pk_kvs |
|
103
|
|
|
|
|
461
|
|
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
sort keys %$sub_updates; |
513
|
86
|
|
|
|
|
184
|
DEBUG and warn "non-pk columns: " . join (', ', |
514
|
|
|
|
|
|
|
@non_pk_columns) . "\n"; |
515
|
86
|
100
|
66
|
|
|
408
|
if ( scalar keys %pk_kvs != scalar @pks && @non_pk_columns) { |
516
|
24
|
|
|
|
|
41
|
DEBUG and warn "not all primary keys available, trying " . |
517
|
|
|
|
|
|
|
"object creation\n"; |
518
|
|
|
|
|
|
|
# new_result throws exception if non column values are passed |
519
|
|
|
|
|
|
|
# because we want to also support e.g. a BUILDARGS method that |
520
|
|
|
|
|
|
|
# populates primary key columns from an additional value |
521
|
|
|
|
|
|
|
# filter out all relationships |
522
|
|
|
|
|
|
|
my @non_rel_columns = grep { |
523
|
24
|
|
100
|
|
|
70
|
!is_m2m( $related_resultset, $_ ) |
|
45
|
|
|
|
|
494
|
|
524
|
|
|
|
|
|
|
&& !$related_result_source->has_relationship($_) |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
sort keys %$sub_updates; |
527
|
|
|
|
|
|
|
my %non_rel_updates = map { |
528
|
24
|
|
|
|
|
494
|
$_ => $sub_updates->{$_} |
|
36
|
|
|
|
|
125
|
|
529
|
|
|
|
|
|
|
} @non_rel_columns; |
530
|
|
|
|
|
|
|
# transform columns specified by their accessor name |
531
|
24
|
|
|
|
|
83
|
my %columns_by_accessor = _get_columns_by_accessor($related_resultset); |
532
|
24
|
|
|
|
|
115
|
for my $accessor_name (sort keys %columns_by_accessor) { |
533
|
116
|
|
|
|
|
195
|
my $colname = $columns_by_accessor{$accessor_name}->{name}; |
534
|
116
|
100
|
100
|
|
|
266
|
if ($accessor_name ne $colname |
535
|
|
|
|
|
|
|
&& exists $non_rel_updates{$accessor_name}) { |
536
|
10
|
|
|
|
|
15
|
DEBUG and warn "renaming column accessor " . |
537
|
|
|
|
|
|
|
"'$accessor_name' to column name '$colname'\n"; |
538
|
|
|
|
|
|
|
$non_rel_updates{$colname} = delete |
539
|
10
|
|
|
|
|
27
|
$non_rel_updates{$accessor_name}; |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
} |
542
|
24
|
|
|
|
|
51
|
DEBUG and warn "using all non-rel updates for object " . |
543
|
|
|
|
|
|
|
"construction: " . Dumper(\%non_rel_updates); |
544
|
|
|
|
|
|
|
# the object creation might fail because of non-column and |
545
|
|
|
|
|
|
|
# non-constructor handled parameters which shouldn't break RU |
546
|
|
|
|
|
|
|
try { |
547
|
24
|
|
|
24
|
|
1380
|
my $related_row = $related_resultset |
548
|
|
|
|
|
|
|
->new_result(\%non_rel_updates); |
549
|
24
|
|
|
|
|
2362
|
for my $colname (@pks) { |
550
|
|
|
|
|
|
|
next |
551
|
28
|
100
|
|
|
|
90
|
if exists $pk_kvs{$colname}; |
552
|
|
|
|
|
|
|
|
553
|
25
|
100
|
66
|
|
|
923
|
if ($related_row->can($colname) |
554
|
|
|
|
|
|
|
&& defined $related_row->$colname) { |
555
|
2
|
|
|
|
|
50
|
DEBUG and warn "missing pk column $colname exists " . |
556
|
|
|
|
|
|
|
"and defined on object\n"; |
557
|
2
|
|
|
|
|
36
|
$pk_kvs{$colname} = $related_row->$colname; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
else { |
560
|
23
|
|
|
|
|
620
|
DEBUG and warn "missing pk column $colname doesn't " |
561
|
|
|
|
|
|
|
. "exist or isn't defined on object, aborting\n"; |
562
|
23
|
|
|
|
|
77
|
last; |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
} |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
catch { |
567
|
0
|
|
|
0
|
|
0
|
DEBUG and warn "object construction failed, ignoring: |
568
|
|
|
|
|
|
|
$_\n"; |
569
|
24
|
|
|
|
|
196
|
}; |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
86
|
100
|
|
|
|
1082
|
if ( scalar keys %pk_kvs == scalar @pks ) { |
573
|
63
|
|
|
|
|
105
|
DEBUG and warn "all primary keys available\n"; |
574
|
|
|
|
|
|
|
# the lookup can fail if the primary key of a currently not |
575
|
|
|
|
|
|
|
# related row is passed in the updates hash |
576
|
63
|
|
|
|
|
235
|
$related_object = _get_matching_row(\%pk_kvs, \@related_rows); |
577
|
|
|
|
|
|
|
} |
578
|
|
|
|
|
|
|
# pass an empty object if no related row found and it's not the |
579
|
|
|
|
|
|
|
# special case where the primary key of a currently not related |
580
|
|
|
|
|
|
|
# row is passed in the updates hash to prevent the find by pk in |
581
|
|
|
|
|
|
|
# recursive_update to happen |
582
|
|
|
|
|
|
|
else { |
583
|
23
|
|
|
|
|
37
|
DEBUG and warn "passing empty row to prevent find by pk\n"; |
584
|
23
|
|
|
|
|
76
|
$related_object = $related_resultset->new_result({}); |
585
|
|
|
|
|
|
|
} |
586
|
|
|
|
|
|
|
|
587
|
86
|
|
|
|
|
1636
|
my $sub_object = recursive_update( |
588
|
|
|
|
|
|
|
resultset => $related_resultset, |
589
|
|
|
|
|
|
|
updates => $sub_updates, |
590
|
|
|
|
|
|
|
resolved => $resolved, |
591
|
|
|
|
|
|
|
# pass prefetched object if found |
592
|
|
|
|
|
|
|
object => $related_object, |
593
|
|
|
|
|
|
|
); |
594
|
|
|
|
|
|
|
|
595
|
81
|
|
|
|
|
351
|
push @updated_objs, $sub_object; |
596
|
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
# determine if a removal query is required |
599
|
|
|
|
|
|
|
my @remove_rows = grep { |
600
|
45
|
|
|
|
|
132
|
my $existing_row = $_; |
|
69
|
|
|
|
|
6649
|
|
601
|
94
|
|
|
94
|
|
7630
|
none { $existing_row->ID eq $_->ID } @updated_objs |
602
|
69
|
|
|
|
|
409
|
} @related_rows; |
603
|
45
|
|
|
|
|
3257
|
DEBUG and warn "rows for removal: " . join(', ', map { $_->ID } |
604
|
|
|
|
|
|
|
@remove_rows) . "\n"; |
605
|
|
|
|
|
|
|
|
606
|
45
|
100
|
|
|
|
298
|
if (scalar @remove_rows) { |
607
|
17
|
|
|
|
|
384
|
my $rs_rel_delist = $object->$name; |
608
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
# foreign table has a single pk column |
610
|
17
|
100
|
|
|
|
3899
|
if (scalar @pks == 1) { |
611
|
6
|
|
|
|
|
13
|
DEBUG and warn "delete in not_in\n"; |
612
|
6
|
|
|
|
|
29
|
$rs_rel_delist = $rs_rel_delist->search_rs( |
613
|
|
|
|
|
|
|
{ |
614
|
|
|
|
|
|
|
$self->current_source_alias . "." . |
615
|
|
|
|
|
|
|
$pks[0] => { -not_in => [ map ( $_->id, @updated_objs ) ] } |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
); |
618
|
|
|
|
|
|
|
} |
619
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
# foreign table has multiple pk columns |
621
|
|
|
|
|
|
|
else { |
622
|
11
|
|
|
|
|
26
|
my @cond; |
623
|
11
|
|
|
|
|
33
|
for my $obj (@updated_objs) { |
624
|
14
|
|
|
|
|
67
|
my %cond_for_obj; |
625
|
14
|
|
|
|
|
30
|
for my $col (@pks) { |
626
|
28
|
|
|
|
|
204
|
$cond_for_obj{ $self->current_source_alias . ".$col" } = |
627
|
|
|
|
|
|
|
$obj->get_column($col); |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
} |
630
|
14
|
|
|
|
|
128
|
push @cond, \%cond_for_obj; |
631
|
|
|
|
|
|
|
} |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# only limit resultset if there are related rows left |
634
|
11
|
100
|
|
|
|
49
|
if (scalar @cond) { |
635
|
8
|
|
|
|
|
38
|
$rs_rel_delist = $rs_rel_delist->search_rs({ -not => [ @cond ] }); |
636
|
|
|
|
|
|
|
} |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
17
|
100
|
|
|
|
6455
|
if ($if_not_submitted eq 'delete') { |
|
|
50
|
|
|
|
|
|
640
|
15
|
|
|
|
|
84
|
$rs_rel_delist->delete; |
641
|
|
|
|
|
|
|
} |
642
|
|
|
|
|
|
|
elsif ($if_not_submitted eq 'set_to_null') { |
643
|
2
|
|
|
|
|
5
|
my %update = map {$_ => undef} @rel_cols; |
|
2
|
|
|
|
|
9
|
|
644
|
2
|
|
|
|
|
10
|
$rs_rel_delist->update(\%update); |
645
|
|
|
|
|
|
|
} |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
} |
648
|
|
|
|
|
|
|
elsif ( $attrs->{accessor} eq 'single' || |
649
|
|
|
|
|
|
|
$attrs->{accessor} eq 'filter' ) { |
650
|
|
|
|
|
|
|
DEBUG and warn "has_one, might_have, belongs_to (" . |
651
|
70
|
|
|
|
|
111
|
$attrs->{accessor} . "): $name\n"; |
652
|
|
|
|
|
|
|
|
653
|
70
|
|
|
|
|
119
|
my $sub_object; |
654
|
70
|
100
|
|
|
|
194
|
if ( ref $updates ) { |
655
|
69
|
|
|
|
|
135
|
my $existing_row = 0; |
656
|
69
|
|
|
|
|
261
|
my @pks = $related_resultset->result_source->primary_columns; |
657
|
69
|
100
|
|
69
|
|
760
|
if ( all { exists $updates->{$_} && defined $updates->{$_} } @pks ) { |
|
69
|
100
|
|
|
|
340
|
|
658
|
24
|
|
|
|
|
49
|
$existing_row = 1; |
659
|
|
|
|
|
|
|
} |
660
|
69
|
|
|
|
|
326
|
DEBUG and warn $existing_row ? "existing row\n" : "new row\n"; |
661
|
69
|
100
|
66
|
|
|
870
|
if ( blessed($updates) && $updates->isa('DBIx::Class::Row') ) { |
|
|
100
|
100
|
|
|
|
|
662
|
10
|
|
|
|
|
27
|
$sub_object = $updates; |
663
|
|
|
|
|
|
|
} |
664
|
|
|
|
|
|
|
elsif ( $attrs->{accessor} eq 'single' && |
665
|
|
|
|
|
|
|
defined $object->$name ) |
666
|
|
|
|
|
|
|
{ |
667
|
3
|
100
|
|
|
|
10852
|
$sub_object = recursive_update( |
668
|
|
|
|
|
|
|
resultset => $related_resultset, |
669
|
|
|
|
|
|
|
updates => $updates, |
670
|
|
|
|
|
|
|
$existing_row ? () : (object => $object->$name), |
671
|
|
|
|
|
|
|
); |
672
|
|
|
|
|
|
|
} |
673
|
|
|
|
|
|
|
else { |
674
|
56
|
100
|
|
|
|
67718
|
$sub_object = recursive_update( |
675
|
|
|
|
|
|
|
resultset => $related_resultset, |
676
|
|
|
|
|
|
|
updates => $updates, |
677
|
|
|
|
|
|
|
$existing_row ? () : (resolved => $resolved), |
678
|
|
|
|
|
|
|
); |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
} |
681
|
|
|
|
|
|
|
else { |
682
|
|
|
|
|
|
|
$sub_object = $related_resultset->find($updates) |
683
|
|
|
|
|
|
|
unless ( |
684
|
|
|
|
|
|
|
!$updates && |
685
|
|
|
|
|
|
|
( exists $attrs->{join_type} && |
686
|
1
|
50
|
33
|
|
|
8
|
$attrs->{join_type} eq 'LEFT' ) |
|
|
|
33
|
|
|
|
|
687
|
|
|
|
|
|
|
); |
688
|
|
|
|
|
|
|
} |
689
|
66
|
|
100
|
|
|
397
|
my $join_type = $attrs->{join_type} || ''; |
690
|
|
|
|
|
|
|
# unmarked 'LEFT' join for belongs_to |
691
|
|
|
|
|
|
|
my $might_belong_to = |
692
|
|
|
|
|
|
|
( $attrs->{accessor} eq 'single' || $attrs->{accessor} eq 'filter' ) && |
693
|
66
|
|
66
|
|
|
1029
|
$attrs->{is_foreign_key_constraint}; |
694
|
|
|
|
|
|
|
# adding check for custom condition that's a coderef |
695
|
|
|
|
|
|
|
# this 'set_from_related' should probably not be called in lots of other |
696
|
|
|
|
|
|
|
# situations too, but until that's worked out, kludge it |
697
|
66
|
50
|
33
|
|
|
833
|
if ( ( $sub_object || $updates || $might_belong_to || $join_type eq 'LEFT' ) && |
|
|
|
33
|
|
|
|
|
698
|
|
|
|
|
|
|
ref $info->{cond} ne 'CODE' ) { |
699
|
66
|
|
|
|
|
4460
|
$object->$name($sub_object); |
700
|
|
|
|
|
|
|
} |
701
|
|
|
|
|
|
|
} |
702
|
|
|
|
|
|
|
else { |
703
|
|
|
|
|
|
|
$self->throw_exception( |
704
|
|
|
|
|
|
|
"recursive_update doesn't now how to handle relationship '$name' with accessor " . |
705
|
0
|
|
|
|
|
0
|
$info->{attrs}{accessor} ); |
706
|
|
|
|
|
|
|
} |
707
|
|
|
|
|
|
|
} |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
sub is_m2m { |
710
|
342
|
|
|
342
|
|
883
|
my ( $self, $relation ) = @_; |
711
|
342
|
|
|
|
|
930
|
my $rclass = $self->result_class; |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
# DBIx::Class::IntrospectableM2M |
714
|
342
|
100
|
|
|
|
4306
|
if ( $rclass->can('_m2m_metadata') ) { |
715
|
57
|
|
|
|
|
1184
|
return $rclass->_m2m_metadata->{$relation}; |
716
|
|
|
|
|
|
|
} |
717
|
285
|
|
|
|
|
900
|
my $object = $self->new_result( {} ); |
718
|
285
|
100
|
100
|
|
|
20178
|
if ( $object->can($relation) and |
|
|
|
100
|
|
|
|
|
719
|
|
|
|
|
|
|
!$self->result_source->has_relationship($relation) and |
720
|
|
|
|
|
|
|
$object->can( 'set_' . $relation ) ) { |
721
|
10
|
|
|
|
|
130
|
return 1; |
722
|
|
|
|
|
|
|
} |
723
|
275
|
|
|
|
|
3339
|
return; |
724
|
|
|
|
|
|
|
} |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
sub get_m2m_source { |
727
|
7
|
|
|
7
|
|
20
|
my ( $self, $relation ) = @_; |
728
|
7
|
|
|
|
|
19
|
my $rclass = $self->result_class; |
729
|
|
|
|
|
|
|
|
730
|
|
|
|
|
|
|
# DBIx::Class::IntrospectableM2M |
731
|
7
|
100
|
|
|
|
62
|
if ( $rclass->can('_m2m_metadata') ) { |
732
|
|
|
|
|
|
|
return $self->result_source->related_source( |
733
|
|
|
|
|
|
|
$rclass->_m2m_metadata->{$relation}{relation} ) |
734
|
2
|
|
|
|
|
35
|
->related_source( $rclass->_m2m_metadata->{$relation}{foreign_relation} ); |
735
|
|
|
|
|
|
|
} |
736
|
5
|
|
|
|
|
17
|
my $object = $self->new_result( {} ); |
737
|
5
|
|
|
|
|
456
|
my $r = $object->$relation; |
738
|
5
|
|
|
|
|
19641
|
return $r->result_source; |
739
|
|
|
|
|
|
|
} |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
sub _delete_empty_auto_increment { |
742
|
0
|
|
|
0
|
|
0
|
my ( $self, $object ) = @_; |
743
|
0
|
|
|
|
|
0
|
for my $col ( sort keys %{ $object->{_column_data} } ) { |
|
0
|
|
|
|
|
0
|
|
744
|
0
|
0
|
0
|
|
|
0
|
if ( |
|
|
|
0
|
|
|
|
|
745
|
|
|
|
|
|
|
$object->result_source->column_info($col)->{is_auto_increment} and |
746
|
|
|
|
|
|
|
( !defined $object->{_column_data}{$col} or |
747
|
|
|
|
|
|
|
$object->{_column_data}{$col} eq '' ) |
748
|
|
|
|
|
|
|
) { |
749
|
0
|
|
|
|
|
0
|
delete $object->{_column_data}{$col}; |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
} |
752
|
|
|
|
|
|
|
} |
753
|
|
|
|
|
|
|
|
754
|
|
|
|
|
|
|
sub _get_pk_for_related { |
755
|
81
|
|
|
81
|
|
200
|
my ( $self, $relation ) = @_; |
756
|
81
|
|
|
|
|
140
|
my $source; |
757
|
81
|
100
|
|
|
|
242
|
if ( $self->result_source->has_relationship($relation) ) { |
758
|
74
|
|
|
|
|
421
|
$source = $self->result_source->related_source($relation); |
759
|
|
|
|
|
|
|
} |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
# many to many case |
762
|
81
|
100
|
|
|
|
9535
|
if ( is_m2m( $self, $relation ) ) { |
763
|
7
|
|
|
|
|
124
|
$source = get_m2m_source( $self, $relation ); |
764
|
|
|
|
|
|
|
} |
765
|
81
|
|
|
|
|
2110
|
return $source->primary_columns; |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
# This function determines whether a relationship should be done before or |
769
|
|
|
|
|
|
|
# after the row is inserted into the database |
770
|
|
|
|
|
|
|
# relationships before: belongs_to |
771
|
|
|
|
|
|
|
# relationships after: has_many, might_have and has_one |
772
|
|
|
|
|
|
|
# true means before, false after |
773
|
|
|
|
|
|
|
sub _master_relation_cond { |
774
|
114
|
|
|
114
|
|
377
|
my ( $self, $name ) = @_; |
775
|
|
|
|
|
|
|
|
776
|
114
|
|
|
|
|
255
|
my $source = $self->result_source; |
777
|
114
|
|
|
|
|
331
|
my $info = $source->relationship_info($name); |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
# has_many rels are always after |
780
|
|
|
|
|
|
|
return 0 |
781
|
114
|
100
|
|
|
|
717
|
if $info->{attrs}->{accessor} eq 'multi'; |
782
|
|
|
|
|
|
|
|
783
|
74
|
|
|
|
|
222
|
my @foreign_ids = _get_pk_for_related( $self, $name ); |
784
|
|
|
|
|
|
|
|
785
|
74
|
|
|
|
|
559
|
my $cond = $info->{cond}; |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
sub _inner { |
788
|
74
|
|
|
74
|
|
224
|
my ( $source, $cond, @foreign_ids ) = @_; |
789
|
|
|
|
|
|
|
|
790
|
74
|
|
|
|
|
160
|
while ( my ( $f_key, $col ) = each %{$cond} ) { |
|
74
|
|
|
|
|
323
|
|
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
# might_have is not master |
793
|
73
|
|
|
|
|
349
|
$col =~ s/^self\.//; |
794
|
73
|
|
|
|
|
224
|
$f_key =~ s/^foreign\.//; |
795
|
73
|
100
|
|
|
|
232
|
if ( $source->column_info($col)->{is_auto_increment} ) { |
796
|
9
|
|
|
|
|
105
|
return 0; |
797
|
|
|
|
|
|
|
} |
798
|
64
|
50
|
|
64
|
|
926
|
if ( any { $_ eq $f_key } @foreign_ids ) { |
|
64
|
|
|
|
|
242
|
|
799
|
64
|
|
|
|
|
333
|
return 1; |
800
|
|
|
|
|
|
|
} |
801
|
|
|
|
|
|
|
} |
802
|
1
|
|
|
|
|
4
|
return 0; |
803
|
|
|
|
|
|
|
} |
804
|
|
|
|
|
|
|
|
805
|
74
|
50
|
|
|
|
229
|
if ( ref $cond eq 'HASH' ) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
806
|
74
|
|
|
|
|
245
|
return _inner( $source, $cond, @foreign_ids ); |
807
|
|
|
|
|
|
|
} |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
# arrayref of hashrefs |
810
|
|
|
|
|
|
|
elsif ( ref $cond eq 'ARRAY' ) { |
811
|
0
|
|
|
|
|
0
|
for my $new_cond (@$cond) { |
812
|
0
|
|
|
|
|
0
|
return _inner( $source, $new_cond, @foreign_ids ); |
813
|
|
|
|
|
|
|
} |
814
|
|
|
|
|
|
|
} |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
# we have a custom join condition, so update afterward |
817
|
|
|
|
|
|
|
elsif ( ref $cond eq 'CODE' ) { |
818
|
0
|
|
|
|
|
0
|
return 0; |
819
|
|
|
|
|
|
|
} |
820
|
|
|
|
|
|
|
|
821
|
|
|
|
|
|
|
else { |
822
|
0
|
|
|
|
|
0
|
$source->throw_exception( "unhandled relation condition " . ref($cond) ); |
823
|
|
|
|
|
|
|
} |
824
|
0
|
|
|
|
|
0
|
return; |
825
|
|
|
|
|
|
|
} |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
1; |
828
|
|
|
|
|
|
|
|
829
|
|
|
|
|
|
|
__END__ |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
=pod |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
=encoding UTF-8 |
834
|
|
|
|
|
|
|
|
835
|
|
|
|
|
|
|
=head1 NAME |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
DBIx::Class::ResultSet::RecursiveUpdate - like update_or_create - but recursive |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
=head1 VERSION |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
version 0.40 |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
=head1 SYNOPSIS |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
# The functional interface: |
846
|
|
|
|
|
|
|
|
847
|
|
|
|
|
|
|
my $schema = MyDB::Schema->connect(); |
848
|
|
|
|
|
|
|
my $new_item = DBIx::Class::ResultSet::RecursiveUpdate::Functions::recursive_update( |
849
|
|
|
|
|
|
|
resultset => $schema->resultset('User'), |
850
|
|
|
|
|
|
|
updates => { |
851
|
|
|
|
|
|
|
id => 1, |
852
|
|
|
|
|
|
|
owned_dvds => [ |
853
|
|
|
|
|
|
|
{ |
854
|
|
|
|
|
|
|
title => "One Flew Over the Cuckoo's Nest" |
855
|
|
|
|
|
|
|
} |
856
|
|
|
|
|
|
|
] |
857
|
|
|
|
|
|
|
}, |
858
|
|
|
|
|
|
|
unknown_params_ok => 1, |
859
|
|
|
|
|
|
|
); |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
# As ResultSet subclass: |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
__PACKAGE__->load_namespaces( default_resultset_class => '+DBIx::Class::ResultSet::RecursiveUpdate' ); |
865
|
|
|
|
|
|
|
|
866
|
|
|
|
|
|
|
# in the Schema file (see t/lib/DBSchema.pm). Or appropriate 'use base' in the ResultSet classes. |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
my $user = $schema->resultset('User')->recursive_update({ |
869
|
|
|
|
|
|
|
id => 1, |
870
|
|
|
|
|
|
|
owned_dvds => [ |
871
|
|
|
|
|
|
|
{ |
872
|
|
|
|
|
|
|
title => "One Flew Over the Cuckoo's Nest" |
873
|
|
|
|
|
|
|
} |
874
|
|
|
|
|
|
|
] |
875
|
|
|
|
|
|
|
}, { |
876
|
|
|
|
|
|
|
unknown_params_ok => 1, |
877
|
|
|
|
|
|
|
}); |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
# You'll get a warning if you pass non-result specific data to |
880
|
|
|
|
|
|
|
# recursive_update. See L</"Additional data in the updates hashref"> |
881
|
|
|
|
|
|
|
# for more information how to prevent this. |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
=head1 DESCRIPTION |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
You can feed the ->create method of DBIx::Class with a recursive datastructure |
886
|
|
|
|
|
|
|
and have the related records created. Unfortunately you cannot do a similar |
887
|
|
|
|
|
|
|
thing with update_or_create. This module tries to fill that void until |
888
|
|
|
|
|
|
|
L<DBIx::Class> has an api itself. |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
The functional interface can be used without modifications of the model, |
891
|
|
|
|
|
|
|
for example by form processors like L<HTML::FormHandler::Model::DBIC>. |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
It is a base class for L<DBIx::Class::ResultSet>s providing the method |
894
|
|
|
|
|
|
|
recursive_update which works just like update_or_create but can recursively |
895
|
|
|
|
|
|
|
update or create result objects composed of multiple rows. All rows need to be |
896
|
|
|
|
|
|
|
identified by primary keys so you need to provide them in the update structure |
897
|
|
|
|
|
|
|
(unless they can be deduced from the parent row. For example a related row of |
898
|
|
|
|
|
|
|
a belongs_to relationship). If any of the primary key columns are missing, |
899
|
|
|
|
|
|
|
a new row will be created, with the expectation that the missing columns will |
900
|
|
|
|
|
|
|
be filled by it (as in the case of auto_increment primary keys). |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
If the resultset itself stores an assignment for the primary key, |
903
|
|
|
|
|
|
|
like in the case of: |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
my $restricted_rs = $user_rs->search( { id => 1 } ); |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
you need to inform recursive_update about the additional predicate with the fixed_fields attribute: |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
my $user = $restricted_rs->recursive_update( { |
910
|
|
|
|
|
|
|
owned_dvds => [ |
911
|
|
|
|
|
|
|
{ |
912
|
|
|
|
|
|
|
title => 'One Flew Over the Cuckoo's Nest' |
913
|
|
|
|
|
|
|
} |
914
|
|
|
|
|
|
|
] |
915
|
|
|
|
|
|
|
}, |
916
|
|
|
|
|
|
|
{ |
917
|
|
|
|
|
|
|
fixed_fields => [ 'id' ], |
918
|
|
|
|
|
|
|
} |
919
|
|
|
|
|
|
|
); |
920
|
|
|
|
|
|
|
|
921
|
|
|
|
|
|
|
For a many_to_many (pseudo) relation you can supply a list of primary keys |
922
|
|
|
|
|
|
|
from the other table and it will link the record at hand to those and |
923
|
|
|
|
|
|
|
only those records identified by them. This is convenient for handling web |
924
|
|
|
|
|
|
|
forms with check boxes (or a select field with multiple choice) that lets you |
925
|
|
|
|
|
|
|
update such (pseudo) relations. |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
For a description how to set up base classes for ResultSets see |
928
|
|
|
|
|
|
|
L<DBIx::Class::Schema/load_namespaces>. |
929
|
|
|
|
|
|
|
|
930
|
|
|
|
|
|
|
=head2 Additional data in the updates hashref |
931
|
|
|
|
|
|
|
|
932
|
|
|
|
|
|
|
If you pass additional data to recursive_update which doesn't match a column |
933
|
|
|
|
|
|
|
name, column accessor, relationship or many-to-many helper accessor, it will |
934
|
|
|
|
|
|
|
throw a warning by default. To disable this behaviour you can set the |
935
|
|
|
|
|
|
|
unknown_params_ok attribute to a true value. |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
The warning thrown is: |
938
|
|
|
|
|
|
|
"No such column, relationship, many-to-many helper accessor or generic accessor '$key'" |
939
|
|
|
|
|
|
|
|
940
|
|
|
|
|
|
|
When used by L<HTML::FormHandler::Model::DBIC> this can happen if you have |
941
|
|
|
|
|
|
|
additional form fields that aren't relevant to the database but don't have the |
942
|
|
|
|
|
|
|
noupdate attribute set to a true value. |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
NOTE: in a future version this behaviour will change and throw an exception |
945
|
|
|
|
|
|
|
instead of a warning! |
946
|
|
|
|
|
|
|
|
947
|
|
|
|
|
|
|
=head1 DESIGN CHOICES |
948
|
|
|
|
|
|
|
|
949
|
|
|
|
|
|
|
Columns and relationships which are excluded from the updates hashref aren't |
950
|
|
|
|
|
|
|
touched at all. |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
=head2 Treatment of belongs_to relations |
953
|
|
|
|
|
|
|
|
954
|
|
|
|
|
|
|
In case the relationship is included but undefined in the updates hashref, |
955
|
|
|
|
|
|
|
all columns forming the relationship will be set to null. |
956
|
|
|
|
|
|
|
If not all of them are nullable, DBIx::Class will throw an error. |
957
|
|
|
|
|
|
|
|
958
|
|
|
|
|
|
|
Updating the relationship: |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
961
|
|
|
|
|
|
|
id => 1, |
962
|
|
|
|
|
|
|
owner => $user->id, |
963
|
|
|
|
|
|
|
}); |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
Clearing the relationship (only works if cols are nullable!): |
966
|
|
|
|
|
|
|
|
967
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
968
|
|
|
|
|
|
|
id => 1, |
969
|
|
|
|
|
|
|
owner => undef, |
970
|
|
|
|
|
|
|
}); |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
Updating a relationship including its (full) primary key: |
973
|
|
|
|
|
|
|
|
974
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
975
|
|
|
|
|
|
|
id => 1, |
976
|
|
|
|
|
|
|
owner => { |
977
|
|
|
|
|
|
|
id => 2, |
978
|
|
|
|
|
|
|
name => "George", |
979
|
|
|
|
|
|
|
}, |
980
|
|
|
|
|
|
|
}); |
981
|
|
|
|
|
|
|
|
982
|
|
|
|
|
|
|
=head2 Treatment of might_have relationships |
983
|
|
|
|
|
|
|
|
984
|
|
|
|
|
|
|
In case the relationship is included but undefined in the updates hashref, |
985
|
|
|
|
|
|
|
all columns forming the relationship will be set to null. |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
Updating the relationship: |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
990
|
|
|
|
|
|
|
id => 1, |
991
|
|
|
|
|
|
|
address => { |
992
|
|
|
|
|
|
|
street => "101 Main Street", |
993
|
|
|
|
|
|
|
city => "Podunk", |
994
|
|
|
|
|
|
|
state => "New York", |
995
|
|
|
|
|
|
|
} |
996
|
|
|
|
|
|
|
}); |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
Clearing the relationship: |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1001
|
|
|
|
|
|
|
id => 1, |
1002
|
|
|
|
|
|
|
address => undef, |
1003
|
|
|
|
|
|
|
}); |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
=head2 Treatment of has_many relations |
1006
|
|
|
|
|
|
|
|
1007
|
|
|
|
|
|
|
If a relationship key is included in the data structure with a value of undef |
1008
|
|
|
|
|
|
|
or an empty array, all existing related rows will be deleted, or their foreign |
1009
|
|
|
|
|
|
|
key columns will be set to null. |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
The exact behaviour depends on the nullability of the foreign key columns and |
1012
|
|
|
|
|
|
|
the value of the "if_not_submitted" parameter. The parameter defaults to |
1013
|
|
|
|
|
|
|
undefined which neither nullifies nor deletes. |
1014
|
|
|
|
|
|
|
|
1015
|
|
|
|
|
|
|
When the array contains elements they are updated if they exist, created when |
1016
|
|
|
|
|
|
|
not and deleted if not included. |
1017
|
|
|
|
|
|
|
|
1018
|
|
|
|
|
|
|
=head3 All foreign table columns are nullable |
1019
|
|
|
|
|
|
|
|
1020
|
|
|
|
|
|
|
In this case recursive_update defaults to nullifying the foreign columns. |
1021
|
|
|
|
|
|
|
|
1022
|
|
|
|
|
|
|
=head3 Not all foreign table columns are nullable |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
In this case recursive_update deletes the foreign rows. |
1025
|
|
|
|
|
|
|
|
1026
|
|
|
|
|
|
|
Updating the relationship: |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
Passing ids: |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1031
|
|
|
|
|
|
|
id => 1, |
1032
|
|
|
|
|
|
|
owned_dvds => [1, 2], |
1033
|
|
|
|
|
|
|
}); |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
Passing hashrefs: |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1038
|
|
|
|
|
|
|
id => 1, |
1039
|
|
|
|
|
|
|
owned_dvds => [ |
1040
|
|
|
|
|
|
|
{ |
1041
|
|
|
|
|
|
|
name => 'temp name 1', |
1042
|
|
|
|
|
|
|
}, |
1043
|
|
|
|
|
|
|
{ |
1044
|
|
|
|
|
|
|
name => 'temp name 2', |
1045
|
|
|
|
|
|
|
}, |
1046
|
|
|
|
|
|
|
], |
1047
|
|
|
|
|
|
|
}); |
1048
|
|
|
|
|
|
|
|
1049
|
|
|
|
|
|
|
Passing objects: |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1052
|
|
|
|
|
|
|
id => 1, |
1053
|
|
|
|
|
|
|
owned_dvds => [ $dvd1, $dvd2 ], |
1054
|
|
|
|
|
|
|
}); |
1055
|
|
|
|
|
|
|
|
1056
|
|
|
|
|
|
|
You can even mix them: |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1059
|
|
|
|
|
|
|
id => 1, |
1060
|
|
|
|
|
|
|
owned_dvds => [ 1, { id => 2 } ], |
1061
|
|
|
|
|
|
|
}); |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
Clearing the relationship: |
1064
|
|
|
|
|
|
|
|
1065
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1066
|
|
|
|
|
|
|
id => 1, |
1067
|
|
|
|
|
|
|
owned_dvds => undef, |
1068
|
|
|
|
|
|
|
}); |
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
This is the same as passing an empty array: |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
my $user = $user_rs->recursive_update( { |
1073
|
|
|
|
|
|
|
id => 1, |
1074
|
|
|
|
|
|
|
owned_dvds => [], |
1075
|
|
|
|
|
|
|
}); |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
=head2 Treatment of many-to-many pseudo relations |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
If a many-to-many accessor key is included in the data structure with a value |
1080
|
|
|
|
|
|
|
of undef or an empty array, all existing related rows are unlinked. |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
When the array contains elements they are updated if they exist, created when |
1083
|
|
|
|
|
|
|
not and deleted if not included. |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
RecursiveUpdate defaults to |
1086
|
|
|
|
|
|
|
calling 'set_$rel' to update many-to-many relationships. |
1087
|
|
|
|
|
|
|
See L<DBIx::Class::Relationship/many_to_many> for details. |
1088
|
|
|
|
|
|
|
set_$rel effectively removes and re-adds all relationship data, |
1089
|
|
|
|
|
|
|
even if the set of related items did not change at all. |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
If L<DBIx::Class::IntrospectableM2M> is in use, RecursiveUpdate will |
1092
|
|
|
|
|
|
|
look up the corresponding has_many relationship and use this to recursively |
1093
|
|
|
|
|
|
|
update the many-to-many relationship. |
1094
|
|
|
|
|
|
|
|
1095
|
|
|
|
|
|
|
While both mechanisms have the same final result, deleting and re-adding |
1096
|
|
|
|
|
|
|
all relationship data can have unwanted consequences if triggers or |
1097
|
|
|
|
|
|
|
method modifiers are defined or logging modules like L<DBIx::Class::AuditLog> |
1098
|
|
|
|
|
|
|
are in use. |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
The traditional "set_$rel" behaviour can be forced by passing |
1101
|
|
|
|
|
|
|
"m2m_force_set_rel => 1" to recursive_update. |
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
See L</is_m2m> for many-to-many pseudo relationship detection. |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
Updating the relationship: |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
Passing ids: |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1110
|
|
|
|
|
|
|
id => 1, |
1111
|
|
|
|
|
|
|
tags => [1, 2], |
1112
|
|
|
|
|
|
|
}); |
1113
|
|
|
|
|
|
|
|
1114
|
|
|
|
|
|
|
Passing hashrefs: |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1117
|
|
|
|
|
|
|
id => 1, |
1118
|
|
|
|
|
|
|
tags => [ |
1119
|
|
|
|
|
|
|
{ |
1120
|
|
|
|
|
|
|
id => 1, |
1121
|
|
|
|
|
|
|
file => 'file0' |
1122
|
|
|
|
|
|
|
}, |
1123
|
|
|
|
|
|
|
{ |
1124
|
|
|
|
|
|
|
id => 2, |
1125
|
|
|
|
|
|
|
file => 'file1', |
1126
|
|
|
|
|
|
|
}, |
1127
|
|
|
|
|
|
|
], |
1128
|
|
|
|
|
|
|
}); |
1129
|
|
|
|
|
|
|
|
1130
|
|
|
|
|
|
|
Passing objects: |
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1133
|
|
|
|
|
|
|
id => 1, |
1134
|
|
|
|
|
|
|
tags => [ $tag1, $tag2 ], |
1135
|
|
|
|
|
|
|
}); |
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
You can even mix them: |
1138
|
|
|
|
|
|
|
|
1139
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1140
|
|
|
|
|
|
|
id => 1, |
1141
|
|
|
|
|
|
|
tags => [ 2, { id => 3 } ], |
1142
|
|
|
|
|
|
|
}); |
1143
|
|
|
|
|
|
|
|
1144
|
|
|
|
|
|
|
Clearing the relationship: |
1145
|
|
|
|
|
|
|
|
1146
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1147
|
|
|
|
|
|
|
id => 1, |
1148
|
|
|
|
|
|
|
tags => undef, |
1149
|
|
|
|
|
|
|
}); |
1150
|
|
|
|
|
|
|
|
1151
|
|
|
|
|
|
|
This is the same as passing an empty array: |
1152
|
|
|
|
|
|
|
|
1153
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1154
|
|
|
|
|
|
|
id => 1, |
1155
|
|
|
|
|
|
|
tags => [], |
1156
|
|
|
|
|
|
|
}); |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
Make sure that set_$rel used to update many-to-many relationships |
1159
|
|
|
|
|
|
|
even if IntrospectableM2M is loaded: |
1160
|
|
|
|
|
|
|
|
1161
|
|
|
|
|
|
|
my $dvd = $dvd_rs->recursive_update( { |
1162
|
|
|
|
|
|
|
id => 1, |
1163
|
|
|
|
|
|
|
tags => [1, 2], |
1164
|
|
|
|
|
|
|
}, |
1165
|
|
|
|
|
|
|
{ m2m_force_set_rel => 1 }, |
1166
|
|
|
|
|
|
|
); |
1167
|
|
|
|
|
|
|
|
1168
|
|
|
|
|
|
|
=head1 INTERFACE |
1169
|
|
|
|
|
|
|
|
1170
|
|
|
|
|
|
|
=head1 METHODS |
1171
|
|
|
|
|
|
|
|
1172
|
|
|
|
|
|
|
=head2 recursive_update |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
The method that does the work here. |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
=head2 is_m2m |
1177
|
|
|
|
|
|
|
|
1178
|
|
|
|
|
|
|
=over 4 |
1179
|
|
|
|
|
|
|
|
1180
|
|
|
|
|
|
|
=item Arguments: $name |
1181
|
|
|
|
|
|
|
|
1182
|
|
|
|
|
|
|
=item Return Value: true, if $name is a many to many pseudo-relationship |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
=back |
1185
|
|
|
|
|
|
|
|
1186
|
|
|
|
|
|
|
The function gets the information about m2m relations from |
1187
|
|
|
|
|
|
|
L<DBIx::Class::IntrospectableM2M>. If it isn't loaded in the ResultSource |
1188
|
|
|
|
|
|
|
class, the code relies on the fact: |
1189
|
|
|
|
|
|
|
|
1190
|
|
|
|
|
|
|
if($object->can($name) and |
1191
|
|
|
|
|
|
|
!$object->result_source->has_relationship($name) and |
1192
|
|
|
|
|
|
|
$object->can( 'set_' . $name ) |
1193
|
|
|
|
|
|
|
) |
1194
|
|
|
|
|
|
|
|
1195
|
|
|
|
|
|
|
to identify a many to many pseudo relationship. In a similar ugly way the |
1196
|
|
|
|
|
|
|
ResultSource of that many to many pseudo relationship is detected. |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
So if you need many to many pseudo relationship support, it's strongly |
1199
|
|
|
|
|
|
|
recommended to load L<DBIx::Class::IntrospectableM2M> in your ResultSource |
1200
|
|
|
|
|
|
|
class! |
1201
|
|
|
|
|
|
|
|
1202
|
|
|
|
|
|
|
=head2 get_m2m_source |
1203
|
|
|
|
|
|
|
|
1204
|
|
|
|
|
|
|
=over 4 |
1205
|
|
|
|
|
|
|
|
1206
|
|
|
|
|
|
|
=item Arguments: $name |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
=item Return Value: $result_source |
1209
|
|
|
|
|
|
|
|
1210
|
|
|
|
|
|
|
=back |
1211
|
|
|
|
|
|
|
|
1212
|
|
|
|
|
|
|
=head1 CONFIGURATION AND ENVIRONMENT |
1213
|
|
|
|
|
|
|
|
1214
|
|
|
|
|
|
|
DBIx::Class::RecursiveUpdate requires no configuration files or environment variables. |
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
=head1 DEPENDENCIES |
1217
|
|
|
|
|
|
|
|
1218
|
|
|
|
|
|
|
DBIx::Class |
1219
|
|
|
|
|
|
|
|
1220
|
|
|
|
|
|
|
optional but recommended: |
1221
|
|
|
|
|
|
|
DBIx::Class::IntrospectableM2M |
1222
|
|
|
|
|
|
|
|
1223
|
|
|
|
|
|
|
=head1 INCOMPATIBILITIES |
1224
|
|
|
|
|
|
|
|
1225
|
|
|
|
|
|
|
None reported. |
1226
|
|
|
|
|
|
|
|
1227
|
|
|
|
|
|
|
=head1 BUGS AND LIMITATIONS |
1228
|
|
|
|
|
|
|
|
1229
|
|
|
|
|
|
|
The list of reported bugs can be viewed at L<http://rt.cpan.org/Public/Dist/Display.html?Name=DBIx-Class-ResultSet-RecursiveUpdate>. |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
Please report any bugs or feature requests to |
1232
|
|
|
|
|
|
|
C<bug-DBIx-Class-ResultSet-RecursiveUpdate@rt.cpan.org>, or through the web interface at |
1233
|
|
|
|
|
|
|
L<http://rt.cpan.org>. |
1234
|
|
|
|
|
|
|
|
1235
|
|
|
|
|
|
|
=head1 AUTHORS |
1236
|
|
|
|
|
|
|
|
1237
|
|
|
|
|
|
|
=over 4 |
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
=item * |
1240
|
|
|
|
|
|
|
|
1241
|
|
|
|
|
|
|
Zbigniew Lukasiak <zby@cpan.org> |
1242
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
=item * |
1244
|
|
|
|
|
|
|
|
1245
|
|
|
|
|
|
|
John Napiorkowski <jjnapiork@cpan.org> |
1246
|
|
|
|
|
|
|
|
1247
|
|
|
|
|
|
|
=item * |
1248
|
|
|
|
|
|
|
|
1249
|
|
|
|
|
|
|
Alexander Hartmaier <abraxxa@cpan.org> |
1250
|
|
|
|
|
|
|
|
1251
|
|
|
|
|
|
|
=item * |
1252
|
|
|
|
|
|
|
|
1253
|
|
|
|
|
|
|
Gerda Shank <gshank@cpan.org> |
1254
|
|
|
|
|
|
|
|
1255
|
|
|
|
|
|
|
=back |
1256
|
|
|
|
|
|
|
|
1257
|
|
|
|
|
|
|
=head1 COPYRIGHT AND LICENSE |
1258
|
|
|
|
|
|
|
|
1259
|
|
|
|
|
|
|
This software is copyright (c) 2019 by Zbigniew Lukasiak, John Napiorkowski, Alexander Hartmaier. |
1260
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
This is free software; you can redistribute it and/or modify it under |
1262
|
|
|
|
|
|
|
the same terms as the Perl 5 programming language system itself. |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
=cut |