Commit | Line | Data |
7624b19f |
1 | package DBIx::Class::Row; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
1edd1722 |
6 | use base qw/DBIx::Class/; |
701da8c4 |
7 | use Carp::Clan qw/^DBIx::Class/; |
1edd1722 |
8 | |
aec3eff1 |
9 | __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/); |
8c49f629 |
10 | |
75d07914 |
11 | =head1 NAME |
7624b19f |
12 | |
13 | DBIx::Class::Row - Basic row methods |
14 | |
15 | =head1 SYNOPSIS |
16 | |
17 | =head1 DESCRIPTION |
18 | |
19 | This class is responsible for defining and doing basic operations on rows |
1ea77c14 |
20 | derived from L<DBIx::Class::ResultSource> objects. |
7624b19f |
21 | |
22 | =head1 METHODS |
23 | |
8091aa91 |
24 | =head2 new |
7624b19f |
25 | |
26 | my $obj = My::Class->new($attrs); |
27 | |
28 | Creates a new row object from column => value mappings passed as a hash ref |
29 | |
30 | =cut |
31 | |
32 | sub new { |
61354236 |
33 | my ($class, $attrs, $source) = @_; |
7624b19f |
34 | $class = ref $class if ref $class; |
04786a4c |
35 | |
36 | my $new = { _column_data => {} }; |
37 | bless $new, $class; |
38 | |
a6a280b9 |
39 | $new->_source_handle($source) if $source; |
40 | |
7624b19f |
41 | if ($attrs) { |
27f01d1f |
42 | $new->throw_exception("attrs must be a hashref") |
43 | unless ref($attrs) eq 'HASH'; |
61a622ee |
44 | |
45 | my ($related,$inflated); |
46 | foreach my $key (keys %$attrs) { |
47 | if (ref $attrs->{$key}) { |
48 | my $info = $class->relationship_info($key); |
49 | if ($info && $info->{attrs}{accessor} |
c4a30d56 |
50 | && $info->{attrs}{accessor} eq 'single') |
61a622ee |
51 | { |
52 | $new->set_from_related($key, $attrs->{$key}); |
53 | $related->{$key} = $attrs->{$key}; |
54 | next; |
55 | } |
56 | elsif ($class->has_column($key) |
57 | && exists $class->column_info($key)->{_inflate_info}) |
58 | { |
59 | $inflated->{$key} = $attrs->{$key}; |
60 | next; |
61 | } |
62 | } |
63 | $new->throw_exception("No such column $key on $class") |
64 | unless $class->has_column($key); |
65 | $new->store_column($key => $attrs->{$key}); |
7624b19f |
66 | } |
f90375dd |
67 | if (my $source = delete $attrs->{-result_source}) { |
68 | $new->result_source($source); |
7624b19f |
69 | } |
f90375dd |
70 | |
61a622ee |
71 | $new->{_relationship_data} = $related if $related; |
72 | $new->{_inflated_column} = $inflated if $inflated; |
7624b19f |
73 | } |
04786a4c |
74 | |
7624b19f |
75 | return $new; |
76 | } |
77 | |
8091aa91 |
78 | =head2 insert |
7624b19f |
79 | |
80 | $obj->insert; |
81 | |
b8810cc5 |
82 | Inserts an object into the database if it isn't already in |
83 | there. Returns the object itself. Requires the object's result source to |
84 | be set, or the class to have a result_source_instance method. To insert |
85 | an entirely new object into the database, use C<create> (see |
86 | L<DBIx::Class::ResultSet/create>). |
7624b19f |
87 | |
88 | =cut |
89 | |
90 | sub insert { |
91 | my ($self) = @_; |
92 | return $self if $self->in_storage; |
6aba697f |
93 | my $source = $self->result_source; |
94 | $source ||= $self->result_source($self->result_source_instance) |
097d3227 |
95 | if $self->can('result_source_instance'); |
aeb1bf75 |
96 | $self->throw_exception("No result_source set on this object; can't insert") |
97 | unless $source; |
7624b19f |
98 | #use Data::Dumper; warn Dumper($self); |
097d3227 |
99 | $source->storage->insert($source->from, { $self->get_columns }); |
7624b19f |
100 | $self->in_storage(1); |
101 | $self->{_dirty_columns} = {}; |
64acc2bc |
102 | $self->{related_resultsets} = {}; |
729b29ae |
103 | undef $self->{_orig_ident}; |
7624b19f |
104 | return $self; |
105 | } |
106 | |
8091aa91 |
107 | =head2 in_storage |
7624b19f |
108 | |
109 | $obj->in_storage; # Get value |
110 | $obj->in_storage(1); # Set value |
111 | |
112 | Indicated whether the object exists as a row in the database or not |
113 | |
114 | =cut |
115 | |
116 | sub in_storage { |
117 | my ($self, $val) = @_; |
118 | $self->{_in_storage} = $val if @_ > 1; |
119 | return $self->{_in_storage}; |
120 | } |
121 | |
8091aa91 |
122 | =head2 update |
7624b19f |
123 | |
124 | $obj->update; |
125 | |
126 | Must be run on an object that is already in the database; issues an SQL |
d3b0e369 |
127 | UPDATE query to commit any changes to the object to the database if |
128 | required. |
7624b19f |
129 | |
130 | =cut |
131 | |
132 | sub update { |
133 | my ($self, $upd) = @_; |
701da8c4 |
134 | $self->throw_exception( "Not in database" ) unless $self->in_storage; |
4b12b3c2 |
135 | my $ident_cond = $self->ident_condition; |
136 | $self->throw_exception("Cannot safely update a row in a PK-less table") |
137 | if ! keys %$ident_cond; |
61a622ee |
138 | if ($upd) { |
139 | foreach my $key (keys %$upd) { |
140 | if (ref $upd->{$key}) { |
141 | my $info = $self->relationship_info($key); |
142 | if ($info && $info->{attrs}{accessor} |
143 | && $info->{attrs}{accessor} eq 'single') |
144 | { |
145 | my $rel = delete $upd->{$key}; |
146 | $self->set_from_related($key => $rel); |
147 | $self->{_relationship_data}{$key} = $rel; |
148 | } |
149 | elsif ($self->has_column($key) |
150 | && exists $self->column_info($key)->{_inflate_info}) |
151 | { |
152 | $self->set_inflated_column($key, delete $upd->{$key}); |
153 | } |
154 | } |
155 | } |
156 | $self->set_columns($upd); |
157 | } |
5a9e0e60 |
158 | my %to_update = $self->get_dirty_columns; |
159 | return $self unless keys %to_update; |
88cb6a1d |
160 | my $rows = $self->result_source->storage->update( |
6c299e8b |
161 | $self->result_source->from, \%to_update, $self->{_orig_ident} || $ident_cond); |
7624b19f |
162 | if ($rows == 0) { |
701da8c4 |
163 | $self->throw_exception( "Can't update ${self}: row not found" ); |
7624b19f |
164 | } elsif ($rows > 1) { |
701da8c4 |
165 | $self->throw_exception("Can't update ${self}: updated more than one row"); |
7624b19f |
166 | } |
167 | $self->{_dirty_columns} = {}; |
64acc2bc |
168 | $self->{related_resultsets} = {}; |
729b29ae |
169 | undef $self->{_orig_ident}; |
7624b19f |
170 | return $self; |
171 | } |
172 | |
8091aa91 |
173 | =head2 delete |
7624b19f |
174 | |
175 | $obj->delete |
176 | |
b8810cc5 |
177 | Deletes the object from the database. The object is still perfectly |
61a622ee |
178 | usable, but C<< ->in_storage() >> will now return 0 and the object must |
179 | reinserted using C<< ->insert() >> before C<< ->update() >> can be used |
b8810cc5 |
180 | on it. If you delete an object in a class with a C<has_many> |
181 | relationship, all the related objects will be deleted as well. To turn |
182 | this behavior off, pass C<cascade_delete => 0> in the C<$attr> |
183 | hashref. Any database-level cascade or restrict will take precedence |
184 | over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>. |
7624b19f |
185 | |
186 | =cut |
187 | |
188 | sub delete { |
189 | my $self = shift; |
190 | if (ref $self) { |
701da8c4 |
191 | $self->throw_exception( "Not in database" ) unless $self->in_storage; |
4b12b3c2 |
192 | my $ident_cond = $self->ident_condition; |
193 | $self->throw_exception("Cannot safely delete a row in a PK-less table") |
194 | if ! keys %$ident_cond; |
e0f56292 |
195 | foreach my $column (keys %$ident_cond) { |
75d07914 |
196 | $self->throw_exception("Can't delete the object unless it has loaded the primary keys") |
197 | unless exists $self->{_column_data}{$column}; |
e0f56292 |
198 | } |
88cb6a1d |
199 | $self->result_source->storage->delete( |
4b12b3c2 |
200 | $self->result_source->from, $ident_cond); |
7624b19f |
201 | $self->in_storage(undef); |
7624b19f |
202 | } else { |
701da8c4 |
203 | $self->throw_exception("Can't do class delete without a ResultSource instance") |
097d3227 |
204 | unless $self->can('result_source_instance'); |
aeb1bf75 |
205 | my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; |
206 | my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; |
097d3227 |
207 | $self->result_source_instance->resultset->search(@_)->delete; |
7624b19f |
208 | } |
209 | return $self; |
210 | } |
211 | |
8091aa91 |
212 | =head2 get_column |
7624b19f |
213 | |
214 | my $val = $obj->get_column($col); |
215 | |
61a622ee |
216 | Gets a column value from a row object. Does not do any queries; the column |
217 | must have already been fetched from the database and stored in the object. If |
218 | there is an inflated value stored that has not yet been deflated, it is deflated |
219 | when the method is invoked. |
7624b19f |
220 | |
221 | =cut |
222 | |
223 | sub get_column { |
224 | my ($self, $column) = @_; |
701da8c4 |
225 | $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; |
aeb1bf75 |
226 | return $self->{_column_data}{$column} if exists $self->{_column_data}{$column}; |
61a622ee |
227 | if (exists $self->{_inflated_column}{$column}) { |
228 | return $self->store_column($column, |
229 | $self->_deflated_column($column, $self->{_inflated_column}{$column})); |
230 | } |
701da8c4 |
231 | $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column); |
7624b19f |
232 | return undef; |
233 | } |
234 | |
9b83fccd |
235 | =head2 has_column_loaded |
236 | |
237 | if ( $obj->has_column_loaded($col) ) { |
238 | print "$col has been loaded from db"; |
239 | } |
240 | |
241 | Returns a true value if the column value has been loaded from the |
c4a30d56 |
242 | database (or set locally). |
9b83fccd |
243 | |
244 | =cut |
245 | |
def81720 |
246 | sub has_column_loaded { |
247 | my ($self, $column) = @_; |
248 | $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self; |
61a622ee |
249 | return 1 if exists $self->{_inflated_column}{$column}; |
aeb1bf75 |
250 | return exists $self->{_column_data}{$column}; |
def81720 |
251 | } |
252 | |
8091aa91 |
253 | =head2 get_columns |
076a6864 |
254 | |
255 | my %data = $obj->get_columns; |
256 | |
8091aa91 |
257 | Does C<get_column>, for all column values at once. |
076a6864 |
258 | |
259 | =cut |
260 | |
261 | sub get_columns { |
262 | my $self = shift; |
61a622ee |
263 | if (exists $self->{_inflated_column}) { |
264 | foreach my $col (keys %{$self->{_inflated_column}}) { |
265 | $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col})) |
c4a30d56 |
266 | unless exists $self->{_column_data}{$col}; |
61a622ee |
267 | } |
268 | } |
cb5f2eea |
269 | return %{$self->{_column_data}}; |
d7156e50 |
270 | } |
271 | |
272 | =head2 get_dirty_columns |
273 | |
274 | my %data = $obj->get_dirty_columns; |
275 | |
276 | Identical to get_columns but only returns those that have been changed. |
277 | |
278 | =cut |
279 | |
280 | sub get_dirty_columns { |
281 | my $self = shift; |
282 | return map { $_ => $self->{_column_data}{$_} } |
283 | keys %{$self->{_dirty_columns}}; |
076a6864 |
284 | } |
285 | |
8091aa91 |
286 | =head2 set_column |
7624b19f |
287 | |
288 | $obj->set_column($col => $val); |
289 | |
8091aa91 |
290 | Sets a column value. If the new value is different from the old one, |
291 | the column is marked as dirty for when you next call $obj->update. |
7624b19f |
292 | |
293 | =cut |
294 | |
295 | sub set_column { |
296 | my $self = shift; |
297 | my ($column) = @_; |
729b29ae |
298 | $self->{_orig_ident} ||= $self->ident_condition; |
7624b19f |
299 | my $old = $self->get_column($column); |
300 | my $ret = $self->store_column(@_); |
87772e46 |
301 | $self->{_dirty_columns}{$column} = 1 |
302 | if (defined $old ^ defined $ret) || (defined $old && $old ne $ret); |
7624b19f |
303 | return $ret; |
304 | } |
305 | |
8091aa91 |
306 | =head2 set_columns |
076a6864 |
307 | |
dc818523 |
308 | my $copy = $orig->set_columns({ $col => $val, ... }); |
076a6864 |
309 | |
8091aa91 |
310 | Sets more than one column value at once. |
076a6864 |
311 | |
312 | =cut |
313 | |
314 | sub set_columns { |
315 | my ($self,$data) = @_; |
a2ca474b |
316 | foreach my $col (keys %$data) { |
317 | $self->set_column($col,$data->{$col}); |
076a6864 |
318 | } |
c01ab172 |
319 | return $self; |
076a6864 |
320 | } |
321 | |
8091aa91 |
322 | =head2 copy |
076a6864 |
323 | |
324 | my $copy = $orig->copy({ change => $to, ... }); |
325 | |
8091aa91 |
326 | Inserts a new row with the specified changes. |
076a6864 |
327 | |
328 | =cut |
329 | |
c01ab172 |
330 | sub copy { |
331 | my ($self, $changes) = @_; |
333cce60 |
332 | $changes ||= {}; |
fde6e28e |
333 | my $col_data = { %{$self->{_column_data}} }; |
334 | foreach my $col (keys %$col_data) { |
335 | delete $col_data->{$col} |
336 | if $self->result_source->column_info($col)->{is_auto_increment}; |
337 | } |
04786a4c |
338 | |
339 | my $new = { _column_data => $col_data }; |
340 | bless $new, ref $self; |
341 | |
83419ec6 |
342 | $new->result_source($self->result_source); |
ecd1f408 |
343 | $new->set_columns($changes); |
333cce60 |
344 | $new->insert; |
345 | foreach my $rel ($self->result_source->relationships) { |
346 | my $rel_info = $self->result_source->relationship_info($rel); |
347 | if ($rel_info->{attrs}{cascade_copy}) { |
348 | my $resolved = $self->result_source->resolve_condition( |
349 | $rel_info->{cond}, $rel, $new); |
350 | foreach my $related ($self->search_related($rel)) { |
351 | $related->copy($resolved); |
352 | } |
353 | } |
354 | } |
2c4c67b6 |
355 | return $new; |
c01ab172 |
356 | } |
357 | |
8091aa91 |
358 | =head2 store_column |
7624b19f |
359 | |
360 | $obj->store_column($col => $val); |
361 | |
8091aa91 |
362 | Sets a column value without marking it as dirty. |
7624b19f |
363 | |
364 | =cut |
365 | |
366 | sub store_column { |
367 | my ($self, $column, $value) = @_; |
75d07914 |
368 | $self->throw_exception( "No such column '${column}'" ) |
d7156e50 |
369 | unless exists $self->{_column_data}{$column} || $self->has_column($column); |
75d07914 |
370 | $self->throw_exception( "set_column called for ${column} without value" ) |
7624b19f |
371 | if @_ < 3; |
372 | return $self->{_column_data}{$column} = $value; |
373 | } |
374 | |
b52e9bf8 |
375 | =head2 inflate_result |
376 | |
c01ab172 |
377 | Class->inflate_result($result_source, \%me, \%prefetch?) |
b52e9bf8 |
378 | |
379 | Called by ResultSet to inflate a result from storage |
380 | |
381 | =cut |
382 | |
383 | sub inflate_result { |
c01ab172 |
384 | my ($class, $source, $me, $prefetch) = @_; |
aec3eff1 |
385 | |
386 | my ($source_handle) = $source; |
387 | |
388 | if ($source->isa('DBIx::Class::ResultSourceHandle')) { |
389 | $source = $source_handle->resolve |
390 | } else { |
391 | $source_handle = $source->handle |
392 | } |
393 | |
04786a4c |
394 | my $new = { |
aec3eff1 |
395 | _source_handle => $source_handle, |
04786a4c |
396 | _column_data => $me, |
397 | _in_storage => 1 |
398 | }; |
399 | bless $new, (ref $class || $class); |
400 | |
7fb16f1a |
401 | my $schema; |
64acc2bc |
402 | foreach my $pre (keys %{$prefetch||{}}) { |
403 | my $pre_val = $prefetch->{$pre}; |
f9cc31dd |
404 | my $pre_source = $source->related_source($pre); |
a86b1efe |
405 | $class->throw_exception("Can't prefetch non-existent relationship ${pre}") |
406 | unless $pre_source; |
0f66a01b |
407 | if (ref($pre_val->[0]) eq 'ARRAY') { # multi |
a86b1efe |
408 | my @pre_objects; |
409 | foreach my $pre_rec (@$pre_val) { |
75d07914 |
410 | unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_} |
5a5bec6c |
411 | and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) { |
a86b1efe |
412 | next; |
413 | } |
414 | push(@pre_objects, $pre_source->result_class->inflate_result( |
415 | $pre_source, @{$pre_rec})); |
416 | } |
417 | $new->related_resultset($pre)->set_cache(\@pre_objects); |
62e87ea8 |
418 | } elsif (defined $pre_val->[0]) { |
a86b1efe |
419 | my $fetched; |
75d07914 |
420 | unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_} |
a86b1efe |
421 | and !defined $pre_val->[0]{$_} } $pre_source->primary_columns) |
422 | { |
423 | $fetched = $pre_source->result_class->inflate_result( |
75d07914 |
424 | $pre_source, @{$pre_val}); |
a86b1efe |
425 | } |
426 | my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; |
427 | $class->throw_exception("No accessor for prefetched $pre") |
428 | unless defined $accessor; |
429 | if ($accessor eq 'single') { |
430 | $new->{_relationship_data}{$pre} = $fetched; |
431 | } elsif ($accessor eq 'filter') { |
432 | $new->{_inflated_column}{$pre} = $fetched; |
433 | } else { |
434 | $class->throw_exception("Prefetch not supported with accessor '$accessor'"); |
435 | } |
b52e9bf8 |
436 | } |
437 | } |
7624b19f |
438 | return $new; |
439 | } |
440 | |
9b465d00 |
441 | =head2 update_or_insert |
7624b19f |
442 | |
9b465d00 |
443 | $obj->update_or_insert |
7624b19f |
444 | |
8091aa91 |
445 | Updates the object if it's already in the db, else inserts it. |
7624b19f |
446 | |
9b83fccd |
447 | =head2 insert_or_update |
448 | |
449 | $obj->insert_or_update |
450 | |
451 | Alias for L</update_or_insert> |
452 | |
7624b19f |
453 | =cut |
454 | |
9b465d00 |
455 | *insert_or_update = \&update_or_insert; |
456 | sub update_or_insert { |
7624b19f |
457 | my $self = shift; |
458 | return ($self->in_storage ? $self->update : $self->insert); |
459 | } |
460 | |
8091aa91 |
461 | =head2 is_changed |
7624b19f |
462 | |
228dbcb4 |
463 | my @changed_col_names = $obj->is_changed(); |
464 | if ($obj->is_changed()) { ... } |
7624b19f |
465 | |
9b83fccd |
466 | In array context returns a list of columns with uncommited changes, or |
467 | in scalar context returns a true value if there are uncommitted |
468 | changes. |
469 | |
7624b19f |
470 | =cut |
471 | |
472 | sub is_changed { |
473 | return keys %{shift->{_dirty_columns} || {}}; |
474 | } |
228dbcb4 |
475 | |
476 | =head2 is_column_changed |
477 | |
478 | if ($obj->is_column_changed('col')) { ... } |
479 | |
9b83fccd |
480 | Returns a true value if the column has uncommitted changes. |
481 | |
228dbcb4 |
482 | =cut |
483 | |
484 | sub is_column_changed { |
485 | my( $self, $col ) = @_; |
486 | return exists $self->{_dirty_columns}->{$col}; |
487 | } |
7624b19f |
488 | |
097d3227 |
489 | =head2 result_source |
490 | |
9b83fccd |
491 | my $resultsource = $object->result_source; |
097d3227 |
492 | |
9b83fccd |
493 | Accessor to the ResultSource this object was created from |
87c4e602 |
494 | |
aec3eff1 |
495 | =cut |
496 | |
497 | sub result_source { |
498 | my $self = shift; |
499 | |
500 | if (@_) { |
501 | $self->_source_handle($_[0]->handle); |
502 | } else { |
503 | $self->_source_handle->resolve; |
504 | } |
505 | } |
506 | |
9b83fccd |
507 | =head2 register_column |
27f01d1f |
508 | |
9b83fccd |
509 | $column_info = { .... }; |
510 | $class->register_column($column_name, $column_info); |
27f01d1f |
511 | |
9b83fccd |
512 | Registers a column on the class. If the column_info has an 'accessor' |
513 | key, creates an accessor named after the value if defined; if there is |
514 | no such key, creates an accessor with the same name as the column |
1f23a877 |
515 | |
9b83fccd |
516 | The column_info attributes are described in |
517 | L<DBIx::Class::ResultSource/add_columns> |
1f23a877 |
518 | |
097d3227 |
519 | =cut |
520 | |
1f23a877 |
521 | sub register_column { |
522 | my ($class, $col, $info) = @_; |
91b0fbd7 |
523 | my $acc = $col; |
524 | if (exists $info->{accessor}) { |
525 | return unless defined $info->{accessor}; |
526 | $acc = [ $info->{accessor}, $col ]; |
527 | } |
528 | $class->mk_group_accessors('column' => $acc); |
1f23a877 |
529 | } |
530 | |
701da8c4 |
531 | |
5160b401 |
532 | =head2 throw_exception |
701da8c4 |
533 | |
534 | See Schema's throw_exception. |
535 | |
536 | =cut |
537 | |
538 | sub throw_exception { |
539 | my $self=shift; |
540 | if (ref $self && ref $self->result_source) { |
541 | $self->result_source->schema->throw_exception(@_); |
542 | } else { |
543 | croak(@_); |
544 | } |
545 | } |
546 | |
7624b19f |
547 | 1; |
548 | |
7624b19f |
549 | =head1 AUTHORS |
550 | |
daec44b8 |
551 | Matt S. Trout <mst@shadowcatsystems.co.uk> |
7624b19f |
552 | |
553 | =head1 LICENSE |
554 | |
555 | You may distribute this code under the same terms as Perl itself. |
556 | |
557 | =cut |