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 ## NB (JER) - this assumes set_from_related can cope with multi-rels
40 ## 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().
41 ## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
42 ## When doing the later insert, we need to make sure the PKs are set.
43 ## using _relationship_data in new and funky ways..
44 ## check Relationship::CascadeActions and Relationship::Accessor for compat
48 my ($class, $attrs, $source) = @_;
49 $class = ref $class if ref $class;
51 my $new = { _column_data => {} };
54 $new->_source_handle($source) if $source;
57 $new->throw_exception("attrs must be a hashref")
58 unless ref($attrs) eq 'HASH';
60 my ($related,$inflated);
61 foreach my $key (keys %$attrs) {
62 if (ref $attrs->{$key}) {
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 = $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 $new->set_from_related($key, $others);
88 $related->{$key} = $attrs->{$key};
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")
138 #use Data::Dumper; warn Dumper($self);
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 foreach my $relname (keys %related_stuff) {
147 my $relobj = $related_stuff{$relname};
148 if(ref $relobj ne 'ARRAY') {
149 $relobj->insert() if(!$relobj->in_storage);
150 $self->set_from_related($relname, $relobj);
154 $source->storage->insert($source->from, { $self->get_columns });
156 foreach my $relname (keys %related_stuff) {
157 my $relobj = $related_stuff{$relname};
158 if(ref $relobj eq 'ARRAY') {
159 foreach my $obj (@$relobj) {
160 my $info = $self->relationship_info($relname);
161 ## What about multi-col FKs ?
162 my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
163 $obj->set_from_related($key, $self);
164 $obj->insert() if(!$obj->in_storage);
168 $source->storage->txn_commit if(!$self->{_rel_in_storage});
170 $self->in_storage(1);
171 $self->{_dirty_columns} = {};
172 $self->{related_resultsets} = {};
173 undef $self->{_orig_ident};
179 $obj->in_storage; # Get value
180 $obj->in_storage(1); # Set value
182 Indicated whether the object exists as a row in the database or not
187 my ($self, $val) = @_;
188 $self->{_in_storage} = $val if @_ > 1;
189 return $self->{_in_storage};
196 Must be run on an object that is already in the database; issues an SQL
197 UPDATE query to commit any changes to the object to the database if
203 my ($self, $upd) = @_;
204 $self->throw_exception( "Not in database" ) unless $self->in_storage;
205 my $ident_cond = $self->ident_condition;
206 $self->throw_exception("Cannot safely update a row in a PK-less table")
207 if ! keys %$ident_cond;
209 foreach my $key (keys %$upd) {
210 if (ref $upd->{$key}) {
211 my $info = $self->relationship_info($key);
212 if ($info && $info->{attrs}{accessor}
213 && $info->{attrs}{accessor} eq 'single')
215 my $rel = delete $upd->{$key};
216 $self->set_from_related($key => $rel);
217 $self->{_relationship_data}{$key} = $rel;
219 elsif ($self->has_column($key)
220 && exists $self->column_info($key)->{_inflate_info})
222 $self->set_inflated_column($key, delete $upd->{$key});
226 $self->set_columns($upd);
228 my %to_update = $self->get_dirty_columns;
229 return $self unless keys %to_update;
230 my $rows = $self->result_source->storage->update(
231 $self->result_source->from, \%to_update, $self->{_orig_ident} || $ident_cond);
233 $self->throw_exception( "Can't update ${self}: row not found" );
234 } elsif ($rows > 1) {
235 $self->throw_exception("Can't update ${self}: updated more than one row");
237 $self->{_dirty_columns} = {};
238 $self->{related_resultsets} = {};
239 undef $self->{_orig_ident};
247 Deletes the object from the database. The object is still perfectly
248 usable, but C<< ->in_storage() >> will now return 0 and the object must
249 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
250 on it. If you delete an object in a class with a C<has_many>
251 relationship, all the related objects will be deleted as well. To turn
252 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
253 hashref. Any database-level cascade or restrict will take precedence
254 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
261 $self->throw_exception( "Not in database" ) unless $self->in_storage;
262 my $ident_cond = $self->ident_condition;
263 $self->throw_exception("Cannot safely delete a row in a PK-less table")
264 if ! keys %$ident_cond;
265 foreach my $column (keys %$ident_cond) {
266 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
267 unless exists $self->{_column_data}{$column};
269 $self->result_source->storage->delete(
270 $self->result_source->from, $ident_cond);
271 $self->in_storage(undef);
273 $self->throw_exception("Can't do class delete without a ResultSource instance")
274 unless $self->can('result_source_instance');
275 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
276 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
277 $self->result_source_instance->resultset->search(@_)->delete;
284 my $val = $obj->get_column($col);
286 Gets a column value from a row object. Does not do any queries; the column
287 must have already been fetched from the database and stored in the object. If
288 there is an inflated value stored that has not yet been deflated, it is deflated
289 when the method is invoked.
294 my ($self, $column) = @_;
295 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
296 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
297 if (exists $self->{_inflated_column}{$column}) {
298 return $self->store_column($column,
299 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
301 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
305 =head2 has_column_loaded
307 if ( $obj->has_column_loaded($col) ) {
308 print "$col has been loaded from db";
311 Returns a true value if the column value has been loaded from the
312 database (or set locally).
316 sub has_column_loaded {
317 my ($self, $column) = @_;
318 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
319 return 1 if exists $self->{_inflated_column}{$column};
320 return exists $self->{_column_data}{$column};
325 my %data = $obj->get_columns;
327 Does C<get_column>, for all column values at once.
333 if (exists $self->{_inflated_column}) {
334 foreach my $col (keys %{$self->{_inflated_column}}) {
335 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
336 unless exists $self->{_column_data}{$col};
339 return %{$self->{_column_data}};
342 =head2 get_dirty_columns
344 my %data = $obj->get_dirty_columns;
346 Identical to get_columns but only returns those that have been changed.
350 sub get_dirty_columns {
352 return map { $_ => $self->{_column_data}{$_} }
353 keys %{$self->{_dirty_columns}};
358 $obj->set_column($col => $val);
360 Sets a column value. If the new value is different from the old one,
361 the column is marked as dirty for when you next call $obj->update.
368 $self->{_orig_ident} ||= $self->ident_condition;
369 my $old = $self->get_column($column);
370 my $ret = $self->store_column(@_);
371 $self->{_dirty_columns}{$column} = 1
372 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
378 my $copy = $orig->set_columns({ $col => $val, ... });
380 Sets more than one column value at once.
385 my ($self,$data) = @_;
386 foreach my $col (keys %$data) {
387 $self->set_column($col,$data->{$col});
394 my $copy = $orig->copy({ change => $to, ... });
396 Inserts a new row with the specified changes.
401 my ($self, $changes) = @_;
403 my $col_data = { %{$self->{_column_data}} };
404 foreach my $col (keys %$col_data) {
405 delete $col_data->{$col}
406 if $self->result_source->column_info($col)->{is_auto_increment};
409 my $new = { _column_data => $col_data };
410 bless $new, ref $self;
412 $new->result_source($self->result_source);
413 $new->set_columns($changes);
415 foreach my $rel ($self->result_source->relationships) {
416 my $rel_info = $self->result_source->relationship_info($rel);
417 if ($rel_info->{attrs}{cascade_copy}) {
418 my $resolved = $self->result_source->resolve_condition(
419 $rel_info->{cond}, $rel, $new);
420 foreach my $related ($self->search_related($rel)) {
421 $related->copy($resolved);
430 $obj->store_column($col => $val);
432 Sets a column value without marking it as dirty.
437 my ($self, $column, $value) = @_;
438 $self->throw_exception( "No such column '${column}'" )
439 unless exists $self->{_column_data}{$column} || $self->has_column($column);
440 $self->throw_exception( "set_column called for ${column} without value" )
442 return $self->{_column_data}{$column} = $value;
445 =head2 inflate_result
447 Class->inflate_result($result_source, \%me, \%prefetch?)
449 Called by ResultSet to inflate a result from storage
454 my ($class, $source, $me, $prefetch) = @_;
456 my ($source_handle) = $source;
458 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
459 $source = $source_handle->resolve
461 $source_handle = $source->handle
465 _source_handle => $source_handle,
469 bless $new, (ref $class || $class);
472 foreach my $pre (keys %{$prefetch||{}}) {
473 my $pre_val = $prefetch->{$pre};
474 my $pre_source = $source->related_source($pre);
475 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
477 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
479 foreach my $pre_rec (@$pre_val) {
480 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
481 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
484 push(@pre_objects, $pre_source->result_class->inflate_result(
485 $pre_source, @{$pre_rec}));
487 $new->related_resultset($pre)->set_cache(\@pre_objects);
488 } elsif (defined $pre_val->[0]) {
490 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
491 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
493 $fetched = $pre_source->result_class->inflate_result(
494 $pre_source, @{$pre_val});
496 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
497 $class->throw_exception("No accessor for prefetched $pre")
498 unless defined $accessor;
499 if ($accessor eq 'single') {
500 $new->{_relationship_data}{$pre} = $fetched;
501 } elsif ($accessor eq 'filter') {
502 $new->{_inflated_column}{$pre} = $fetched;
504 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
511 =head2 update_or_insert
513 $obj->update_or_insert
515 Updates the object if it's already in the db, else inserts it.
517 =head2 insert_or_update
519 $obj->insert_or_update
521 Alias for L</update_or_insert>
525 *insert_or_update = \&update_or_insert;
526 sub update_or_insert {
528 return ($self->in_storage ? $self->update : $self->insert);
533 my @changed_col_names = $obj->is_changed();
534 if ($obj->is_changed()) { ... }
536 In array context returns a list of columns with uncommited changes, or
537 in scalar context returns a true value if there are uncommitted
543 return keys %{shift->{_dirty_columns} || {}};
546 =head2 is_column_changed
548 if ($obj->is_column_changed('col')) { ... }
550 Returns a true value if the column has uncommitted changes.
554 sub is_column_changed {
555 my( $self, $col ) = @_;
556 return exists $self->{_dirty_columns}->{$col};
561 my $resultsource = $object->result_source;
563 Accessor to the ResultSource this object was created from
571 $self->_source_handle($_[0]->handle);
573 $self->_source_handle->resolve;
577 =head2 register_column
579 $column_info = { .... };
580 $class->register_column($column_name, $column_info);
582 Registers a column on the class. If the column_info has an 'accessor'
583 key, creates an accessor named after the value if defined; if there is
584 no such key, creates an accessor with the same name as the column
586 The column_info attributes are described in
587 L<DBIx::Class::ResultSource/add_columns>
591 sub register_column {
592 my ($class, $col, $info) = @_;
594 if (exists $info->{accessor}) {
595 return unless defined $info->{accessor};
596 $acc = [ $info->{accessor}, $col ];
598 $class->mk_group_accessors('column' => $acc);
602 =head2 throw_exception
604 See Schema's throw_exception.
608 sub throw_exception {
610 if (ref $self && ref $self->result_source) {
611 $self->result_source->schema->throw_exception(@_);
621 Matt S. Trout <mst@shadowcatsystems.co.uk>
625 You may distribute this code under the same terms as Perl itself.