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