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