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};
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
220 my ($self, $upd) = @_;
221 $self->throw_exception( "Not in database" ) unless $self->in_storage;
222 my $ident_cond = $self->ident_condition;
223 $self->throw_exception("Cannot safely update a row in a PK-less table")
224 if ! keys %$ident_cond;
227 foreach my $key (keys %$upd) {
228 if (ref $upd->{$key}) {
229 my $info = $self->relationship_info($key);
230 if ($info && $info->{attrs}{accessor}
231 && $info->{attrs}{accessor} eq 'single')
233 my $rel = delete $upd->{$key};
234 $self->set_from_related($key => $rel);
235 $self->{_relationship_data}{$key} = $rel;
236 } elsif ($info && $info->{attrs}{accessor}
237 && $info->{attrs}{accessor} eq 'multi'
238 && ref $upd->{$key} eq 'ARRAY') {
239 my $others = delete $upd->{$key};
240 foreach my $rel_obj (@$others) {
241 if(!Scalar::Util::blessed($rel_obj)) {
242 $rel_obj = $self->create_related($key, $rel_obj);
245 $self->{_relationship_data}{$key} = $others;
246 # $related->{$key} = $others;
249 elsif ($self->has_column($key)
250 && exists $self->column_info($key)->{_inflate_info})
252 $self->set_inflated_column($key, delete $upd->{$key});
256 $self->set_columns($upd);
258 my %to_update = $self->get_dirty_columns;
259 return $self unless keys %to_update;
260 my $rows = $self->result_source->storage->update(
261 $self->result_source, \%to_update,
262 $self->{_orig_ident} || $ident_cond
265 $self->throw_exception( "Can't update ${self}: row not found" );
266 } elsif ($rows > 1) {
267 $self->throw_exception("Can't update ${self}: updated more than one row");
269 $self->{_dirty_columns} = {};
270 $self->{related_resultsets} = {};
271 undef $self->{_orig_ident};
279 Deletes the object from the database. The object is still perfectly
280 usable, but C<< ->in_storage() >> will now return 0 and the object must
281 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
282 on it. If you delete an object in a class with a C<has_many>
283 relationship, all the related objects will be deleted as well. To turn
284 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
285 hashref. Any database-level cascade or restrict will take precedence
286 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
293 $self->throw_exception( "Not in database" ) unless $self->in_storage;
294 my $ident_cond = $self->ident_condition;
295 $self->throw_exception("Cannot safely delete a row in a PK-less table")
296 if ! keys %$ident_cond;
297 foreach my $column (keys %$ident_cond) {
298 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
299 unless exists $self->{_column_data}{$column};
301 $self->result_source->storage->delete(
302 $self->result_source, $ident_cond);
303 $self->in_storage(undef);
305 $self->throw_exception("Can't do class delete without a ResultSource instance")
306 unless $self->can('result_source_instance');
307 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
308 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
309 $self->result_source_instance->resultset->search(@_)->delete;
316 my $val = $obj->get_column($col);
318 Gets a column value from a row object. Does not do any queries; the column
319 must have already been fetched from the database and stored in the object. If
320 there is an inflated value stored that has not yet been deflated, it is deflated
321 when the method is invoked.
326 my ($self, $column) = @_;
327 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
328 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
329 if (exists $self->{_inflated_column}{$column}) {
330 return $self->store_column($column,
331 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
333 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
337 =head2 has_column_loaded
339 if ( $obj->has_column_loaded($col) ) {
340 print "$col has been loaded from db";
343 Returns a true value if the column value has been loaded from the
344 database (or set locally).
348 sub has_column_loaded {
349 my ($self, $column) = @_;
350 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
351 return 1 if exists $self->{_inflated_column}{$column};
352 return exists $self->{_column_data}{$column};
357 my %data = $obj->get_columns;
359 Does C<get_column>, for all column values at once.
365 if (exists $self->{_inflated_column}) {
366 foreach my $col (keys %{$self->{_inflated_column}}) {
367 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
368 unless exists $self->{_column_data}{$col};
371 return %{$self->{_column_data}};
374 =head2 get_dirty_columns
376 my %data = $obj->get_dirty_columns;
378 Identical to get_columns but only returns those that have been changed.
382 sub get_dirty_columns {
384 return map { $_ => $self->{_column_data}{$_} }
385 keys %{$self->{_dirty_columns}};
390 $obj->set_column($col => $val);
392 Sets a column value. If the new value is different from the old one,
393 the column is marked as dirty for when you next call $obj->update.
400 $self->{_orig_ident} ||= $self->ident_condition;
401 my $old = $self->get_column($column);
402 my $ret = $self->store_column(@_);
403 $self->{_dirty_columns}{$column} = 1
404 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
410 my $copy = $orig->set_columns({ $col => $val, ... });
412 Sets more than one column value at once.
417 my ($self,$data) = @_;
418 foreach my $col (keys %$data) {
419 $self->set_column($col,$data->{$col});
426 my $copy = $orig->copy({ change => $to, ... });
428 Inserts a new row with the specified changes.
433 my ($self, $changes) = @_;
435 my $col_data = { %{$self->{_column_data}} };
436 foreach my $col (keys %$col_data) {
437 delete $col_data->{$col}
438 if $self->result_source->column_info($col)->{is_auto_increment};
441 my $new = { _column_data => $col_data };
442 bless $new, ref $self;
444 $new->result_source($self->result_source);
445 $new->set_columns($changes);
447 foreach my $rel ($self->result_source->relationships) {
448 my $rel_info = $self->result_source->relationship_info($rel);
449 if ($rel_info->{attrs}{cascade_copy}) {
450 my $resolved = $self->result_source->resolve_condition(
451 $rel_info->{cond}, $rel, $new);
452 foreach my $related ($self->search_related($rel)) {
453 $related->copy($resolved);
462 $obj->store_column($col => $val);
464 Sets a column value without marking it as dirty.
469 my ($self, $column, $value) = @_;
470 $self->throw_exception( "No such column '${column}'" )
471 unless exists $self->{_column_data}{$column} || $self->has_column($column);
472 $self->throw_exception( "set_column called for ${column} without value" )
474 return $self->{_column_data}{$column} = $value;
477 =head2 inflate_result
479 Class->inflate_result($result_source, \%me, \%prefetch?)
481 Called by ResultSet to inflate a result from storage
486 my ($class, $source, $me, $prefetch) = @_;
488 my ($source_handle) = $source;
490 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
491 $source = $source_handle->resolve
493 $source_handle = $source->handle
497 _source_handle => $source_handle,
501 bless $new, (ref $class || $class);
504 foreach my $pre (keys %{$prefetch||{}}) {
505 my $pre_val = $prefetch->{$pre};
506 my $pre_source = $source->related_source($pre);
507 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
509 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
511 foreach my $pre_rec (@$pre_val) {
512 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
513 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
516 push(@pre_objects, $pre_source->result_class->inflate_result(
517 $pre_source, @{$pre_rec}));
519 $new->related_resultset($pre)->set_cache(\@pre_objects);
520 } elsif (defined $pre_val->[0]) {
522 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
523 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
525 $fetched = $pre_source->result_class->inflate_result(
526 $pre_source, @{$pre_val});
528 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
529 $class->throw_exception("No accessor for prefetched $pre")
530 unless defined $accessor;
531 if ($accessor eq 'single') {
532 $new->{_relationship_data}{$pre} = $fetched;
533 } elsif ($accessor eq 'filter') {
534 $new->{_inflated_column}{$pre} = $fetched;
536 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
543 =head2 update_or_insert
545 $obj->update_or_insert
547 Updates the object if it's already in the db, else inserts it.
549 =head2 insert_or_update
551 $obj->insert_or_update
553 Alias for L</update_or_insert>
557 *insert_or_update = \&update_or_insert;
558 sub update_or_insert {
560 return ($self->in_storage ? $self->update : $self->insert);
565 my @changed_col_names = $obj->is_changed();
566 if ($obj->is_changed()) { ... }
568 In array context returns a list of columns with uncommited changes, or
569 in scalar context returns a true value if there are uncommitted
575 return keys %{shift->{_dirty_columns} || {}};
578 =head2 is_column_changed
580 if ($obj->is_column_changed('col')) { ... }
582 Returns a true value if the column has uncommitted changes.
586 sub is_column_changed {
587 my( $self, $col ) = @_;
588 return exists $self->{_dirty_columns}->{$col};
593 my $resultsource = $object->result_source;
595 Accessor to the ResultSource this object was created from
603 $self->_source_handle($_[0]->handle);
605 $self->_source_handle->resolve;
609 =head2 register_column
611 $column_info = { .... };
612 $class->register_column($column_name, $column_info);
614 Registers a column on the class. If the column_info has an 'accessor'
615 key, creates an accessor named after the value if defined; if there is
616 no such key, creates an accessor with the same name as the column
618 The column_info attributes are described in
619 L<DBIx::Class::ResultSource/add_columns>
623 sub register_column {
624 my ($class, $col, $info) = @_;
626 if (exists $info->{accessor}) {
627 return unless defined $info->{accessor};
628 $acc = [ $info->{accessor}, $col ];
630 $class->mk_group_accessors('column' => $acc);
634 =head2 throw_exception
636 See Schema's throw_exception.
640 sub throw_exception {
642 if (ref $self && ref $self->result_source) {
643 $self->result_source->schema->throw_exception(@_);
653 Matt S. Trout <mst@shadowcatsystems.co.uk>
657 You may distribute this code under the same terms as Perl itself.