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