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