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;
53 my $new = { _column_data => {} };
56 if (my $handle = delete $attrs->{-source_handle}) {
57 $new->_source_handle($handle);
59 if (my $source = delete $attrs->{-result_source}) {
60 $new->result_source($source);
64 $new->throw_exception("attrs must be a hashref")
65 unless ref($attrs) eq 'HASH';
67 my ($related,$inflated);
68 ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
69 $new->{_rel_in_storage} = 1;
71 foreach my $key (keys %$attrs) {
72 if (ref $attrs->{$key}) {
73 ## Can we extract this lot to use with update(_or .. ) ?
74 my $info = $class->relationship_info($key);
75 if ($info && $info->{attrs}{accessor}
76 && $info->{attrs}{accessor} eq 'single')
78 my $rel_obj = delete $attrs->{$key};
79 if(!Scalar::Util::blessed($rel_obj)) {
80 $rel_obj = $new->find_or_new_related($key, $rel_obj);
83 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
85 $new->set_from_related($key, $rel_obj);
86 $related->{$key} = $rel_obj;
88 } elsif ($info && $info->{attrs}{accessor}
89 && $info->{attrs}{accessor} eq 'multi'
90 && ref $attrs->{$key} eq 'ARRAY') {
91 my $others = delete $attrs->{$key};
92 foreach my $rel_obj (@$others) {
93 if(!Scalar::Util::blessed($rel_obj)) {
94 $rel_obj = $new->new_related($key, $rel_obj);
95 $new->{_rel_in_storage} = 0;
98 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
100 $related->{$key} = $others;
102 } elsif ($info && $info->{attrs}{accessor}
103 && $info->{attrs}{accessor} eq 'filter')
105 ## 'filter' should disappear and get merged in with 'single' above!
106 my $rel_obj = delete $attrs->{$key};
107 if(!Scalar::Util::blessed($rel_obj)) {
108 $rel_obj = $new->find_or_new_related($key, $rel_obj);
109 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
111 $inflated->{$key} = $rel_obj;
113 } elsif ($class->has_column($key)
114 && $class->column_info($key)->{_inflate_info}) {
115 $inflated->{$key} = $attrs->{$key};
120 $new->throw_exception("No such column $key on $class")
121 unless $class->has_column($key);
122 $new->store_column($key => $attrs->{$key});
125 $new->{_relationship_data} = $related if $related;
126 $new->{_inflated_column} = $inflated if $inflated;
136 Inserts an object into the database if it isn't already in
137 there. Returns the object itself. Requires the object's result source to
138 be set, or the class to have a result_source_instance method. To insert
139 an entirely new object into the database, use C<create> (see
140 L<DBIx::Class::ResultSet/create>).
142 This will also insert any uninserted, related objects held inside this
143 one, see L<DBIx::Class::ResultSet/create> for more details.
149 return $self if $self->in_storage;
150 my $source = $self->result_source;
151 $source ||= $self->result_source($self->result_source_instance)
152 if $self->can('result_source_instance');
153 $self->throw_exception("No result_source set on this object; can't insert")
158 # Check if we stored uninserted relobjs here in new()
159 my %related_stuff = (%{$self->{_relationship_data} || {}},
160 %{$self->{_inflated_column} || {}});
162 if(!$self->{_rel_in_storage}) {
163 $source->storage->txn_begin;
165 # The guard will save us if we blow out of this scope via die
167 $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
169 ## Should all be in relationship_data, but we need to get rid of the
170 ## 'filter' reltype..
171 ## These are the FK rels, need their IDs for the insert.
173 my @pri = $self->primary_columns;
175 REL: foreach my $relname (keys %related_stuff) {
177 my $rel_obj = $related_stuff{$relname};
179 next REL unless (Scalar::Util::blessed($rel_obj)
180 && $rel_obj->isa('DBIx::Class::Row'));
182 my $cond = $source->relationship_info($relname)->{cond};
184 next REL unless ref($cond) eq 'HASH';
186 # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
188 my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
190 # assume anything that references our PK probably is dependent on us
191 # rather than vice versa, unless the far side is (a) defined or (b)
194 foreach my $p (@pri) {
195 if (exists $keyhash->{$p}) {
196 unless (defined($rel_obj->get_column($keyhash->{$p}))
197 || $rel_obj->column_info($keyhash->{$p})
198 ->{is_auto_increment}) {
205 $self->set_from_related($relname, $rel_obj);
206 delete $related_stuff{$relname};
210 my $updated_cols = $source->storage->insert($source, { $self->get_columns });
211 $self->set_columns($updated_cols);
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 aware that this hashref might be edited in place, so dont rely on
287 it being the same after a call to C<update>. If you need to preserve the hashref,
288 it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
293 my ($self, $upd) = @_;
294 $self->throw_exception( "Not in database" ) unless $self->in_storage;
295 my $ident_cond = $self->ident_condition;
296 $self->throw_exception("Cannot safely update a row in a PK-less table")
297 if ! keys %$ident_cond;
300 foreach my $key (keys %$upd) {
301 if (ref $upd->{$key}) {
302 my $info = $self->relationship_info($key);
303 if ($info && $info->{attrs}{accessor}
304 && $info->{attrs}{accessor} eq 'single')
306 my $rel = delete $upd->{$key};
307 $self->set_from_related($key => $rel);
308 $self->{_relationship_data}{$key} = $rel;
309 } elsif ($info && $info->{attrs}{accessor}
310 && $info->{attrs}{accessor} eq 'multi'
311 && ref $upd->{$key} eq 'ARRAY') {
312 my $others = delete $upd->{$key};
313 foreach my $rel_obj (@$others) {
314 if(!Scalar::Util::blessed($rel_obj)) {
315 $rel_obj = $self->create_related($key, $rel_obj);
318 $self->{_relationship_data}{$key} = $others;
319 # $related->{$key} = $others;
322 elsif ($self->has_column($key)
323 && exists $self->column_info($key)->{_inflate_info})
325 $self->set_inflated_column($key, delete $upd->{$key});
329 $self->set_columns($upd);
331 my %to_update = $self->get_dirty_columns;
332 return $self unless keys %to_update;
333 my $rows = $self->result_source->storage->update(
334 $self->result_source, \%to_update,
335 $self->{_orig_ident} || $ident_cond
338 $self->throw_exception( "Can't update ${self}: row not found" );
339 } elsif ($rows > 1) {
340 $self->throw_exception("Can't update ${self}: updated more than one row");
342 $self->{_dirty_columns} = {};
343 $self->{related_resultsets} = {};
344 undef $self->{_orig_ident};
352 Deletes the object from the database. The object is still perfectly
353 usable, but C<< ->in_storage() >> will now return 0 and the object must
354 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
355 on it. If you delete an object in a class with a C<has_many>
356 relationship, all the related objects will be deleted as well. To turn
357 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
358 hashref. Any database-level cascade or restrict will take precedence
359 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
366 $self->throw_exception( "Not in database" ) unless $self->in_storage;
367 my $ident_cond = $self->ident_condition;
368 $self->throw_exception("Cannot safely delete a row in a PK-less table")
369 if ! keys %$ident_cond;
370 foreach my $column (keys %$ident_cond) {
371 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
372 unless exists $self->{_column_data}{$column};
374 $self->result_source->storage->delete(
375 $self->result_source, $ident_cond);
376 $self->in_storage(undef);
378 $self->throw_exception("Can't do class delete without a ResultSource instance")
379 unless $self->can('result_source_instance');
380 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
381 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
382 $self->result_source_instance->resultset->search(@_)->delete;
389 my $val = $obj->get_column($col);
391 Gets a column value from a row object. Does not do any queries; the column
392 must have already been fetched from the database and stored in the object. If
393 there is an inflated value stored that has not yet been deflated, it is deflated
394 when the method is invoked.
399 my ($self, $column) = @_;
400 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
401 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
402 if (exists $self->{_inflated_column}{$column}) {
403 return $self->store_column($column,
404 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
406 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
410 =head2 has_column_loaded
412 if ( $obj->has_column_loaded($col) ) {
413 print "$col has been loaded from db";
416 Returns a true value if the column value has been loaded from the
417 database (or set locally).
421 sub has_column_loaded {
422 my ($self, $column) = @_;
423 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
424 return 1 if exists $self->{_inflated_column}{$column};
425 return exists $self->{_column_data}{$column};
430 my %data = $obj->get_columns;
432 Does C<get_column>, for all column values at once.
438 if (exists $self->{_inflated_column}) {
439 foreach my $col (keys %{$self->{_inflated_column}}) {
440 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
441 unless exists $self->{_column_data}{$col};
444 return %{$self->{_column_data}};
447 =head2 get_dirty_columns
449 my %data = $obj->get_dirty_columns;
451 Identical to get_columns but only returns those that have been changed.
455 sub get_dirty_columns {
457 return map { $_ => $self->{_column_data}{$_} }
458 keys %{$self->{_dirty_columns}};
461 =head2 get_inflated_columns
463 my $inflated_data = $obj->get_inflated_columns;
465 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
469 sub get_inflated_columns {
472 my $accessor = $self->column_info($_)->{'accessor'} || $_;
473 ($_ => $self->$accessor);
479 $obj->set_column($col => $val);
481 Sets a column value. If the new value is different from the old one,
482 the column is marked as dirty for when you next call $obj->update.
489 $self->{_orig_ident} ||= $self->ident_condition;
490 my $old = $self->get_column($column);
491 my $ret = $self->store_column(@_);
492 $self->{_dirty_columns}{$column} = 1
493 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
499 my $copy = $orig->set_columns({ $col => $val, ... });
501 Sets more than one column value at once.
506 my ($self,$data) = @_;
507 foreach my $col (keys %$data) {
508 $self->set_column($col,$data->{$col});
515 my $copy = $orig->copy({ change => $to, ... });
517 Inserts a new row with the specified changes.
522 my ($self, $changes) = @_;
524 my $col_data = { %{$self->{_column_data}} };
525 foreach my $col (keys %$col_data) {
526 delete $col_data->{$col}
527 if $self->result_source->column_info($col)->{is_auto_increment};
530 my $new = { _column_data => $col_data };
531 bless $new, ref $self;
533 $new->result_source($self->result_source);
534 $new->set_columns($changes);
536 foreach my $rel ($self->result_source->relationships) {
537 my $rel_info = $self->result_source->relationship_info($rel);
538 if ($rel_info->{attrs}{cascade_copy}) {
539 my $resolved = $self->result_source->resolve_condition(
540 $rel_info->{cond}, $rel, $new);
541 foreach my $related ($self->search_related($rel)) {
542 $related->copy($resolved);
551 $obj->store_column($col => $val);
553 Sets a column value without marking it as dirty.
558 my ($self, $column, $value) = @_;
559 $self->throw_exception( "No such column '${column}'" )
560 unless exists $self->{_column_data}{$column} || $self->has_column($column);
561 $self->throw_exception( "set_column called for ${column} without value" )
563 return $self->{_column_data}{$column} = $value;
566 =head2 inflate_result
568 Class->inflate_result($result_source, \%me, \%prefetch?)
570 Called by ResultSet to inflate a result from storage
575 my ($class, $source, $me, $prefetch) = @_;
577 my ($source_handle) = $source;
579 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
580 $source = $source_handle->resolve
582 $source_handle = $source->handle
586 _source_handle => $source_handle,
590 bless $new, (ref $class || $class);
593 foreach my $pre (keys %{$prefetch||{}}) {
594 my $pre_val = $prefetch->{$pre};
595 my $pre_source = $source->related_source($pre);
596 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
598 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
600 foreach my $pre_rec (@$pre_val) {
601 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
602 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
605 push(@pre_objects, $pre_source->result_class->inflate_result(
606 $pre_source, @{$pre_rec}));
608 $new->related_resultset($pre)->set_cache(\@pre_objects);
609 } elsif (defined $pre_val->[0]) {
611 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
612 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
614 $fetched = $pre_source->result_class->inflate_result(
615 $pre_source, @{$pre_val});
617 $new->related_resultset($pre)->set_cache([ $fetched ]);
618 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
619 $class->throw_exception("No accessor for prefetched $pre")
620 unless defined $accessor;
621 if ($accessor eq 'single') {
622 $new->{_relationship_data}{$pre} = $fetched;
623 } elsif ($accessor eq 'filter') {
624 $new->{_inflated_column}{$pre} = $fetched;
626 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
633 =head2 update_or_insert
635 $obj->update_or_insert
637 Updates the object if it's already in the db, else inserts it.
639 =head2 insert_or_update
641 $obj->insert_or_update
643 Alias for L</update_or_insert>
647 *insert_or_update = \&update_or_insert;
648 sub update_or_insert {
650 return ($self->in_storage ? $self->update : $self->insert);
655 my @changed_col_names = $obj->is_changed();
656 if ($obj->is_changed()) { ... }
658 In array context returns a list of columns with uncommited changes, or
659 in scalar context returns a true value if there are uncommitted
665 return keys %{shift->{_dirty_columns} || {}};
668 =head2 is_column_changed
670 if ($obj->is_column_changed('col')) { ... }
672 Returns a true value if the column has uncommitted changes.
676 sub is_column_changed {
677 my( $self, $col ) = @_;
678 return exists $self->{_dirty_columns}->{$col};
683 my $resultsource = $object->result_source;
685 Accessor to the ResultSource this object was created from
693 $self->_source_handle($_[0]->handle);
695 $self->_source_handle->resolve;
699 =head2 register_column
701 $column_info = { .... };
702 $class->register_column($column_name, $column_info);
704 Registers a column on the class. If the column_info has an 'accessor'
705 key, creates an accessor named after the value if defined; if there is
706 no such key, creates an accessor with the same name as the column
708 The column_info attributes are described in
709 L<DBIx::Class::ResultSource/add_columns>
713 sub register_column {
714 my ($class, $col, $info) = @_;
716 if (exists $info->{accessor}) {
717 return unless defined $info->{accessor};
718 $acc = [ $info->{accessor}, $col ];
720 $class->mk_group_accessors('column' => $acc);
724 =head2 throw_exception
726 See Schema's throw_exception.
730 sub throw_exception {
732 if (ref $self && ref $self->result_source && $self->result_source->schema) {
733 $self->result_source->schema->throw_exception(@_);
743 Matt S. Trout <mst@shadowcatsystems.co.uk>
747 You may distribute this code under the same terms as Perl itself.