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