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, $source) = @_;
48 $class = ref $class if ref $class;
50 my $new = { _column_data => {} };
53 $new->_source_handle($source) if $source;
56 $new->throw_exception("attrs must be a hashref")
57 unless ref($attrs) eq 'HASH';
59 my ($related,$inflated);
60 foreach my $key (keys %$attrs) {
61 if (ref $attrs->{$key}) {
62 ## Can we extract this lot to use with update(_or .. ) ?
63 my $info = $class->relationship_info($key);
64 if ($info && $info->{attrs}{accessor}
65 && $info->{attrs}{accessor} eq 'single')
67 my $rel_obj = $attrs->{$key};
68 $new->{_rel_in_storage} = 1;
69 if(!Scalar::Util::blessed($rel_obj)) {
70 $rel_obj = $new->new_related($key, $rel_obj);
71 $new->{_rel_in_storage} = 0;
73 $new->set_from_related($key, $attrs->{$key});
74 $related->{$key} = $attrs->{$key};
76 } elsif ($info && $info->{attrs}{accessor}
77 && $info->{attrs}{accessor} eq 'multi'
78 && ref $attrs->{$key} eq 'ARRAY') {
79 my $others = delete $attrs->{$key};
80 $new->{_rel_in_storage} = 1;
81 foreach my $rel_obj (@$others) {
82 if(!Scalar::Util::blessed($rel_obj)) {
83 $rel_obj = $new->new_related($key, $rel_obj);
84 $new->{_rel_in_storage} = 0;
87 $related->{$key} = $others;
89 } elsif ($class->has_column($key)
90 && exists $class->column_info($key)->{_inflate_info})
92 ## 'filter' should disappear and get merged in with 'single' above!
93 my $rel_obj = $attrs->{$key};
94 $new->{_rel_in_storage} = 1;
95 if(!Scalar::Util::blessed($rel_obj)) {
96 $rel_obj = $new->new_related($key, $rel_obj);
97 $new->{_rel_in_storage} = 0;
99 $inflated->{$key} = $rel_obj;
103 $new->throw_exception("No such column $key on $class")
104 unless $class->has_column($key);
105 $new->store_column($key => $attrs->{$key});
107 if (my $source = delete $attrs->{-result_source}) {
108 $new->result_source($source);
111 $new->{_relationship_data} = $related if $related;
112 $new->{_inflated_column} = $inflated if $inflated;
122 Inserts an object into the database if it isn't already in
123 there. Returns the object itself. Requires the object's result source to
124 be set, or the class to have a result_source_instance method. To insert
125 an entirely new object into the database, use C<create> (see
126 L<DBIx::Class::ResultSet/create>).
132 return $self if $self->in_storage;
133 my $source = $self->result_source;
134 $source ||= $self->result_source($self->result_source_instance)
135 if $self->can('result_source_instance');
136 $self->throw_exception("No result_source set on this object; can't insert")
139 # Check if we stored uninserted relobjs here in new()
140 $source->storage->txn_begin if(!$self->{_rel_in_storage});
142 my %related_stuff = (%{$self->{_relationship_data} || {}},
143 %{$self->{_inflated_column} || {}});
144 ## Should all be in relationship_data, but we need to get rid of the
145 ## 'filter' reltype..
146 ## These are the FK rels, need their IDs for the insert.
147 foreach my $relname (keys %related_stuff) {
148 my $relobj = $related_stuff{$relname};
149 if(ref $relobj ne 'ARRAY') {
150 $relobj->insert() if(!$relobj->in_storage);
151 $self->set_from_related($relname, $relobj);
155 $source->storage->insert($source, { $self->get_columns });
158 my ($pri, $too_many) = grep { !defined $self->get_column($_) ||
159 ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
161 $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
162 if defined $too_many;
164 my $storage = $self->result_source->storage;
165 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
166 unless $storage->can('last_insert_id');
167 my $id = $storage->last_insert_id($self->result_source,$pri);
168 $self->throw_exception( "Can't get last insert id" ) unless $id;
169 $self->store_column($pri => $id);
172 ## Now do the has_many rels, that need $selfs ID.
173 foreach my $relname (keys %related_stuff) {
174 my $relobj = $related_stuff{$relname};
175 if(ref $relobj eq 'ARRAY') {
176 foreach my $obj (@$relobj) {
177 my $info = $self->relationship_info($relname);
178 ## What about multi-col FKs ?
179 my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
180 $obj->set_from_related($key, $self);
181 $obj->insert() if(!$obj->in_storage);
185 $source->storage->txn_commit if(!$self->{_rel_in_storage});
187 $self->in_storage(1);
188 $self->{_dirty_columns} = {};
189 $self->{related_resultsets} = {};
190 undef $self->{_orig_ident};
196 $obj->in_storage; # Get value
197 $obj->in_storage(1); # Set value
199 Indicated whether the object exists as a row in the database or not
204 my ($self, $val) = @_;
205 $self->{_in_storage} = $val if @_ > 1;
206 return $self->{_in_storage};
211 $obj->update \%columns?;
213 Must be run on an object that is already in the database; issues an SQL
214 UPDATE query to commit any changes to the object to the database if
217 Also takes an options hashref of C<< column_name => value> pairs >> to update
218 first. But be aware that this hashref might be edited in place, so dont rely on
219 it being the same after a call to C<update>.
224 my ($self, $upd) = @_;
225 $self->throw_exception( "Not in database" ) unless $self->in_storage;
226 my $ident_cond = $self->ident_condition;
227 $self->throw_exception("Cannot safely update a row in a PK-less table")
228 if ! keys %$ident_cond;
231 foreach my $key (keys %$upd) {
232 if (ref $upd->{$key}) {
233 my $info = $self->relationship_info($key);
234 if ($info && $info->{attrs}{accessor}
235 && $info->{attrs}{accessor} eq 'single')
237 my $rel = delete $upd->{$key};
238 $self->set_from_related($key => $rel);
239 $self->{_relationship_data}{$key} = $rel;
240 } elsif ($info && $info->{attrs}{accessor}
241 && $info->{attrs}{accessor} eq 'multi'
242 && ref $upd->{$key} eq 'ARRAY') {
243 my $others = delete $upd->{$key};
244 foreach my $rel_obj (@$others) {
245 if(!Scalar::Util::blessed($rel_obj)) {
246 $rel_obj = $self->create_related($key, $rel_obj);
249 $self->{_relationship_data}{$key} = $others;
250 # $related->{$key} = $others;
253 elsif ($self->has_column($key)
254 && exists $self->column_info($key)->{_inflate_info})
256 $self->set_inflated_column($key, delete $upd->{$key});
260 $self->set_columns($upd);
262 my %to_update = $self->get_dirty_columns;
263 return $self unless keys %to_update;
264 my $rows = $self->result_source->storage->update(
265 $self->result_source, \%to_update,
266 $self->{_orig_ident} || $ident_cond
269 $self->throw_exception( "Can't update ${self}: row not found" );
270 } elsif ($rows > 1) {
271 $self->throw_exception("Can't update ${self}: updated more than one row");
273 $self->{_dirty_columns} = {};
274 $self->{related_resultsets} = {};
275 undef $self->{_orig_ident};
283 Deletes the object from the database. The object is still perfectly
284 usable, but C<< ->in_storage() >> will now return 0 and the object must
285 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
286 on it. If you delete an object in a class with a C<has_many>
287 relationship, all the related objects will be deleted as well. To turn
288 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
289 hashref. Any database-level cascade or restrict will take precedence
290 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
297 $self->throw_exception( "Not in database" ) unless $self->in_storage;
298 my $ident_cond = $self->ident_condition;
299 $self->throw_exception("Cannot safely delete a row in a PK-less table")
300 if ! keys %$ident_cond;
301 foreach my $column (keys %$ident_cond) {
302 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
303 unless exists $self->{_column_data}{$column};
305 $self->result_source->storage->delete(
306 $self->result_source, $ident_cond);
307 $self->in_storage(undef);
309 $self->throw_exception("Can't do class delete without a ResultSource instance")
310 unless $self->can('result_source_instance');
311 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
312 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
313 $self->result_source_instance->resultset->search(@_)->delete;
320 my $val = $obj->get_column($col);
322 Gets a column value from a row object. Does not do any queries; the column
323 must have already been fetched from the database and stored in the object. If
324 there is an inflated value stored that has not yet been deflated, it is deflated
325 when the method is invoked.
330 my ($self, $column) = @_;
331 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
332 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
333 if (exists $self->{_inflated_column}{$column}) {
334 return $self->store_column($column,
335 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
337 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
341 =head2 has_column_loaded
343 if ( $obj->has_column_loaded($col) ) {
344 print "$col has been loaded from db";
347 Returns a true value if the column value has been loaded from the
348 database (or set locally).
352 sub has_column_loaded {
353 my ($self, $column) = @_;
354 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
355 return 1 if exists $self->{_inflated_column}{$column};
356 return exists $self->{_column_data}{$column};
361 my %data = $obj->get_columns;
363 Does C<get_column>, for all column values at once.
369 if (exists $self->{_inflated_column}) {
370 foreach my $col (keys %{$self->{_inflated_column}}) {
371 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
372 unless exists $self->{_column_data}{$col};
375 return %{$self->{_column_data}};
378 =head2 get_dirty_columns
380 my %data = $obj->get_dirty_columns;
382 Identical to get_columns but only returns those that have been changed.
386 sub get_dirty_columns {
388 return map { $_ => $self->{_column_data}{$_} }
389 keys %{$self->{_dirty_columns}};
394 $obj->set_column($col => $val);
396 Sets a column value. If the new value is different from the old one,
397 the column is marked as dirty for when you next call $obj->update.
404 $self->{_orig_ident} ||= $self->ident_condition;
405 my $old = $self->get_column($column);
406 my $ret = $self->store_column(@_);
407 $self->{_dirty_columns}{$column} = 1
408 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
414 my $copy = $orig->set_columns({ $col => $val, ... });
416 Sets more than one column value at once.
421 my ($self,$data) = @_;
422 foreach my $col (keys %$data) {
423 $self->set_column($col,$data->{$col});
430 my $copy = $orig->copy({ change => $to, ... });
432 Inserts a new row with the specified changes.
437 my ($self, $changes) = @_;
439 my $col_data = { %{$self->{_column_data}} };
440 foreach my $col (keys %$col_data) {
441 delete $col_data->{$col}
442 if $self->result_source->column_info($col)->{is_auto_increment};
445 my $new = { _column_data => $col_data };
446 bless $new, ref $self;
448 $new->result_source($self->result_source);
449 $new->set_columns($changes);
451 foreach my $rel ($self->result_source->relationships) {
452 my $rel_info = $self->result_source->relationship_info($rel);
453 if ($rel_info->{attrs}{cascade_copy}) {
454 my $resolved = $self->result_source->resolve_condition(
455 $rel_info->{cond}, $rel, $new);
456 foreach my $related ($self->search_related($rel)) {
457 $related->copy($resolved);
466 $obj->store_column($col => $val);
468 Sets a column value without marking it as dirty.
473 my ($self, $column, $value) = @_;
474 $self->throw_exception( "No such column '${column}'" )
475 unless exists $self->{_column_data}{$column} || $self->has_column($column);
476 $self->throw_exception( "set_column called for ${column} without value" )
478 return $self->{_column_data}{$column} = $value;
481 =head2 inflate_result
483 Class->inflate_result($result_source, \%me, \%prefetch?)
485 Called by ResultSet to inflate a result from storage
490 my ($class, $source, $me, $prefetch) = @_;
492 my ($source_handle) = $source;
494 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
495 $source = $source_handle->resolve
497 $source_handle = $source->handle
501 _source_handle => $source_handle,
505 bless $new, (ref $class || $class);
508 foreach my $pre (keys %{$prefetch||{}}) {
509 my $pre_val = $prefetch->{$pre};
510 my $pre_source = $source->related_source($pre);
511 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
513 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
515 foreach my $pre_rec (@$pre_val) {
516 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
517 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
520 push(@pre_objects, $pre_source->result_class->inflate_result(
521 $pre_source, @{$pre_rec}));
523 $new->related_resultset($pre)->set_cache(\@pre_objects);
524 } elsif (defined $pre_val->[0]) {
526 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
527 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
529 $fetched = $pre_source->result_class->inflate_result(
530 $pre_source, @{$pre_val});
532 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
533 $class->throw_exception("No accessor for prefetched $pre")
534 unless defined $accessor;
535 if ($accessor eq 'single') {
536 $new->{_relationship_data}{$pre} = $fetched;
537 } elsif ($accessor eq 'filter') {
538 $new->{_inflated_column}{$pre} = $fetched;
540 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
547 =head2 update_or_insert
549 $obj->update_or_insert
551 Updates the object if it's already in the db, else inserts it.
553 =head2 insert_or_update
555 $obj->insert_or_update
557 Alias for L</update_or_insert>
561 *insert_or_update = \&update_or_insert;
562 sub update_or_insert {
564 return ($self->in_storage ? $self->update : $self->insert);
569 my @changed_col_names = $obj->is_changed();
570 if ($obj->is_changed()) { ... }
572 In array context returns a list of columns with uncommited changes, or
573 in scalar context returns a true value if there are uncommitted
579 return keys %{shift->{_dirty_columns} || {}};
582 =head2 is_column_changed
584 if ($obj->is_column_changed('col')) { ... }
586 Returns a true value if the column has uncommitted changes.
590 sub is_column_changed {
591 my( $self, $col ) = @_;
592 return exists $self->{_dirty_columns}->{$col};
597 my $resultsource = $object->result_source;
599 Accessor to the ResultSource this object was created from
607 $self->_source_handle($_[0]->handle);
609 $self->_source_handle->resolve;
613 =head2 register_column
615 $column_info = { .... };
616 $class->register_column($column_name, $column_info);
618 Registers a column on the class. If the column_info has an 'accessor'
619 key, creates an accessor named after the value if defined; if there is
620 no such key, creates an accessor with the same name as the column
622 The column_info attributes are described in
623 L<DBIx::Class::ResultSource/add_columns>
627 sub register_column {
628 my ($class, $col, $info) = @_;
630 if (exists $info->{accessor}) {
631 return unless defined $info->{accessor};
632 $acc = [ $info->{accessor}, $col ];
634 $class->mk_group_accessors('column' => $acc);
638 =head2 throw_exception
640 See Schema's throw_exception.
644 sub throw_exception {
646 if (ref $self && ref $self->result_source) {
647 $self->result_source->schema->throw_exception(@_);
657 Matt S. Trout <mst@shadowcatsystems.co.uk>
661 You may distribute this code under the same terms as Perl itself.