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