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