fix related resultsets and multi-create
[dbsrgits/DBIx-Class.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/;
33dd4e80 8use Scalar::Util ();
9c6d6d93 9use Scope::Guard;
1edd1722 10
aec3eff1 11__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
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
33dd4e80 32Passing an object, or an arrayref of objects as a value will call
33L<DBIx::Class::Relationship::Base/set_from_related> for you. When
34passed a hashref or an arrayref of hashrefs as the value, these will
35be turned into objects via new_related, and treated as if you had
36passed objects.
37
264f1571 38For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
39
7624b19f 40=cut
41
33dd4e80 42## It needs to store the new objects somewhere, and call insert on that list later when insert is called on this object. We may need an accessor for these so the user can retrieve them, if just doing ->new().
43## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
44## When doing the later insert, we need to make sure the PKs are set.
45## using _relationship_data in new and funky ways..
46## check Relationship::CascadeActions and Relationship::Accessor for compat
47## tests!
48
370f2ba2 49sub __new_related_find_or_new_helper {
50 my ($self, $relname, $data) = @_;
51 if ($self->__their_pk_needs_us($relname, $data)) {
52 return $self->result_source
53 ->related_source($relname)
54 ->resultset
55 ->new_result($data);
56 }
57 if ($self->result_source->pk_depends_on($relname, $data)) {
58 return $self->result_source
59 ->related_source($relname)
60 ->resultset
61 ->find_or_new($data);
62 }
63 return $self->find_or_new_related($relname, $data);
64}
65
66sub __their_pk_needs_us { # this should maybe be in resultsource.
67 my ($self, $relname, $data) = @_;
68 my $source = $self->result_source;
69 my $reverse = $source->reverse_relationship_info($relname);
70 my $rel_source = $source->related_source($relname);
71 my $us = { $self->get_columns };
72 foreach my $key (keys %$reverse) {
73 # if their primary key depends on us, then we have to
74 # just create a result and we'll fill it out afterwards
75 return 1 if $rel_source->pk_depends_on($key, $us);
76 }
77 return 0;
78}
79
7624b19f 80sub new {
448f820f 81 my ($class, $attrs) = @_;
7624b19f 82 $class = ref $class if ref $class;
04786a4c 83
e60dc79f 84 my $new = {
85 _column_data => {},
86 };
04786a4c 87 bless $new, $class;
88
448f820f 89 if (my $handle = delete $attrs->{-source_handle}) {
90 $new->_source_handle($handle);
91 }
370f2ba2 92
93 my $source;
94 if ($source = delete $attrs->{-result_source}) {
e9fe476b 95 $new->result_source($source);
96 }
a6a280b9 97
7624b19f 98 if ($attrs) {
27f01d1f 99 $new->throw_exception("attrs must be a hashref")
100 unless ref($attrs) eq 'HASH';
61a622ee 101
102 my ($related,$inflated);
de7c7c53 103 ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
104 $new->{_rel_in_storage} = 1;
8222f722 105
61a622ee 106 foreach my $key (keys %$attrs) {
107 if (ref $attrs->{$key}) {
af2d42c0 108 ## Can we extract this lot to use with update(_or .. ) ?
370f2ba2 109 confess "Can't do multi-create without result source" unless $source;
110 my $info = $source->relationship_info($key);
61a622ee 111 if ($info && $info->{attrs}{accessor}
c4a30d56 112 && $info->{attrs}{accessor} eq 'single')
61a622ee 113 {
de7c7c53 114 my $rel_obj = delete $attrs->{$key};
33dd4e80 115 if(!Scalar::Util::blessed($rel_obj)) {
370f2ba2 116 $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
33dd4e80 117 }
2bc3c81e 118
119 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
120
370f2ba2 121 $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
de7c7c53 122 $related->{$key} = $rel_obj;
61a622ee 123 next;
33dd4e80 124 } elsif ($info && $info->{attrs}{accessor}
125 && $info->{attrs}{accessor} eq 'multi'
126 && ref $attrs->{$key} eq 'ARRAY') {
2ec8e594 127 my $others = delete $attrs->{$key};
128 foreach my $rel_obj (@$others) {
129 if(!Scalar::Util::blessed($rel_obj)) {
370f2ba2 130 $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
33dd4e80 131 }
2bc3c81e 132
133 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
370f2ba2 134 $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
2ec8e594 135 }
136 $related->{$key} = $others;
137 next;
138 } elsif ($info && $info->{attrs}{accessor}
139 && $info->{attrs}{accessor} eq 'filter')
61a622ee 140 {
33dd4e80 141 ## 'filter' should disappear and get merged in with 'single' above!
2ec8e594 142 my $rel_obj = delete $attrs->{$key};
33dd4e80 143 if(!Scalar::Util::blessed($rel_obj)) {
370f2ba2 144 $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
33dd4e80 145 }
370f2ba2 146 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
33dd4e80 147 $inflated->{$key} = $rel_obj;
61a622ee 148 next;
2ec8e594 149 } elsif ($class->has_column($key)
150 && $class->column_info($key)->{_inflate_info}) {
61a622ee 151 $inflated->{$key} = $attrs->{$key};
152 next;
153 }
154 }
155 $new->throw_exception("No such column $key on $class")
156 unless $class->has_column($key);
157 $new->store_column($key => $attrs->{$key});
7624b19f 158 }
f90375dd 159
61a622ee 160 $new->{_relationship_data} = $related if $related;
161 $new->{_inflated_column} = $inflated if $inflated;
7624b19f 162 }
04786a4c 163
7624b19f 164 return $new;
165}
166
8091aa91 167=head2 insert
7624b19f 168
169 $obj->insert;
170
b8810cc5 171Inserts an object into the database if it isn't already in
172there. Returns the object itself. Requires the object's result source to
173be set, or the class to have a result_source_instance method. To insert
174an entirely new object into the database, use C<create> (see
175L<DBIx::Class::ResultSet/create>).
7624b19f 176
e91e756c 177To fetch an uninserted row object, call
178L<new|DBIx::Class::ResultSet/new> on a resultset.
179
264f1571 180This will also insert any uninserted, related objects held inside this
181one, see L<DBIx::Class::ResultSet/create> for more details.
182
7624b19f 183=cut
184
185sub insert {
186 my ($self) = @_;
187 return $self if $self->in_storage;
6aba697f 188 my $source = $self->result_source;
189 $source ||= $self->result_source($self->result_source_instance)
097d3227 190 if $self->can('result_source_instance');
aeb1bf75 191 $self->throw_exception("No result_source set on this object; can't insert")
192 unless $source;
6e399b4f 193
9c6d6d93 194 my $rollback_guard;
195
33dd4e80 196 # Check if we stored uninserted relobjs here in new()
33dd4e80 197 my %related_stuff = (%{$self->{_relationship_data} || {}},
198 %{$self->{_inflated_column} || {}});
9c6d6d93 199
ae66ef47 200 if(!$self->{_rel_in_storage}) {
8222f722 201
9c6d6d93 202 # The guard will save us if we blow out of this scope via die
1bc193ac 203 $rollback_guard = $source->storage->txn_scope_guard;
9c6d6d93 204
8222f722 205 ## Should all be in relationship_data, but we need to get rid of the
206 ## 'filter' reltype..
207 ## These are the FK rels, need their IDs for the insert.
9c6d6d93 208
209 my @pri = $self->primary_columns;
210
211 REL: foreach my $relname (keys %related_stuff) {
a8c98174 212
213 my $rel_obj = $related_stuff{$relname};
214
215 next REL unless (Scalar::Util::blessed($rel_obj)
216 && $rel_obj->isa('DBIx::Class::Row'));
217
370f2ba2 218 next REL unless $source->pk_depends_on(
219 $relname, { $rel_obj->get_columns }
220 );
9c6d6d93 221
a8c98174 222 $rel_obj->insert();
223 $self->set_from_related($relname, $rel_obj);
224 delete $related_stuff{$relname};
33dd4e80 225 }
226 }
6e399b4f 227
ef5f6b0a 228 my $updated_cols = $source->storage->insert($source, { $self->get_columns });
229 $self->set_columns($updated_cols);
ac8e89d7 230
231 ## PK::Auto
3fda409f 232 my @auto_pri = grep {
233 !defined $self->get_column($_) ||
234 ref($self->get_column($_)) eq 'SCALAR'
235 } $self->primary_columns;
236
237 if (@auto_pri) {
238 #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
239 # if defined $too_many;
ac8e89d7 240
241 my $storage = $self->result_source->storage;
242 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
243 unless $storage->can('last_insert_id');
3fda409f 244 my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
245 $self->throw_exception( "Can't get last insert id" )
246 unless (@ids == @auto_pri);
247 $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
ac8e89d7 248 }
33dd4e80 249
370f2ba2 250 $self->{_dirty_columns} = {};
251 $self->{related_resultsets} = {};
252
ae66ef47 253 if(!$self->{_rel_in_storage}) {
8222f722 254 ## Now do the has_many rels, that need $selfs ID.
255 foreach my $relname (keys %related_stuff) {
9c6d6d93 256 my $rel_obj = $related_stuff{$relname};
257 my @cands;
258 if (Scalar::Util::blessed($rel_obj)
259 && $rel_obj->isa('DBIx::Class::Row')) {
260 @cands = ($rel_obj);
261 } elsif (ref $rel_obj eq 'ARRAY') {
262 @cands = @$rel_obj;
263 }
264 if (@cands) {
265 my $reverse = $source->reverse_relationship_info($relname);
266 foreach my $obj (@cands) {
267 $obj->set_from_related($_, $self) for keys %$reverse;
370f2ba2 268 my $them = { $obj->get_columns };
269 if ($self->__their_pk_needs_us($relname, $them)) {
270 $obj = $self->find_or_create_related($relname, $them);
271 } else {
272 $obj->insert();
273 }
8222f722 274 }
33dd4e80 275 }
276 }
1bc193ac 277 $rollback_guard->commit;
33dd4e80 278 }
33dd4e80 279
7624b19f 280 $self->in_storage(1);
729b29ae 281 undef $self->{_orig_ident};
7624b19f 282 return $self;
283}
284
8091aa91 285=head2 in_storage
7624b19f 286
287 $obj->in_storage; # Get value
288 $obj->in_storage(1); # Set value
289
e91e756c 290Indicates whether the object exists as a row in the database or
291not. This is set to true when L<DBIx::Class::ResultSet/find>,
292L<DBIx::Class::ResultSet/create> or L<DBIx::Class::ResultSet/insert>
293are used.
294
295Creating a row object using L<DBIx::Class::ResultSet/new>, or calling
296L</delete> on one, sets it to false.
7624b19f 297
298=cut
299
300sub in_storage {
301 my ($self, $val) = @_;
302 $self->{_in_storage} = $val if @_ > 1;
303 return $self->{_in_storage};
304}
305
8091aa91 306=head2 update
7624b19f 307
d5d833d9 308 $obj->update \%columns?;
7624b19f 309
310Must be run on an object that is already in the database; issues an SQL
d3b0e369 311UPDATE query to commit any changes to the object to the database if
312required.
7624b19f 313
d5d833d9 314Also takes an options hashref of C<< column_name => value> pairs >> to update
f7043881 315first. But be aware that the hashref will be passed to
bacf6f12 316C<set_inflated_columns>, which might edit it in place, so dont rely on it being
317the same after a call to C<update>. If you need to preserve the hashref, it is
318sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
d5d833d9 319
05d1bc9c 320If the values passed or any of the column values set on the object
321contain scalar references, eg:
322
323 $obj->last_modified(\'NOW()');
324 # OR
325 $obj->update({ last_modified => \'NOW()' });
326
327The update will pass the values verbatim into SQL. (See
328L<SQL::Abstract> docs). The values in your Row object will NOT change
329as a result of the update call, if you want the object to be updated
330with the actual values from the database, call L</discard_changes>
331after the update.
332
333 $obj->update()->discard_changes();
334
7624b19f 335=cut
336
337sub update {
338 my ($self, $upd) = @_;
701da8c4 339 $self->throw_exception( "Not in database" ) unless $self->in_storage;
4b12b3c2 340 my $ident_cond = $self->ident_condition;
341 $self->throw_exception("Cannot safely update a row in a PK-less table")
342 if ! keys %$ident_cond;
6e399b4f 343
bacf6f12 344 $self->set_inflated_columns($upd) if $upd;
5a9e0e60 345 my %to_update = $self->get_dirty_columns;
346 return $self unless keys %to_update;
88cb6a1d 347 my $rows = $self->result_source->storage->update(
f4afcd5d 348 $self->result_source, \%to_update,
349 $self->{_orig_ident} || $ident_cond
350 );
7624b19f 351 if ($rows == 0) {
701da8c4 352 $self->throw_exception( "Can't update ${self}: row not found" );
7624b19f 353 } elsif ($rows > 1) {
701da8c4 354 $self->throw_exception("Can't update ${self}: updated more than one row");
7624b19f 355 }
356 $self->{_dirty_columns} = {};
64acc2bc 357 $self->{related_resultsets} = {};
729b29ae 358 undef $self->{_orig_ident};
7624b19f 359 return $self;
360}
361
8091aa91 362=head2 delete
7624b19f 363
364 $obj->delete
365
b8810cc5 366Deletes the object from the database. The object is still perfectly
61a622ee 367usable, but C<< ->in_storage() >> will now return 0 and the object must
368reinserted using C<< ->insert() >> before C<< ->update() >> can be used
b8810cc5 369on it. If you delete an object in a class with a C<has_many>
370relationship, all the related objects will be deleted as well. To turn
977e7403 371this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
b8810cc5 372hashref. Any database-level cascade or restrict will take precedence
373over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
7624b19f 374
375=cut
376
377sub delete {
378 my $self = shift;
379 if (ref $self) {
701da8c4 380 $self->throw_exception( "Not in database" ) unless $self->in_storage;
4b12b3c2 381 my $ident_cond = $self->ident_condition;
382 $self->throw_exception("Cannot safely delete a row in a PK-less table")
383 if ! keys %$ident_cond;
e0f56292 384 foreach my $column (keys %$ident_cond) {
75d07914 385 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
386 unless exists $self->{_column_data}{$column};
e0f56292 387 }
88cb6a1d 388 $self->result_source->storage->delete(
7af8b477 389 $self->result_source, $ident_cond);
7624b19f 390 $self->in_storage(undef);
7624b19f 391 } else {
701da8c4 392 $self->throw_exception("Can't do class delete without a ResultSource instance")
097d3227 393 unless $self->can('result_source_instance');
aeb1bf75 394 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
395 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
097d3227 396 $self->result_source_instance->resultset->search(@_)->delete;
7624b19f 397 }
398 return $self;
399}
400
8091aa91 401=head2 get_column
7624b19f 402
403 my $val = $obj->get_column($col);
404
e91e756c 405Returns a raw column value from the row object, if it has already
406been fetched from the database or set by an accessor.
407
408If an L<inflated value|DBIx::Class::InflateColumn> has been set, it
409will be deflated and returned.
7624b19f 410
411=cut
412
413sub get_column {
414 my ($self, $column) = @_;
701da8c4 415 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
aeb1bf75 416 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
61a622ee 417 if (exists $self->{_inflated_column}{$column}) {
418 return $self->store_column($column,
419 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
420 }
701da8c4 421 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
7624b19f 422 return undef;
423}
424
9b83fccd 425=head2 has_column_loaded
426
427 if ( $obj->has_column_loaded($col) ) {
428 print "$col has been loaded from db";
429 }
430
431Returns a true value if the column value has been loaded from the
432database (or set locally).
433
434=cut
435
def81720 436sub has_column_loaded {
437 my ($self, $column) = @_;
438 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
61a622ee 439 return 1 if exists $self->{_inflated_column}{$column};
aeb1bf75 440 return exists $self->{_column_data}{$column};
def81720 441}
442
8091aa91 443=head2 get_columns
076a6864 444
445 my %data = $obj->get_columns;
446
e91e756c 447Does C<get_column>, for all loaded column values at once.
076a6864 448
449=cut
450
451sub get_columns {
452 my $self = shift;
61a622ee 453 if (exists $self->{_inflated_column}) {
454 foreach my $col (keys %{$self->{_inflated_column}}) {
455 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
c4a30d56 456 unless exists $self->{_column_data}{$col};
61a622ee 457 }
458 }
cb5f2eea 459 return %{$self->{_column_data}};
d7156e50 460}
461
462=head2 get_dirty_columns
463
464 my %data = $obj->get_dirty_columns;
465
466Identical to get_columns but only returns those that have been changed.
467
468=cut
469
470sub get_dirty_columns {
471 my $self = shift;
472 return map { $_ => $self->{_column_data}{$_} }
473 keys %{$self->{_dirty_columns}};
076a6864 474}
475
6dbea98e 476=head2 make_column_dirty
477
478Marks a column dirty regardless if it has really changed. Throws an
479exception if the column does not exist.
480
481=cut
482sub make_column_dirty {
483 my ($self, $column) = @_;
484
485 $self->throw_exception( "No such column '${column}'" )
486 unless exists $self->{_column_data}{$column} || $self->has_column($column);
487 $self->{_dirty_columns}{$column} = 1;
488}
489
ba4a6453 490=head2 get_inflated_columns
491
e91e756c 492 my %inflated_data = $obj->get_inflated_columns;
ba4a6453 493
e91e756c 494Similar to get_columns but objects are returned for inflated columns
495instead of their raw non-inflated values.
ba4a6453 496
497=cut
498
499sub get_inflated_columns {
500 my $self = shift;
501 return map {
502 my $accessor = $self->column_info($_)->{'accessor'} || $_;
503 ($_ => $self->$accessor);
504 } $self->columns;
505}
506
8091aa91 507=head2 set_column
7624b19f 508
509 $obj->set_column($col => $val);
510
e91e756c 511Sets a raw column value. If the new value is different from the old one,
8091aa91 512the column is marked as dirty for when you next call $obj->update.
7624b19f 513
e91e756c 514If passed an object or reference, this will happily attempt store the
515value, and a later insert/update will try and stringify/numify as
516appropriate.
517
7624b19f 518=cut
519
520sub set_column {
521 my $self = shift;
522 my ($column) = @_;
729b29ae 523 $self->{_orig_ident} ||= $self->ident_condition;
7624b19f 524 my $old = $self->get_column($column);
525 my $ret = $self->store_column(@_);
87772e46 526 $self->{_dirty_columns}{$column} = 1
4c9f72c1 527 if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
e60dc79f 528
529 # XXX clear out the relation cache for this column
530 delete $self->{related_resultsets}{$column};
531
7624b19f 532 return $ret;
533}
534
8091aa91 535=head2 set_columns
076a6864 536
dc818523 537 my $copy = $orig->set_columns({ $col => $val, ... });
076a6864 538
8091aa91 539Sets more than one column value at once.
076a6864 540
541=cut
542
543sub set_columns {
544 my ($self,$data) = @_;
a2ca474b 545 foreach my $col (keys %$data) {
546 $self->set_column($col,$data->{$col});
076a6864 547 }
c01ab172 548 return $self;
076a6864 549}
550
bacf6f12 551=head2 set_inflated_columns
552
553 my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
554
555Sets more than one column value at once, taking care to respect inflations and
556relationships if relevant. Be aware that this hashref might be edited in place,
557so dont rely on it being the same after a call to C<set_inflated_columns>. If
558you need to preserve the hashref, it is sufficient to pass a shallow copy to
559C<set_inflated_columns>, e.g. ( { %{ $href } } )
560
561=cut
562
563sub set_inflated_columns {
564 my ( $self, $upd ) = @_;
565 foreach my $key (keys %$upd) {
566 if (ref $upd->{$key}) {
567 my $info = $self->relationship_info($key);
568 if ($info && $info->{attrs}{accessor}
569 && $info->{attrs}{accessor} eq 'single')
570 {
571 my $rel = delete $upd->{$key};
572 $self->set_from_related($key => $rel);
573 $self->{_relationship_data}{$key} = $rel;
574 } elsif ($info && $info->{attrs}{accessor}
575 && $info->{attrs}{accessor} eq 'multi'
576 && ref $upd->{$key} eq 'ARRAY') {
577 my $others = delete $upd->{$key};
578 foreach my $rel_obj (@$others) {
579 if(!Scalar::Util::blessed($rel_obj)) {
580 $rel_obj = $self->create_related($key, $rel_obj);
581 }
582 }
583 $self->{_relationship_data}{$key} = $others;
584# $related->{$key} = $others;
585 next;
586 }
587 elsif ($self->has_column($key)
588 && exists $self->column_info($key)->{_inflate_info})
589 {
590 $self->set_inflated_column($key, delete $upd->{$key});
591 }
592 }
593 }
594 $self->set_columns($upd);
595}
596
8091aa91 597=head2 copy
076a6864 598
599 my $copy = $orig->copy({ change => $to, ... });
600
f4e92c39 601Inserts a new row with the specified changes. If the row has related
602objects in a C<has_many> then those objects may be copied too depending
603on the C<cascade_copy> relationship attribute.
076a6864 604
605=cut
606
c01ab172 607sub copy {
608 my ($self, $changes) = @_;
333cce60 609 $changes ||= {};
fde6e28e 610 my $col_data = { %{$self->{_column_data}} };
611 foreach my $col (keys %$col_data) {
612 delete $col_data->{$col}
613 if $self->result_source->column_info($col)->{is_auto_increment};
614 }
04786a4c 615
616 my $new = { _column_data => $col_data };
617 bless $new, ref $self;
618
83419ec6 619 $new->result_source($self->result_source);
bacf6f12 620 $new->set_inflated_columns($changes);
333cce60 621 $new->insert;
35688220 622
623 # Its possible we'll have 2 relations to the same Source. We need to make
624 # sure we don't try to insert the same row twice esle we'll violate unique
625 # constraints
626 my $rels_copied = {};
627
333cce60 628 foreach my $rel ($self->result_source->relationships) {
629 my $rel_info = $self->result_source->relationship_info($rel);
35688220 630
631 next unless $rel_info->{attrs}{cascade_copy};
632
633 my $resolved = $self->result_source->resolve_condition(
634 $rel_info->{cond}, $rel, $new
635 );
636
637 my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
638 foreach my $related ($self->search_related($rel)) {
639 my $id_str = join("\0", $related->id);
640 next if $copied->{$id_str};
641 $copied->{$id_str} = 1;
642 my $rel_copy = $related->copy($resolved);
333cce60 643 }
35688220 644
333cce60 645 }
2c4c67b6 646 return $new;
c01ab172 647}
648
8091aa91 649=head2 store_column
7624b19f 650
651 $obj->store_column($col => $val);
652
8091aa91 653Sets a column value without marking it as dirty.
7624b19f 654
655=cut
656
657sub store_column {
658 my ($self, $column, $value) = @_;
75d07914 659 $self->throw_exception( "No such column '${column}'" )
d7156e50 660 unless exists $self->{_column_data}{$column} || $self->has_column($column);
75d07914 661 $self->throw_exception( "set_column called for ${column} without value" )
7624b19f 662 if @_ < 3;
663 return $self->{_column_data}{$column} = $value;
664}
665
b52e9bf8 666=head2 inflate_result
667
c01ab172 668 Class->inflate_result($result_source, \%me, \%prefetch?)
b52e9bf8 669
670Called by ResultSet to inflate a result from storage
671
672=cut
673
674sub inflate_result {
c01ab172 675 my ($class, $source, $me, $prefetch) = @_;
aec3eff1 676
677 my ($source_handle) = $source;
678
679 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
680 $source = $source_handle->resolve
681 } else {
682 $source_handle = $source->handle
683 }
684
04786a4c 685 my $new = {
aec3eff1 686 _source_handle => $source_handle,
04786a4c 687 _column_data => $me,
688 _in_storage => 1
689 };
690 bless $new, (ref $class || $class);
691
7fb16f1a 692 my $schema;
64acc2bc 693 foreach my $pre (keys %{$prefetch||{}}) {
694 my $pre_val = $prefetch->{$pre};
f9cc31dd 695 my $pre_source = $source->related_source($pre);
a86b1efe 696 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
697 unless $pre_source;
0f66a01b 698 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
a86b1efe 699 my @pre_objects;
700 foreach my $pre_rec (@$pre_val) {
75d07914 701 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
5a5bec6c 702 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
a86b1efe 703 next;
704 }
705 push(@pre_objects, $pre_source->result_class->inflate_result(
706 $pre_source, @{$pre_rec}));
707 }
708 $new->related_resultset($pre)->set_cache(\@pre_objects);
62e87ea8 709 } elsif (defined $pre_val->[0]) {
a86b1efe 710 my $fetched;
75d07914 711 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
a86b1efe 712 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
713 {
714 $fetched = $pre_source->result_class->inflate_result(
75d07914 715 $pre_source, @{$pre_val});
a86b1efe 716 }
9809a6df 717 $new->related_resultset($pre)->set_cache([ $fetched ]);
a86b1efe 718 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
719 $class->throw_exception("No accessor for prefetched $pre")
720 unless defined $accessor;
721 if ($accessor eq 'single') {
722 $new->{_relationship_data}{$pre} = $fetched;
723 } elsif ($accessor eq 'filter') {
724 $new->{_inflated_column}{$pre} = $fetched;
725 } else {
726 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
727 }
b52e9bf8 728 }
729 }
7624b19f 730 return $new;
731}
732
9b465d00 733=head2 update_or_insert
7624b19f 734
9b465d00 735 $obj->update_or_insert
7624b19f 736
e91e756c 737Updates the object if it's already in the database, according to
738L</in_storage>, else inserts it.
7624b19f 739
9b83fccd 740=head2 insert_or_update
741
742 $obj->insert_or_update
743
744Alias for L</update_or_insert>
745
7624b19f 746=cut
747
370f2ba2 748sub insert_or_update { shift->update_or_insert(@_) }
749
9b465d00 750sub update_or_insert {
7624b19f 751 my $self = shift;
752 return ($self->in_storage ? $self->update : $self->insert);
753}
754
8091aa91 755=head2 is_changed
7624b19f 756
228dbcb4 757 my @changed_col_names = $obj->is_changed();
758 if ($obj->is_changed()) { ... }
7624b19f 759
9b83fccd 760In array context returns a list of columns with uncommited changes, or
761in scalar context returns a true value if there are uncommitted
762changes.
763
7624b19f 764=cut
765
766sub is_changed {
767 return keys %{shift->{_dirty_columns} || {}};
768}
228dbcb4 769
770=head2 is_column_changed
771
772 if ($obj->is_column_changed('col')) { ... }
773
9b83fccd 774Returns a true value if the column has uncommitted changes.
775
228dbcb4 776=cut
777
778sub is_column_changed {
779 my( $self, $col ) = @_;
780 return exists $self->{_dirty_columns}->{$col};
781}
7624b19f 782
097d3227 783=head2 result_source
784
9b83fccd 785 my $resultsource = $object->result_source;
097d3227 786
9b83fccd 787Accessor to the ResultSource this object was created from
87c4e602 788
aec3eff1 789=cut
790
791sub result_source {
792 my $self = shift;
793
794 if (@_) {
795 $self->_source_handle($_[0]->handle);
796 } else {
797 $self->_source_handle->resolve;
798 }
799}
800
9b83fccd 801=head2 register_column
27f01d1f 802
9b83fccd 803 $column_info = { .... };
804 $class->register_column($column_name, $column_info);
27f01d1f 805
9b83fccd 806Registers a column on the class. If the column_info has an 'accessor'
807key, creates an accessor named after the value if defined; if there is
808no such key, creates an accessor with the same name as the column
1f23a877 809
9b83fccd 810The column_info attributes are described in
811L<DBIx::Class::ResultSource/add_columns>
1f23a877 812
097d3227 813=cut
814
1f23a877 815sub register_column {
816 my ($class, $col, $info) = @_;
91b0fbd7 817 my $acc = $col;
818 if (exists $info->{accessor}) {
819 return unless defined $info->{accessor};
820 $acc = [ $info->{accessor}, $col ];
821 }
822 $class->mk_group_accessors('column' => $acc);
1f23a877 823}
824
7e38d850 825=head2 get_from_storage ($attrs)
b9b4e52f 826
827Returns a new Row which is whatever the Storage has for the currently created
bbafcf26 828Row object. You can use this to see if the storage has become inconsistent with
b9b4e52f 829whatever your Row object is.
830
7e38d850 831$attrs is expected to be a hashref of attributes suitable for passing as the
832second argument to $resultset->search($cond, $attrs);
833
b9b4e52f 834=cut
835
a737512c 836sub get_from_storage {
b9b4e52f 837 my $self = shift @_;
7e38d850 838 my $attrs = shift @_;
b9b4e52f 839 my @primary_columns = map { $self->$_ } $self->primary_columns;
7e38d850 840 my $resultset = $self->result_source->resultset;
841
842 if(defined $attrs) {
843 $resultset = $resultset->search(undef, $attrs);
844 }
845
846 return $resultset->find(@primary_columns);
b9b4e52f 847}
701da8c4 848
5160b401 849=head2 throw_exception
701da8c4 850
851See Schema's throw_exception.
852
853=cut
854
855sub throw_exception {
856 my $self=shift;
66cab05c 857 if (ref $self && ref $self->result_source && $self->result_source->schema) {
701da8c4 858 $self->result_source->schema->throw_exception(@_);
859 } else {
860 croak(@_);
861 }
862}
863
33cf6616 864=head2 id
865
866Returns the primary key(s) for a row. Can't be called as a class method.
f7043881 867Actually implemented in L<DBIx::Class::PK>
33cf6616 868
869=head2 discard_changes
870
871Re-selects the row from the database, losing any changes that had
872been made.
873
874This method can also be used to refresh from storage, retrieving any
875changes made since the row was last read from storage. Actually
f7043881 876implemented in L<DBIx::Class::PK>
33cf6616 877
878=cut
879
7624b19f 8801;
881
7624b19f 882=head1 AUTHORS
883
daec44b8 884Matt S. Trout <mst@shadowcatsystems.co.uk>
7624b19f 885
886=head1 LICENSE
887
888You may distribute this code under the same terms as Perl itself.
889
890=cut