1 package DBIx::Class::Row;
6 use base qw/DBIx::Class/;
7 use Carp::Clan qw/^DBIx::Class/;
11 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
15 DBIx::Class::Row - Basic row methods
21 This class is responsible for defining and doing basic operations on rows
22 derived from L<DBIx::Class::ResultSource> objects.
28 my $obj = My::Class->new($attrs);
30 Creates a new row object from column => value mappings passed as a hash ref
32 Passing an object, or an arrayref of objects as a value will call
33 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
34 passed a hashref or an arrayref of hashrefs as the value, these will
35 be turned into objects via new_related, and treated as if you had
38 For a more involved explanation, see L<DBIx::Class::ResultSet/create>.
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
50 my ($class, $attrs) = @_;
51 $class = ref $class if ref $class;
58 if (my $handle = delete $attrs->{-source_handle}) {
59 $new->_source_handle($handle);
61 if (my $source = delete $attrs->{-result_source}) {
62 $new->result_source($source);
66 $new->throw_exception("attrs must be a hashref")
67 unless ref($attrs) eq 'HASH';
69 my ($related,$inflated);
70 ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
71 $new->{_rel_in_storage} = 1;
73 foreach my $key (keys %$attrs) {
74 if (ref $attrs->{$key}) {
75 ## Can we extract this lot to use with update(_or .. ) ?
76 my $info = $class->relationship_info($key);
77 if ($info && $info->{attrs}{accessor}
78 && $info->{attrs}{accessor} eq 'single')
80 my $rel_obj = delete $attrs->{$key};
81 if(!Scalar::Util::blessed($rel_obj)) {
82 $rel_obj = $new->find_or_new_related($key, $rel_obj);
85 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
87 $new->set_from_related($key, $rel_obj);
88 $related->{$key} = $rel_obj;
90 } elsif ($info && $info->{attrs}{accessor}
91 && $info->{attrs}{accessor} eq 'multi'
92 && ref $attrs->{$key} eq 'ARRAY') {
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;
100 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
102 $related->{$key} = $others;
104 } elsif ($info && $info->{attrs}{accessor}
105 && $info->{attrs}{accessor} eq 'filter')
107 ## 'filter' should disappear and get merged in with 'single' above!
108 my $rel_obj = delete $attrs->{$key};
109 if(!Scalar::Util::blessed($rel_obj)) {
110 $rel_obj = $new->find_or_new_related($key, $rel_obj);
111 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
113 $inflated->{$key} = $rel_obj;
115 } elsif ($class->has_column($key)
116 && $class->column_info($key)->{_inflate_info}) {
117 $inflated->{$key} = $attrs->{$key};
121 $new->throw_exception("No such column $key on $class")
122 unless $class->has_column($key);
123 $new->store_column($key => $attrs->{$key});
126 $new->{_relationship_data} = $related if $related;
127 $new->{_inflated_column} = $inflated if $inflated;
137 Inserts an object into the database if it isn't already in
138 there. Returns the object itself. Requires the object's result source to
139 be set, or the class to have a result_source_instance method. To insert
140 an entirely new object into the database, use C<create> (see
141 L<DBIx::Class::ResultSet/create>).
143 This will also insert any uninserted, related objects held inside this
144 one, see L<DBIx::Class::ResultSet/create> for more details.
150 return $self if $self->in_storage;
151 my $source = $self->result_source;
152 $source ||= $self->result_source($self->result_source_instance)
153 if $self->can('result_source_instance');
154 $self->throw_exception("No result_source set on this object; can't insert")
159 # Check if we stored uninserted relobjs here in new()
160 my %related_stuff = (%{$self->{_relationship_data} || {}},
161 %{$self->{_inflated_column} || {}});
163 if(!$self->{_rel_in_storage}) {
164 $source->storage->txn_begin;
166 # The guard will save us if we blow out of this scope via die
168 $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
170 ## Should all be in relationship_data, but we need to get rid of the
171 ## 'filter' reltype..
172 ## These are the FK rels, need their IDs for the insert.
174 my @pri = $self->primary_columns;
176 REL: foreach my $relname (keys %related_stuff) {
178 my $rel_obj = $related_stuff{$relname};
180 next REL unless (Scalar::Util::blessed($rel_obj)
181 && $rel_obj->isa('DBIx::Class::Row'));
183 my $cond = $source->relationship_info($relname)->{cond};
185 next REL unless ref($cond) eq 'HASH';
187 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
189 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
191 # assume anything that references our PK probably is dependent on us
192 # rather than vice versa, unless the far side is (a) defined or (b)
195 foreach my $p (@pri) {
196 if (exists $keyhash->{$p}) {
197 unless (defined($rel_obj->get_column($keyhash->{$p}))
198 || $rel_obj->column_info($keyhash->{$p})
199 ->{is_auto_increment}) {
206 $self->set_from_related($relname, $rel_obj);
207 delete $related_stuff{$relname};
211 $source->storage->insert($source, { $self->get_columns });
214 my @auto_pri = grep {
215 !defined $self->get_column($_) ||
216 ref($self->get_column($_)) eq 'SCALAR'
217 } $self->primary_columns;
220 #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
221 # if defined $too_many;
223 my $storage = $self->result_source->storage;
224 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
225 unless $storage->can('last_insert_id');
226 my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
227 $self->throw_exception( "Can't get last insert id" )
228 unless (@ids == @auto_pri);
229 $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
232 if(!$self->{_rel_in_storage}) {
233 ## Now do the has_many rels, that need $selfs ID.
234 foreach my $relname (keys %related_stuff) {
235 my $rel_obj = $related_stuff{$relname};
237 if (Scalar::Util::blessed($rel_obj)
238 && $rel_obj->isa('DBIx::Class::Row')) {
240 } elsif (ref $rel_obj eq 'ARRAY') {
244 my $reverse = $source->reverse_relationship_info($relname);
245 foreach my $obj (@cands) {
246 $obj->set_from_related($_, $self) for keys %$reverse;
247 $obj->insert() unless ($obj->in_storage || $obj->result_source->resultset->search({$obj->get_columns})->count);
251 $source->storage->txn_commit;
252 $rollback_guard->dismiss;
255 $self->in_storage(1);
256 $self->{_dirty_columns} = {};
257 $self->{related_resultsets} = {};
258 undef $self->{_orig_ident};
264 $obj->in_storage; # Get value
265 $obj->in_storage(1); # Set value
267 Indicates whether the object exists as a row in the database or not
272 my ($self, $val) = @_;
273 $self->{_in_storage} = $val if @_ > 1;
274 return $self->{_in_storage};
279 $obj->update \%columns?;
281 Must be run on an object that is already in the database; issues an SQL
282 UPDATE query to commit any changes to the object to the database if
285 Also takes an options hashref of C<< column_name => value> pairs >> to update
286 first. But be awawre that the hashref will be passed to
287 C<set_inflated_columns>, which might edit it in place, so dont rely on it being
288 the same after a call to C<update>. If you need to preserve the hashref, it is
289 sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
294 my ($self, $upd) = @_;
295 $self->throw_exception( "Not in database" ) unless $self->in_storage;
296 my $ident_cond = $self->ident_condition;
297 $self->throw_exception("Cannot safely update a row in a PK-less table")
298 if ! keys %$ident_cond;
300 $self->set_inflated_columns($upd) if $upd;
301 my %to_update = $self->get_dirty_columns;
302 return $self unless keys %to_update;
303 my $rows = $self->result_source->storage->update(
304 $self->result_source, \%to_update,
305 $self->{_orig_ident} || $ident_cond
308 $self->throw_exception( "Can't update ${self}: row not found" );
309 } elsif ($rows > 1) {
310 $self->throw_exception("Can't update ${self}: updated more than one row");
312 $self->{_dirty_columns} = {};
313 $self->{related_resultsets} = {};
314 undef $self->{_orig_ident};
322 Deletes the object from the database. The object is still perfectly
323 usable, but C<< ->in_storage() >> will now return 0 and the object must
324 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
325 on it. If you delete an object in a class with a C<has_many>
326 relationship, all the related objects will be deleted as well. To turn
327 this behavior off, pass C<< cascade_delete => 0 >> in the C<$attr>
328 hashref. Any database-level cascade or restrict will take precedence
329 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
336 $self->throw_exception( "Not in database" ) unless $self->in_storage;
337 my $ident_cond = $self->ident_condition;
338 $self->throw_exception("Cannot safely delete a row in a PK-less table")
339 if ! keys %$ident_cond;
340 foreach my $column (keys %$ident_cond) {
341 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
342 unless exists $self->{_column_data}{$column};
344 $self->result_source->storage->delete(
345 $self->result_source, $ident_cond);
346 $self->in_storage(undef);
348 $self->throw_exception("Can't do class delete without a ResultSource instance")
349 unless $self->can('result_source_instance');
350 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
351 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
352 $self->result_source_instance->resultset->search(@_)->delete;
359 my $val = $obj->get_column($col);
361 Gets a column value from a row object. Does not do any queries; the column
362 must have already been fetched from the database and stored in the object. If
363 there is an inflated value stored that has not yet been deflated, it is deflated
364 when the method is invoked.
369 my ($self, $column) = @_;
370 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
371 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
372 if (exists $self->{_inflated_column}{$column}) {
373 return $self->store_column($column,
374 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
376 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
380 =head2 has_column_loaded
382 if ( $obj->has_column_loaded($col) ) {
383 print "$col has been loaded from db";
386 Returns a true value if the column value has been loaded from the
387 database (or set locally).
391 sub has_column_loaded {
392 my ($self, $column) = @_;
393 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
394 return 1 if exists $self->{_inflated_column}{$column};
395 return exists $self->{_column_data}{$column};
400 my %data = $obj->get_columns;
402 Does C<get_column>, for all column values at once.
408 if (exists $self->{_inflated_column}) {
409 foreach my $col (keys %{$self->{_inflated_column}}) {
410 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
411 unless exists $self->{_column_data}{$col};
414 return %{$self->{_column_data}};
417 =head2 get_dirty_columns
419 my %data = $obj->get_dirty_columns;
421 Identical to get_columns but only returns those that have been changed.
425 sub get_dirty_columns {
427 return map { $_ => $self->{_column_data}{$_} }
428 keys %{$self->{_dirty_columns}};
431 =head2 get_inflated_columns
433 my $inflated_data = $obj->get_inflated_columns;
435 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
439 sub get_inflated_columns {
442 my $accessor = $self->column_info($_)->{'accessor'} || $_;
443 ($_ => $self->$accessor);
449 $obj->set_column($col => $val);
451 Sets a column value. If the new value is different from the old one,
452 the column is marked as dirty for when you next call $obj->update.
459 $self->{_orig_ident} ||= $self->ident_condition;
460 my $old = $self->get_column($column);
461 my $ret = $self->store_column(@_);
462 $self->{_dirty_columns}{$column} = 1
463 if (defined $old xor defined $ret) || (defined $old && $old ne $ret);
465 # XXX clear out the relation cache for this column
466 delete $self->{related_resultsets}{$column};
473 my $copy = $orig->set_columns({ $col => $val, ... });
475 Sets more than one column value at once.
480 my ($self,$data) = @_;
481 foreach my $col (keys %$data) {
482 $self->set_column($col,$data->{$col});
487 =head2 set_inflated_columns
489 my $copy = $orig->set_inflated_columns({ $col => $val, $rel => $obj, ... });
491 Sets more than one column value at once, taking care to respect inflations and
492 relationships if relevant. Be aware that this hashref might be edited in place,
493 so dont rely on it being the same after a call to C<set_inflated_columns>. If
494 you need to preserve the hashref, it is sufficient to pass a shallow copy to
495 C<set_inflated_columns>, e.g. ( { %{ $href } } )
499 sub set_inflated_columns {
500 my ( $self, $upd ) = @_;
501 foreach my $key (keys %$upd) {
502 if (ref $upd->{$key}) {
503 my $info = $self->relationship_info($key);
504 if ($info && $info->{attrs}{accessor}
505 && $info->{attrs}{accessor} eq 'single')
507 my $rel = delete $upd->{$key};
508 $self->set_from_related($key => $rel);
509 $self->{_relationship_data}{$key} = $rel;
510 } elsif ($info && $info->{attrs}{accessor}
511 && $info->{attrs}{accessor} eq 'multi'
512 && ref $upd->{$key} eq 'ARRAY') {
513 my $others = delete $upd->{$key};
514 foreach my $rel_obj (@$others) {
515 if(!Scalar::Util::blessed($rel_obj)) {
516 $rel_obj = $self->create_related($key, $rel_obj);
519 $self->{_relationship_data}{$key} = $others;
520 # $related->{$key} = $others;
523 elsif ($self->has_column($key)
524 && exists $self->column_info($key)->{_inflate_info})
526 $self->set_inflated_column($key, delete $upd->{$key});
530 $self->set_columns($upd);
535 my $copy = $orig->copy({ change => $to, ... });
537 Inserts a new row with the specified changes.
542 my ($self, $changes) = @_;
544 my $col_data = { %{$self->{_column_data}} };
545 foreach my $col (keys %$col_data) {
546 delete $col_data->{$col}
547 if $self->result_source->column_info($col)->{is_auto_increment};
550 my $new = { _column_data => $col_data };
551 bless $new, ref $self;
553 $new->result_source($self->result_source);
554 $new->set_inflated_columns($changes);
557 # Its possible we'll have 2 relations to the same Source. We need to make
558 # sure we don't try to insert the same row twice esle we'll violate unique
560 my $rels_copied = {};
562 foreach my $rel ($self->result_source->relationships) {
563 my $rel_info = $self->result_source->relationship_info($rel);
565 next unless $rel_info->{attrs}{cascade_copy};
567 my $resolved = $self->result_source->resolve_condition(
568 $rel_info->{cond}, $rel, $new
571 my $copied = $rels_copied->{ $rel_info->{source} } ||= {};
572 foreach my $related ($self->search_related($rel)) {
573 my $id_str = join("\0", $related->id);
574 next if $copied->{$id_str};
575 $copied->{$id_str} = 1;
576 my $rel_copy = $related->copy($resolved);
585 $obj->store_column($col => $val);
587 Sets a column value without marking it as dirty.
592 my ($self, $column, $value) = @_;
593 $self->throw_exception( "No such column '${column}'" )
594 unless exists $self->{_column_data}{$column} || $self->has_column($column);
595 $self->throw_exception( "set_column called for ${column} without value" )
597 return $self->{_column_data}{$column} = $value;
600 =head2 inflate_result
602 Class->inflate_result($result_source, \%me, \%prefetch?)
604 Called by ResultSet to inflate a result from storage
609 my ($class, $source, $me, $prefetch) = @_;
611 my ($source_handle) = $source;
613 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
614 $source = $source_handle->resolve
616 $source_handle = $source->handle
620 _source_handle => $source_handle,
624 bless $new, (ref $class || $class);
627 foreach my $pre (keys %{$prefetch||{}}) {
628 my $pre_val = $prefetch->{$pre};
629 my $pre_source = $source->related_source($pre);
630 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
632 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
634 foreach my $pre_rec (@$pre_val) {
635 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
636 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
639 push(@pre_objects, $pre_source->result_class->inflate_result(
640 $pre_source, @{$pre_rec}));
642 $new->related_resultset($pre)->set_cache(\@pre_objects);
643 } elsif (defined $pre_val->[0]) {
645 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
646 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
648 $fetched = $pre_source->result_class->inflate_result(
649 $pre_source, @{$pre_val});
651 $new->related_resultset($pre)->set_cache([ $fetched ]);
652 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
653 $class->throw_exception("No accessor for prefetched $pre")
654 unless defined $accessor;
655 if ($accessor eq 'single') {
656 $new->{_relationship_data}{$pre} = $fetched;
657 } elsif ($accessor eq 'filter') {
658 $new->{_inflated_column}{$pre} = $fetched;
660 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
667 =head2 update_or_insert
669 $obj->update_or_insert
671 Updates the object if it's already in the db, else inserts it.
673 =head2 insert_or_update
675 $obj->insert_or_update
677 Alias for L</update_or_insert>
681 *insert_or_update = \&update_or_insert;
682 sub update_or_insert {
684 return ($self->in_storage ? $self->update : $self->insert);
689 my @changed_col_names = $obj->is_changed();
690 if ($obj->is_changed()) { ... }
692 In array context returns a list of columns with uncommited changes, or
693 in scalar context returns a true value if there are uncommitted
699 return keys %{shift->{_dirty_columns} || {}};
702 =head2 is_column_changed
704 if ($obj->is_column_changed('col')) { ... }
706 Returns a true value if the column has uncommitted changes.
710 sub is_column_changed {
711 my( $self, $col ) = @_;
712 return exists $self->{_dirty_columns}->{$col};
717 my $resultsource = $object->result_source;
719 Accessor to the ResultSource this object was created from
727 $self->_source_handle($_[0]->handle);
729 $self->_source_handle->resolve;
733 =head2 register_column
735 $column_info = { .... };
736 $class->register_column($column_name, $column_info);
738 Registers a column on the class. If the column_info has an 'accessor'
739 key, creates an accessor named after the value if defined; if there is
740 no such key, creates an accessor with the same name as the column
742 The column_info attributes are described in
743 L<DBIx::Class::ResultSource/add_columns>
747 sub register_column {
748 my ($class, $col, $info) = @_;
750 if (exists $info->{accessor}) {
751 return unless defined $info->{accessor};
752 $acc = [ $info->{accessor}, $col ];
754 $class->mk_group_accessors('column' => $acc);
758 =head2 throw_exception
760 See Schema's throw_exception.
764 sub throw_exception {
766 if (ref $self && ref $self->result_source && $self->result_source->schema) {
767 $self->result_source->schema->throw_exception(@_);
775 Returns the primary key(s) for a row. Can't be called as a class method.
776 Actually implemented in L<DBIx::Class::Pk>
778 =head2 discard_changes
780 Re-selects the row from the database, losing any changes that had
783 This method can also be used to refresh from storage, retrieving any
784 changes made since the row was last read from storage. Actually
785 implemented in L<DBIx::Class::Pk>
793 Matt S. Trout <mst@shadowcatsystems.co.uk>
797 You may distribute this code under the same terms as Perl itself.