resultset_class/result_class now (again) auto loads the specified class; requires...
[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
8091aa91 295=head2 set_column
7624b19f 296
297 $obj->set_column($col => $val);
298
8091aa91 299Sets a column value. If the new value is different from the old one,
300the column is marked as dirty for when you next call $obj->update.
7624b19f 301
302=cut
303
304sub set_column {
305 my $self = shift;
306 my ($column) = @_;
729b29ae 307 $self->{_orig_ident} ||= $self->ident_condition;
7624b19f 308 my $old = $self->get_column($column);
309 my $ret = $self->store_column(@_);
87772e46 310 $self->{_dirty_columns}{$column} = 1
311 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
7624b19f 312 return $ret;
313}
314
8091aa91 315=head2 set_columns
076a6864 316
dc818523 317 my $copy = $orig->set_columns({ $col => $val, ... });
076a6864 318
8091aa91 319Sets more than one column value at once.
076a6864 320
321=cut
322
323sub set_columns {
324 my ($self,$data) = @_;
a2ca474b 325 foreach my $col (keys %$data) {
326 $self->set_column($col,$data->{$col});
076a6864 327 }
c01ab172 328 return $self;
076a6864 329}
330
8091aa91 331=head2 copy
076a6864 332
333 my $copy = $orig->copy({ change => $to, ... });
334
8091aa91 335Inserts a new row with the specified changes.
076a6864 336
337=cut
338
c01ab172 339sub copy {
340 my ($self, $changes) = @_;
333cce60 341 $changes ||= {};
fde6e28e 342 my $col_data = { %{$self->{_column_data}} };
343 foreach my $col (keys %$col_data) {
344 delete $col_data->{$col}
345 if $self->result_source->column_info($col)->{is_auto_increment};
346 }
04786a4c 347
348 my $new = { _column_data => $col_data };
349 bless $new, ref $self;
350
83419ec6 351 $new->result_source($self->result_source);
ecd1f408 352 $new->set_columns($changes);
333cce60 353 $new->insert;
354 foreach my $rel ($self->result_source->relationships) {
355 my $rel_info = $self->result_source->relationship_info($rel);
356 if ($rel_info->{attrs}{cascade_copy}) {
357 my $resolved = $self->result_source->resolve_condition(
358 $rel_info->{cond}, $rel, $new);
359 foreach my $related ($self->search_related($rel)) {
360 $related->copy($resolved);
361 }
362 }
363 }
2c4c67b6 364 return $new;
c01ab172 365}
366
8091aa91 367=head2 store_column
7624b19f 368
369 $obj->store_column($col => $val);
370
8091aa91 371Sets a column value without marking it as dirty.
7624b19f 372
373=cut
374
375sub store_column {
376 my ($self, $column, $value) = @_;
75d07914 377 $self->throw_exception( "No such column '${column}'" )
d7156e50 378 unless exists $self->{_column_data}{$column} || $self->has_column($column);
75d07914 379 $self->throw_exception( "set_column called for ${column} without value" )
7624b19f 380 if @_ < 3;
381 return $self->{_column_data}{$column} = $value;
382}
383
b52e9bf8 384=head2 inflate_result
385
c01ab172 386 Class->inflate_result($result_source, \%me, \%prefetch?)
b52e9bf8 387
388Called by ResultSet to inflate a result from storage
389
390=cut
391
392sub inflate_result {
c01ab172 393 my ($class, $source, $me, $prefetch) = @_;
aec3eff1 394
395 my ($source_handle) = $source;
396
397 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
398 $source = $source_handle->resolve
399 } else {
400 $source_handle = $source->handle
401 }
402
04786a4c 403 my $new = {
aec3eff1 404 _source_handle => $source_handle,
04786a4c 405 _column_data => $me,
406 _in_storage => 1
407 };
408 bless $new, (ref $class || $class);
409
7fb16f1a 410 my $schema;
64acc2bc 411 foreach my $pre (keys %{$prefetch||{}}) {
412 my $pre_val = $prefetch->{$pre};
f9cc31dd 413 my $pre_source = $source->related_source($pre);
a86b1efe 414 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
415 unless $pre_source;
0f66a01b 416 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
a86b1efe 417 my @pre_objects;
418 foreach my $pre_rec (@$pre_val) {
75d07914 419 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
5a5bec6c 420 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
a86b1efe 421 next;
422 }
423 push(@pre_objects, $pre_source->result_class->inflate_result(
424 $pre_source, @{$pre_rec}));
425 }
426 $new->related_resultset($pre)->set_cache(\@pre_objects);
62e87ea8 427 } elsif (defined $pre_val->[0]) {
a86b1efe 428 my $fetched;
75d07914 429 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
a86b1efe 430 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
431 {
432 $fetched = $pre_source->result_class->inflate_result(
75d07914 433 $pre_source, @{$pre_val});
a86b1efe 434 }
435 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
436 $class->throw_exception("No accessor for prefetched $pre")
437 unless defined $accessor;
438 if ($accessor eq 'single') {
439 $new->{_relationship_data}{$pre} = $fetched;
440 } elsif ($accessor eq 'filter') {
441 $new->{_inflated_column}{$pre} = $fetched;
442 } else {
443 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
444 }
b52e9bf8 445 }
446 }
7624b19f 447 return $new;
448}
449
9b465d00 450=head2 update_or_insert
7624b19f 451
9b465d00 452 $obj->update_or_insert
7624b19f 453
8091aa91 454Updates the object if it's already in the db, else inserts it.
7624b19f 455
9b83fccd 456=head2 insert_or_update
457
458 $obj->insert_or_update
459
460Alias for L</update_or_insert>
461
7624b19f 462=cut
463
9b465d00 464*insert_or_update = \&update_or_insert;
465sub update_or_insert {
7624b19f 466 my $self = shift;
467 return ($self->in_storage ? $self->update : $self->insert);
468}
469
8091aa91 470=head2 is_changed
7624b19f 471
228dbcb4 472 my @changed_col_names = $obj->is_changed();
473 if ($obj->is_changed()) { ... }
7624b19f 474
9b83fccd 475In array context returns a list of columns with uncommited changes, or
476in scalar context returns a true value if there are uncommitted
477changes.
478
7624b19f 479=cut
480
481sub is_changed {
482 return keys %{shift->{_dirty_columns} || {}};
483}
228dbcb4 484
485=head2 is_column_changed
486
487 if ($obj->is_column_changed('col')) { ... }
488
9b83fccd 489Returns a true value if the column has uncommitted changes.
490
228dbcb4 491=cut
492
493sub is_column_changed {
494 my( $self, $col ) = @_;
495 return exists $self->{_dirty_columns}->{$col};
496}
7624b19f 497
097d3227 498=head2 result_source
499
9b83fccd 500 my $resultsource = $object->result_source;
097d3227 501
9b83fccd 502Accessor to the ResultSource this object was created from
87c4e602 503
aec3eff1 504=cut
505
506sub result_source {
507 my $self = shift;
508
509 if (@_) {
510 $self->_source_handle($_[0]->handle);
511 } else {
512 $self->_source_handle->resolve;
513 }
514}
515
9b83fccd 516=head2 register_column
27f01d1f 517
9b83fccd 518 $column_info = { .... };
519 $class->register_column($column_name, $column_info);
27f01d1f 520
9b83fccd 521Registers a column on the class. If the column_info has an 'accessor'
522key, creates an accessor named after the value if defined; if there is
523no such key, creates an accessor with the same name as the column
1f23a877 524
9b83fccd 525The column_info attributes are described in
526L<DBIx::Class::ResultSource/add_columns>
1f23a877 527
097d3227 528=cut
529
1f23a877 530sub register_column {
531 my ($class, $col, $info) = @_;
91b0fbd7 532 my $acc = $col;
533 if (exists $info->{accessor}) {
534 return unless defined $info->{accessor};
535 $acc = [ $info->{accessor}, $col ];
536 }
537 $class->mk_group_accessors('column' => $acc);
1f23a877 538}
539
701da8c4 540
5160b401 541=head2 throw_exception
701da8c4 542
543See Schema's throw_exception.
544
545=cut
546
547sub throw_exception {
548 my $self=shift;
549 if (ref $self && ref $self->result_source) {
550 $self->result_source->schema->throw_exception(@_);
551 } else {
552 croak(@_);
553 }
554}
555
7624b19f 5561;
557
7624b19f 558=head1 AUTHORS
559
daec44b8 560Matt S. Trout <mst@shadowcatsystems.co.uk>
7624b19f 561
562=head1 LICENSE
563
564You may distribute this code under the same terms as Perl itself.
565
566=cut