1 package DBIx::Class::Row;
6 use base qw/DBIx::Class/;
7 use Carp::Clan qw/^DBIx::Class/;
10 __PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
14 DBIx::Class::Row - Basic row methods
20 This class is responsible for defining and doing basic operations on rows
21 derived from L<DBIx::Class::ResultSource> objects.
27 my $obj = My::Class->new($attrs);
29 Creates a new row object from column => value mappings passed as a hash ref
31 Passing an object, or an arrayref of objects as a value will call
32 L<DBIx::Class::Relationship::Base/set_from_related> for you. When
33 passed a hashref or an arrayref of hashrefs as the value, these will
34 be turned into objects via new_related, and treated as if you had
39 ## 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().
40 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
41 ## When doing the later insert, we need to make sure the PKs are set.
42 ## using _relationship_data in new and funky ways..
43 ## check Relationship::CascadeActions and Relationship::Accessor for compat
47 my ($class, $attrs) = @_;
48 $class = ref $class if ref $class;
50 my $new = { _column_data => {} };
53 if (my $handle = delete $attrs->{-source_handle}) {
54 $new->_source_handle($handle);
56 if (my $source = delete $attrs->{-result_source}) {
57 $new->result_source($source);
61 $new->throw_exception("attrs must be a hashref")
62 unless ref($attrs) eq 'HASH';
64 my ($related,$inflated);
65 ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
66 $new->{_rel_in_storage} = 1;
68 foreach my $key (keys %$attrs) {
69 if (ref $attrs->{$key}) {
70 ## Can we extract this lot to use with update(_or .. ) ?
71 my $info = $class->relationship_info($key);
72 if ($info && $info->{attrs}{accessor}
73 && $info->{attrs}{accessor} eq 'single')
75 my $rel_obj = delete $attrs->{$key};
76 if(!Scalar::Util::blessed($rel_obj)) {
77 $rel_obj = $new->find_or_new_related($key, $rel_obj);
78 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
80 $new->set_from_related($key, $rel_obj);
81 $related->{$key} = $rel_obj;
83 } elsif ($info && $info->{attrs}{accessor}
84 && $info->{attrs}{accessor} eq 'multi'
85 && ref $attrs->{$key} eq 'ARRAY') {
86 my $others = delete $attrs->{$key};
87 foreach my $rel_obj (@$others) {
88 if(!Scalar::Util::blessed($rel_obj)) {
89 $rel_obj = $new->new_related($key, $rel_obj);
90 $new->{_rel_in_storage} = 0;
93 $related->{$key} = $others;
95 } elsif ($info && $info->{attrs}{accessor}
96 && $info->{attrs}{accessor} eq 'filter')
98 ## 'filter' should disappear and get merged in with 'single' above!
99 my $rel_obj = delete $attrs->{$key};
100 if(!Scalar::Util::blessed($rel_obj)) {
101 $rel_obj = $new->find_or_new_related($key, $rel_obj);
102 $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
104 $inflated->{$key} = $rel_obj;
106 } elsif ($class->has_column($key)
107 && $class->column_info($key)->{_inflate_info}) {
108 $inflated->{$key} = $attrs->{$key};
113 $new->throw_exception("No such column $key on $class")
114 unless $class->has_column($key);
115 $new->store_column($key => $attrs->{$key});
118 $new->{_relationship_data} = $related if $related;
119 $new->{_inflated_column} = $inflated if $inflated;
129 Inserts an object into the database if it isn't already in
130 there. Returns the object itself. Requires the object's result source to
131 be set, or the class to have a result_source_instance method. To insert
132 an entirely new object into the database, use C<create> (see
133 L<DBIx::Class::ResultSet/create>).
139 return $self if $self->in_storage;
140 my $source = $self->result_source;
141 $source ||= $self->result_source($self->result_source_instance)
142 if $self->can('result_source_instance');
143 $self->throw_exception("No result_source set on this object; can't insert")
146 # Check if we stored uninserted relobjs here in new()
147 my %related_stuff = (%{$self->{_relationship_data} || {}},
148 %{$self->{_inflated_column} || {}});
149 if(!$self->{_rel_in_storage})
151 $source->storage->txn_begin;
153 ## Should all be in relationship_data, but we need to get rid of the
154 ## 'filter' reltype..
155 ## These are the FK rels, need their IDs for the insert.
156 foreach my $relname (keys %related_stuff) {
157 my $rel_obj = $related_stuff{$relname};
158 if(Scalar::Util::blessed($rel_obj) && $rel_obj->isa('DBIx::Class::Row')) {
160 $self->set_from_related($relname, $rel_obj);
165 $source->storage->insert($source, { $self->get_columns });
168 my @auto_pri = grep {
169 !defined $self->get_column($_) ||
170 ref($self->get_column($_)) eq 'SCALAR'
171 } $self->primary_columns;
174 #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
175 # if defined $too_many;
177 my $storage = $self->result_source->storage;
178 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
179 unless $storage->can('last_insert_id');
180 my @ids = $storage->last_insert_id($self->result_source,@auto_pri);
181 $self->throw_exception( "Can't get last insert id" )
182 unless (@ids == @auto_pri);
183 $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
186 if(!$self->{_rel_in_storage})
188 ## Now do the has_many rels, that need $selfs ID.
189 foreach my $relname (keys %related_stuff) {
190 my $relobj = $related_stuff{$relname};
191 if(ref $relobj eq 'ARRAY') {
192 foreach my $obj (@$relobj) {
193 my $info = $self->relationship_info($relname);
194 ## What about multi-col FKs ?
195 my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
196 $obj->set_from_related($key, $self);
197 $obj->insert() if(!$obj->in_storage);
201 $source->storage->txn_commit;
204 $self->in_storage(1);
205 $self->{_dirty_columns} = {};
206 $self->{related_resultsets} = {};
207 undef $self->{_orig_ident};
213 $obj->in_storage; # Get value
214 $obj->in_storage(1); # Set value
216 Indicated whether the object exists as a row in the database or not
221 my ($self, $val) = @_;
222 $self->{_in_storage} = $val if @_ > 1;
223 return $self->{_in_storage};
228 $obj->update \%columns?;
230 Must be run on an object that is already in the database; issues an SQL
231 UPDATE query to commit any changes to the object to the database if
234 Also takes an options hashref of C<< column_name => value> pairs >> to update
235 first. But be aware that this hashref might be edited in place, so dont rely on
236 it being the same after a call to C<update>. If you need to preserve the hashref,
237 it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
242 my ($self, $upd) = @_;
243 $self->throw_exception( "Not in database" ) unless $self->in_storage;
244 my $ident_cond = $self->ident_condition;
245 $self->throw_exception("Cannot safely update a row in a PK-less table")
246 if ! keys %$ident_cond;
249 foreach my $key (keys %$upd) {
250 if (ref $upd->{$key}) {
251 my $info = $self->relationship_info($key);
252 if ($info && $info->{attrs}{accessor}
253 && $info->{attrs}{accessor} eq 'single')
255 my $rel = delete $upd->{$key};
256 $self->set_from_related($key => $rel);
257 $self->{_relationship_data}{$key} = $rel;
258 } elsif ($info && $info->{attrs}{accessor}
259 && $info->{attrs}{accessor} eq 'multi'
260 && ref $upd->{$key} eq 'ARRAY') {
261 my $others = delete $upd->{$key};
262 foreach my $rel_obj (@$others) {
263 if(!Scalar::Util::blessed($rel_obj)) {
264 $rel_obj = $self->create_related($key, $rel_obj);
267 $self->{_relationship_data}{$key} = $others;
268 # $related->{$key} = $others;
271 elsif ($self->has_column($key)
272 && exists $self->column_info($key)->{_inflate_info})
274 $self->set_inflated_column($key, delete $upd->{$key});
278 $self->set_columns($upd);
280 my %to_update = $self->get_dirty_columns;
281 return $self unless keys %to_update;
282 my $rows = $self->result_source->storage->update(
283 $self->result_source, \%to_update,
284 $self->{_orig_ident} || $ident_cond
287 $self->throw_exception( "Can't update ${self}: row not found" );
288 } elsif ($rows > 1) {
289 $self->throw_exception("Can't update ${self}: updated more than one row");
291 $self->{_dirty_columns} = {};
292 $self->{related_resultsets} = {};
293 undef $self->{_orig_ident};
301 Deletes the object from the database. The object is still perfectly
302 usable, but C<< ->in_storage() >> will now return 0 and the object must
303 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
304 on it. If you delete an object in a class with a C<has_many>
305 relationship, all the related objects will be deleted as well. To turn
306 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
307 hashref. Any database-level cascade or restrict will take precedence
308 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
315 $self->throw_exception( "Not in database" ) unless $self->in_storage;
316 my $ident_cond = $self->ident_condition;
317 $self->throw_exception("Cannot safely delete a row in a PK-less table")
318 if ! keys %$ident_cond;
319 foreach my $column (keys %$ident_cond) {
320 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
321 unless exists $self->{_column_data}{$column};
323 $self->result_source->storage->delete(
324 $self->result_source, $ident_cond);
325 $self->in_storage(undef);
327 $self->throw_exception("Can't do class delete without a ResultSource instance")
328 unless $self->can('result_source_instance');
329 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
330 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
331 $self->result_source_instance->resultset->search(@_)->delete;
338 my $val = $obj->get_column($col);
340 Gets a column value from a row object. Does not do any queries; the column
341 must have already been fetched from the database and stored in the object. If
342 there is an inflated value stored that has not yet been deflated, it is deflated
343 when the method is invoked.
348 my ($self, $column) = @_;
349 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
350 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
351 if (exists $self->{_inflated_column}{$column}) {
352 return $self->store_column($column,
353 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
355 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
359 =head2 has_column_loaded
361 if ( $obj->has_column_loaded($col) ) {
362 print "$col has been loaded from db";
365 Returns a true value if the column value has been loaded from the
366 database (or set locally).
370 sub has_column_loaded {
371 my ($self, $column) = @_;
372 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
373 return 1 if exists $self->{_inflated_column}{$column};
374 return exists $self->{_column_data}{$column};
379 my %data = $obj->get_columns;
381 Does C<get_column>, for all column values at once.
387 if (exists $self->{_inflated_column}) {
388 foreach my $col (keys %{$self->{_inflated_column}}) {
389 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
390 unless exists $self->{_column_data}{$col};
393 return %{$self->{_column_data}};
396 =head2 get_dirty_columns
398 my %data = $obj->get_dirty_columns;
400 Identical to get_columns but only returns those that have been changed.
404 sub get_dirty_columns {
406 return map { $_ => $self->{_column_data}{$_} }
407 keys %{$self->{_dirty_columns}};
410 =head2 get_inflated_columns
412 my $inflated_data = $obj->get_inflated_columns;
414 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
418 sub get_inflated_columns {
421 my $accessor = $self->column_info($_)->{'accessor'} || $_;
422 ($_ => $self->$accessor);
428 $obj->set_column($col => $val);
430 Sets a column value. If the new value is different from the old one,
431 the column is marked as dirty for when you next call $obj->update.
438 $self->{_orig_ident} ||= $self->ident_condition;
439 my $old = $self->get_column($column);
440 my $ret = $self->store_column(@_);
441 $self->{_dirty_columns}{$column} = 1
442 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
448 my $copy = $orig->set_columns({ $col => $val, ... });
450 Sets more than one column value at once.
455 my ($self,$data) = @_;
456 foreach my $col (keys %$data) {
457 $self->set_column($col,$data->{$col});
464 my $copy = $orig->copy({ change => $to, ... });
466 Inserts a new row with the specified changes.
471 my ($self, $changes) = @_;
473 my $col_data = { %{$self->{_column_data}} };
474 foreach my $col (keys %$col_data) {
475 delete $col_data->{$col}
476 if $self->result_source->column_info($col)->{is_auto_increment};
479 my $new = { _column_data => $col_data };
480 bless $new, ref $self;
482 $new->result_source($self->result_source);
483 $new->set_columns($changes);
485 foreach my $rel ($self->result_source->relationships) {
486 my $rel_info = $self->result_source->relationship_info($rel);
487 if ($rel_info->{attrs}{cascade_copy}) {
488 my $resolved = $self->result_source->resolve_condition(
489 $rel_info->{cond}, $rel, $new);
490 foreach my $related ($self->search_related($rel)) {
491 $related->copy($resolved);
500 $obj->store_column($col => $val);
502 Sets a column value without marking it as dirty.
507 my ($self, $column, $value) = @_;
508 $self->throw_exception( "No such column '${column}'" )
509 unless exists $self->{_column_data}{$column} || $self->has_column($column);
510 $self->throw_exception( "set_column called for ${column} without value" )
512 return $self->{_column_data}{$column} = $value;
515 =head2 inflate_result
517 Class->inflate_result($result_source, \%me, \%prefetch?)
519 Called by ResultSet to inflate a result from storage
524 my ($class, $source, $me, $prefetch) = @_;
526 my ($source_handle) = $source;
528 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
529 $source = $source_handle->resolve
531 $source_handle = $source->handle
535 _source_handle => $source_handle,
539 bless $new, (ref $class || $class);
542 foreach my $pre (keys %{$prefetch||{}}) {
543 my $pre_val = $prefetch->{$pre};
544 my $pre_source = $source->related_source($pre);
545 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
547 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
549 foreach my $pre_rec (@$pre_val) {
550 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
551 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
554 push(@pre_objects, $pre_source->result_class->inflate_result(
555 $pre_source, @{$pre_rec}));
557 $new->related_resultset($pre)->set_cache(\@pre_objects);
558 } elsif (defined $pre_val->[0]) {
560 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
561 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
563 $fetched = $pre_source->result_class->inflate_result(
564 $pre_source, @{$pre_val});
566 $new->related_resultset($pre)->set_cache([ $fetched ]);
567 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
568 $class->throw_exception("No accessor for prefetched $pre")
569 unless defined $accessor;
570 if ($accessor eq 'single') {
571 $new->{_relationship_data}{$pre} = $fetched;
572 } elsif ($accessor eq 'filter') {
573 $new->{_inflated_column}{$pre} = $fetched;
575 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
582 =head2 update_or_insert
584 $obj->update_or_insert
586 Updates the object if it's already in the db, else inserts it.
588 =head2 insert_or_update
590 $obj->insert_or_update
592 Alias for L</update_or_insert>
596 *insert_or_update = \&update_or_insert;
597 sub update_or_insert {
599 return ($self->in_storage ? $self->update : $self->insert);
604 my @changed_col_names = $obj->is_changed();
605 if ($obj->is_changed()) { ... }
607 In array context returns a list of columns with uncommited changes, or
608 in scalar context returns a true value if there are uncommitted
614 return keys %{shift->{_dirty_columns} || {}};
617 =head2 is_column_changed
619 if ($obj->is_column_changed('col')) { ... }
621 Returns a true value if the column has uncommitted changes.
625 sub is_column_changed {
626 my( $self, $col ) = @_;
627 return exists $self->{_dirty_columns}->{$col};
632 my $resultsource = $object->result_source;
634 Accessor to the ResultSource this object was created from
642 $self->_source_handle($_[0]->handle);
644 $self->_source_handle->resolve;
648 =head2 register_column
650 $column_info = { .... };
651 $class->register_column($column_name, $column_info);
653 Registers a column on the class. If the column_info has an 'accessor'
654 key, creates an accessor named after the value if defined; if there is
655 no such key, creates an accessor with the same name as the column
657 The column_info attributes are described in
658 L<DBIx::Class::ResultSource/add_columns>
662 sub register_column {
663 my ($class, $col, $info) = @_;
665 if (exists $info->{accessor}) {
666 return unless defined $info->{accessor};
667 $acc = [ $info->{accessor}, $col ];
669 $class->mk_group_accessors('column' => $acc);
673 =head2 throw_exception
675 See Schema's throw_exception.
679 sub throw_exception {
681 if (ref $self && ref $self->result_source && $self->result_source->schema) {
682 $self->result_source->schema->throw_exception(@_);
692 Matt S. Trout <mst@shadowcatsystems.co.uk>
696 You may distribute this code under the same terms as Perl itself.