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 ($pri, $too_many) = grep { !defined $self->get_column($_) ||
169 ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
171 $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
172 if defined $too_many;
174 my $storage = $self->result_source->storage;
175 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
176 unless $storage->can('last_insert_id');
177 my $id = $storage->last_insert_id($self->result_source,$pri);
178 $self->throw_exception( "Can't get last insert id" ) unless $id;
179 $self->store_column($pri => $id);
182 if(!$self->{_rel_in_storage})
184 ## Now do the has_many rels, that need $selfs ID.
185 foreach my $relname (keys %related_stuff) {
186 my $relobj = $related_stuff{$relname};
187 if(ref $relobj eq 'ARRAY') {
188 foreach my $obj (@$relobj) {
189 my $info = $self->relationship_info($relname);
190 ## What about multi-col FKs ?
191 my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
192 $obj->set_from_related($key, $self);
193 $obj->insert() if(!$obj->in_storage);
197 $source->storage->txn_commit;
200 $self->in_storage(1);
201 $self->{_dirty_columns} = {};
202 $self->{related_resultsets} = {};
203 undef $self->{_orig_ident};
209 $obj->in_storage; # Get value
210 $obj->in_storage(1); # Set value
212 Indicated whether the object exists as a row in the database or not
217 my ($self, $val) = @_;
218 $self->{_in_storage} = $val if @_ > 1;
219 return $self->{_in_storage};
224 $obj->update \%columns?;
226 Must be run on an object that is already in the database; issues an SQL
227 UPDATE query to commit any changes to the object to the database if
230 Also takes an options hashref of C<< column_name => value> pairs >> to update
231 first. But be aware that this hashref might be edited in place, so dont rely on
232 it being the same after a call to C<update>.
237 my ($self, $upd) = @_;
238 $self->throw_exception( "Not in database" ) unless $self->in_storage;
239 my $ident_cond = $self->ident_condition;
240 $self->throw_exception("Cannot safely update a row in a PK-less table")
241 if ! keys %$ident_cond;
244 foreach my $key (keys %$upd) {
245 if (ref $upd->{$key}) {
246 my $info = $self->relationship_info($key);
247 if ($info && $info->{attrs}{accessor}
248 && $info->{attrs}{accessor} eq 'single')
250 my $rel = delete $upd->{$key};
251 $self->set_from_related($key => $rel);
252 $self->{_relationship_data}{$key} = $rel;
253 } elsif ($info && $info->{attrs}{accessor}
254 && $info->{attrs}{accessor} eq 'multi'
255 && ref $upd->{$key} eq 'ARRAY') {
256 my $others = delete $upd->{$key};
257 foreach my $rel_obj (@$others) {
258 if(!Scalar::Util::blessed($rel_obj)) {
259 $rel_obj = $self->create_related($key, $rel_obj);
262 $self->{_relationship_data}{$key} = $others;
263 # $related->{$key} = $others;
266 elsif ($self->has_column($key)
267 && exists $self->column_info($key)->{_inflate_info})
269 $self->set_inflated_column($key, delete $upd->{$key});
273 $self->set_columns($upd);
275 my %to_update = $self->get_dirty_columns;
276 return $self unless keys %to_update;
277 my $rows = $self->result_source->storage->update(
278 $self->result_source, \%to_update,
279 $self->{_orig_ident} || $ident_cond
282 $self->throw_exception( "Can't update ${self}: row not found" );
283 } elsif ($rows > 1) {
284 $self->throw_exception("Can't update ${self}: updated more than one row");
286 $self->{_dirty_columns} = {};
287 $self->{related_resultsets} = {};
288 undef $self->{_orig_ident};
296 Deletes the object from the database. The object is still perfectly
297 usable, but C<< ->in_storage() >> will now return 0 and the object must
298 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
299 on it. If you delete an object in a class with a C<has_many>
300 relationship, all the related objects will be deleted as well. To turn
301 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
302 hashref. Any database-level cascade or restrict will take precedence
303 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
310 $self->throw_exception( "Not in database" ) unless $self->in_storage;
311 my $ident_cond = $self->ident_condition;
312 $self->throw_exception("Cannot safely delete a row in a PK-less table")
313 if ! keys %$ident_cond;
314 foreach my $column (keys %$ident_cond) {
315 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
316 unless exists $self->{_column_data}{$column};
318 $self->result_source->storage->delete(
319 $self->result_source, $ident_cond);
320 $self->in_storage(undef);
322 $self->throw_exception("Can't do class delete without a ResultSource instance")
323 unless $self->can('result_source_instance');
324 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
325 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
326 $self->result_source_instance->resultset->search(@_)->delete;
333 my $val = $obj->get_column($col);
335 Gets a column value from a row object. Does not do any queries; the column
336 must have already been fetched from the database and stored in the object. If
337 there is an inflated value stored that has not yet been deflated, it is deflated
338 when the method is invoked.
343 my ($self, $column) = @_;
344 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
345 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
346 if (exists $self->{_inflated_column}{$column}) {
347 return $self->store_column($column,
348 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
350 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
354 =head2 has_column_loaded
356 if ( $obj->has_column_loaded($col) ) {
357 print "$col has been loaded from db";
360 Returns a true value if the column value has been loaded from the
361 database (or set locally).
365 sub has_column_loaded {
366 my ($self, $column) = @_;
367 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
368 return 1 if exists $self->{_inflated_column}{$column};
369 return exists $self->{_column_data}{$column};
374 my %data = $obj->get_columns;
376 Does C<get_column>, for all column values at once.
382 if (exists $self->{_inflated_column}) {
383 foreach my $col (keys %{$self->{_inflated_column}}) {
384 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
385 unless exists $self->{_column_data}{$col};
388 return %{$self->{_column_data}};
391 =head2 get_dirty_columns
393 my %data = $obj->get_dirty_columns;
395 Identical to get_columns but only returns those that have been changed.
399 sub get_dirty_columns {
401 return map { $_ => $self->{_column_data}{$_} }
402 keys %{$self->{_dirty_columns}};
405 =head2 get_inflated_columns
407 my $inflated_data = $obj->get_inflated_columns;
409 Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
413 sub get_inflated_columns {
416 my $accessor = $self->column_info($_)->{'accessor'} || $_;
417 ($_ => $self->$accessor);
423 $obj->set_column($col => $val);
425 Sets a column value. If the new value is different from the old one,
426 the column is marked as dirty for when you next call $obj->update.
433 $self->{_orig_ident} ||= $self->ident_condition;
434 my $old = $self->get_column($column);
435 my $ret = $self->store_column(@_);
436 $self->{_dirty_columns}{$column} = 1
437 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
443 my $copy = $orig->set_columns({ $col => $val, ... });
445 Sets more than one column value at once.
450 my ($self,$data) = @_;
451 foreach my $col (keys %$data) {
452 $self->set_column($col,$data->{$col});
459 my $copy = $orig->copy({ change => $to, ... });
461 Inserts a new row with the specified changes.
466 my ($self, $changes) = @_;
468 my $col_data = { %{$self->{_column_data}} };
469 foreach my $col (keys %$col_data) {
470 delete $col_data->{$col}
471 if $self->result_source->column_info($col)->{is_auto_increment};
474 my $new = { _column_data => $col_data };
475 bless $new, ref $self;
477 $new->result_source($self->result_source);
478 $new->set_columns($changes);
480 foreach my $rel ($self->result_source->relationships) {
481 my $rel_info = $self->result_source->relationship_info($rel);
482 if ($rel_info->{attrs}{cascade_copy}) {
483 my $resolved = $self->result_source->resolve_condition(
484 $rel_info->{cond}, $rel, $new);
485 foreach my $related ($self->search_related($rel)) {
486 $related->copy($resolved);
495 $obj->store_column($col => $val);
497 Sets a column value without marking it as dirty.
502 my ($self, $column, $value) = @_;
503 $self->throw_exception( "No such column '${column}'" )
504 unless exists $self->{_column_data}{$column} || $self->has_column($column);
505 $self->throw_exception( "set_column called for ${column} without value" )
507 return $self->{_column_data}{$column} = $value;
510 =head2 inflate_result
512 Class->inflate_result($result_source, \%me, \%prefetch?)
514 Called by ResultSet to inflate a result from storage
519 my ($class, $source, $me, $prefetch) = @_;
521 my ($source_handle) = $source;
523 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
524 $source = $source_handle->resolve
526 $source_handle = $source->handle
530 _source_handle => $source_handle,
534 bless $new, (ref $class || $class);
537 foreach my $pre (keys %{$prefetch||{}}) {
538 my $pre_val = $prefetch->{$pre};
539 my $pre_source = $source->related_source($pre);
540 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
542 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
544 foreach my $pre_rec (@$pre_val) {
545 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
546 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
549 push(@pre_objects, $pre_source->result_class->inflate_result(
550 $pre_source, @{$pre_rec}));
552 $new->related_resultset($pre)->set_cache(\@pre_objects);
553 } elsif (defined $pre_val->[0]) {
555 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
556 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
558 $fetched = $pre_source->result_class->inflate_result(
559 $pre_source, @{$pre_val});
561 $new->related_resultset($pre)->set_cache([ $fetched ]);
562 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
563 $class->throw_exception("No accessor for prefetched $pre")
564 unless defined $accessor;
565 if ($accessor eq 'single') {
566 $new->{_relationship_data}{$pre} = $fetched;
567 } elsif ($accessor eq 'filter') {
568 $new->{_inflated_column}{$pre} = $fetched;
570 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
577 =head2 update_or_insert
579 $obj->update_or_insert
581 Updates the object if it's already in the db, else inserts it.
583 =head2 insert_or_update
585 $obj->insert_or_update
587 Alias for L</update_or_insert>
591 *insert_or_update = \&update_or_insert;
592 sub update_or_insert {
594 return ($self->in_storage ? $self->update : $self->insert);
599 my @changed_col_names = $obj->is_changed();
600 if ($obj->is_changed()) { ... }
602 In array context returns a list of columns with uncommited changes, or
603 in scalar context returns a true value if there are uncommitted
609 return keys %{shift->{_dirty_columns} || {}};
612 =head2 is_column_changed
614 if ($obj->is_column_changed('col')) { ... }
616 Returns a true value if the column has uncommitted changes.
620 sub is_column_changed {
621 my( $self, $col ) = @_;
622 return exists $self->{_dirty_columns}->{$col};
627 my $resultsource = $object->result_source;
629 Accessor to the ResultSource this object was created from
637 $self->_source_handle($_[0]->handle);
639 $self->_source_handle->resolve;
643 =head2 register_column
645 $column_info = { .... };
646 $class->register_column($column_name, $column_info);
648 Registers a column on the class. If the column_info has an 'accessor'
649 key, creates an accessor named after the value if defined; if there is
650 no such key, creates an accessor with the same name as the column
652 The column_info attributes are described in
653 L<DBIx::Class::ResultSource/add_columns>
657 sub register_column {
658 my ($class, $col, $info) = @_;
660 if (exists $info->{accessor}) {
661 return unless defined $info->{accessor};
662 $acc = [ $info->{accessor}, $col ];
664 $class->mk_group_accessors('column' => $acc);
668 =head2 throw_exception
670 See Schema's throw_exception.
674 sub throw_exception {
676 if (ref $self && ref $self->result_source) {
677 $self->result_source->schema->throw_exception(@_);
687 Matt S. Trout <mst@shadowcatsystems.co.uk>
691 You may distribute this code under the same terms as Perl itself.