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;
67 print STDERR "Attrs: ", Dumper($attrs), "\n";
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 print STDERR "REL: $key ", ref($rel_obj), "\n";
77 if(!Scalar::Util::blessed($rel_obj)) {
78 $rel_obj = $new->new_related($key, $rel_obj);
79 print STDERR "REL: $key ", ref($rel_obj), "\n";
80 $new->{_rel_in_storage} = 0;
82 $new->set_from_related($key, $rel_obj);
83 $related->{$key} = $rel_obj;
85 } elsif ($info && $info->{attrs}{accessor}
86 && $info->{attrs}{accessor} eq 'multi'
87 && ref $attrs->{$key} eq 'ARRAY') {
88 my $others = delete $attrs->{$key};
89 foreach my $rel_obj (@$others) {
90 if(!Scalar::Util::blessed($rel_obj)) {
91 $rel_obj = $new->new_related($key, $rel_obj);
92 $new->{_rel_in_storage} = 0;
95 $related->{$key} = $others;
97 } elsif ($class->has_column($key)
98 && exists $class->column_info($key)->{_inflate_info})
100 ## 'filter' should disappear and get merged in with 'single' above!
101 my $rel_obj = $attrs->{$key};
102 if(!Scalar::Util::blessed($rel_obj)) {
103 $rel_obj = $new->new_related($key, $rel_obj);
104 $new->{_rel_in_storage} = 0;
106 $inflated->{$key} = $rel_obj;
111 print STDERR "Key: ", Dumper($key), "\n";
112 $new->throw_exception("No such column $key on $class")
113 unless $class->has_column($key);
114 $new->store_column($key => $attrs->{$key});
117 $new->{_relationship_data} = $related if $related;
118 $new->{_inflated_column} = $inflated if $inflated;
128 Inserts an object into the database if it isn't already in
129 there. Returns the object itself. Requires the object's result source to
130 be set, or the class to have a result_source_instance method. To insert
131 an entirely new object into the database, use C<create> (see
132 L<DBIx::Class::ResultSet/create>).
138 return $self if $self->in_storage;
139 my $source = $self->result_source;
140 $source ||= $self->result_source($self->result_source_instance)
141 if $self->can('result_source_instance');
142 $self->throw_exception("No result_source set on this object; can't insert")
145 # Check if we stored uninserted relobjs here in new()
146 $source->storage->txn_begin if(!$self->{_rel_in_storage});
148 my %related_stuff = (%{$self->{_relationship_data} || {}},
149 %{$self->{_inflated_column} || {}});
150 ## Should all be in relationship_data, but we need to get rid of the
151 ## 'filter' reltype..
152 ## These are the FK rels, need their IDs for the insert.
153 foreach my $relname (keys %related_stuff) {
154 my $relobj = $related_stuff{$relname};
155 if(ref $relobj ne 'ARRAY') {
156 $relobj->insert() if(!$relobj->in_storage);
157 print STDERR "Inserting: ", ref($relobj), "\n";
158 $self->set_from_related($relname, $relobj);
162 $source->storage->insert($source, { $self->get_columns });
165 my ($pri, $too_many) = grep { !defined $self->get_column($_) ||
166 ref($self->get_column($_)) eq 'SCALAR'} $self->primary_columns;
168 $self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
169 if defined $too_many;
171 my $storage = $self->result_source->storage;
172 $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" )
173 unless $storage->can('last_insert_id');
174 my $id = $storage->last_insert_id($self->result_source,$pri);
175 $self->throw_exception( "Can't get last insert id" ) unless $id;
176 $self->store_column($pri => $id);
179 ## Now do the has_many rels, that need $selfs ID.
180 foreach my $relname (keys %related_stuff) {
181 my $relobj = $related_stuff{$relname};
182 if(ref $relobj eq 'ARRAY') {
183 foreach my $obj (@$relobj) {
184 my $info = $self->relationship_info($relname);
185 ## What about multi-col FKs ?
186 my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
187 print STDERR "Inserting: ", ref($obj), "\n";
188 $obj->set_from_related($key, $self);
189 $obj->insert() if(!$obj->in_storage);
193 $source->storage->txn_commit if(!$self->{_rel_in_storage});
195 $self->in_storage(1);
196 $self->{_dirty_columns} = {};
197 $self->{related_resultsets} = {};
198 undef $self->{_orig_ident};
204 $obj->in_storage; # Get value
205 $obj->in_storage(1); # Set value
207 Indicated whether the object exists as a row in the database or not
212 my ($self, $val) = @_;
213 $self->{_in_storage} = $val if @_ > 1;
214 return $self->{_in_storage};
219 $obj->update \%columns?;
221 Must be run on an object that is already in the database; issues an SQL
222 UPDATE query to commit any changes to the object to the database if
225 Also takes an options hashref of C<< column_name => value> pairs >> to update
226 first. But be aware that this hashref might be edited in place, so dont rely on
227 it being the same after a call to C<update>.
232 my ($self, $upd) = @_;
233 $self->throw_exception( "Not in database" ) unless $self->in_storage;
234 my $ident_cond = $self->ident_condition;
235 $self->throw_exception("Cannot safely update a row in a PK-less table")
236 if ! keys %$ident_cond;
239 foreach my $key (keys %$upd) {
240 if (ref $upd->{$key}) {
241 my $info = $self->relationship_info($key);
242 if ($info && $info->{attrs}{accessor}
243 && $info->{attrs}{accessor} eq 'single')
245 my $rel = delete $upd->{$key};
246 $self->set_from_related($key => $rel);
247 $self->{_relationship_data}{$key} = $rel;
248 } elsif ($info && $info->{attrs}{accessor}
249 && $info->{attrs}{accessor} eq 'multi'
250 && ref $upd->{$key} eq 'ARRAY') {
251 my $others = delete $upd->{$key};
252 foreach my $rel_obj (@$others) {
253 if(!Scalar::Util::blessed($rel_obj)) {
254 $rel_obj = $self->create_related($key, $rel_obj);
257 $self->{_relationship_data}{$key} = $others;
258 # $related->{$key} = $others;
261 elsif ($self->has_column($key)
262 && exists $self->column_info($key)->{_inflate_info})
264 $self->set_inflated_column($key, delete $upd->{$key});
268 $self->set_columns($upd);
270 my %to_update = $self->get_dirty_columns;
271 return $self unless keys %to_update;
272 my $rows = $self->result_source->storage->update(
273 $self->result_source, \%to_update,
274 $self->{_orig_ident} || $ident_cond
277 $self->throw_exception( "Can't update ${self}: row not found" );
278 } elsif ($rows > 1) {
279 $self->throw_exception("Can't update ${self}: updated more than one row");
281 $self->{_dirty_columns} = {};
282 $self->{related_resultsets} = {};
283 undef $self->{_orig_ident};
291 Deletes the object from the database. The object is still perfectly
292 usable, but C<< ->in_storage() >> will now return 0 and the object must
293 reinserted using C<< ->insert() >> before C<< ->update() >> can be used
294 on it. If you delete an object in a class with a C<has_many>
295 relationship, all the related objects will be deleted as well. To turn
296 this behavior off, pass C<cascade_delete => 0> in the C<$attr>
297 hashref. Any database-level cascade or restrict will take precedence
298 over a DBIx-Class-based cascading delete. See also L<DBIx::Class::ResultSet/delete>.
305 $self->throw_exception( "Not in database" ) unless $self->in_storage;
306 my $ident_cond = $self->ident_condition;
307 $self->throw_exception("Cannot safely delete a row in a PK-less table")
308 if ! keys %$ident_cond;
309 foreach my $column (keys %$ident_cond) {
310 $self->throw_exception("Can't delete the object unless it has loaded the primary keys")
311 unless exists $self->{_column_data}{$column};
313 $self->result_source->storage->delete(
314 $self->result_source, $ident_cond);
315 $self->in_storage(undef);
317 $self->throw_exception("Can't do class delete without a ResultSource instance")
318 unless $self->can('result_source_instance');
319 my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {};
320 my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_};
321 $self->result_source_instance->resultset->search(@_)->delete;
328 my $val = $obj->get_column($col);
330 Gets a column value from a row object. Does not do any queries; the column
331 must have already been fetched from the database and stored in the object. If
332 there is an inflated value stored that has not yet been deflated, it is deflated
333 when the method is invoked.
338 my ($self, $column) = @_;
339 $self->throw_exception( "Can't fetch data as class method" ) unless ref $self;
340 return $self->{_column_data}{$column} if exists $self->{_column_data}{$column};
341 if (exists $self->{_inflated_column}{$column}) {
342 return $self->store_column($column,
343 $self->_deflated_column($column, $self->{_inflated_column}{$column}));
345 $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column);
349 =head2 has_column_loaded
351 if ( $obj->has_column_loaded($col) ) {
352 print "$col has been loaded from db";
355 Returns a true value if the column value has been loaded from the
356 database (or set locally).
360 sub has_column_loaded {
361 my ($self, $column) = @_;
362 $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self;
363 return 1 if exists $self->{_inflated_column}{$column};
364 return exists $self->{_column_data}{$column};
369 my %data = $obj->get_columns;
371 Does C<get_column>, for all column values at once.
377 if (exists $self->{_inflated_column}) {
378 foreach my $col (keys %{$self->{_inflated_column}}) {
379 $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col}))
380 unless exists $self->{_column_data}{$col};
383 return %{$self->{_column_data}};
386 =head2 get_dirty_columns
388 my %data = $obj->get_dirty_columns;
390 Identical to get_columns but only returns those that have been changed.
394 sub get_dirty_columns {
396 return map { $_ => $self->{_column_data}{$_} }
397 keys %{$self->{_dirty_columns}};
402 $obj->set_column($col => $val);
404 Sets a column value. If the new value is different from the old one,
405 the column is marked as dirty for when you next call $obj->update.
412 $self->{_orig_ident} ||= $self->ident_condition;
413 my $old = $self->get_column($column);
414 my $ret = $self->store_column(@_);
415 $self->{_dirty_columns}{$column} = 1
416 if (defined $old ^ defined $ret) || (defined $old && $old ne $ret);
422 my $copy = $orig->set_columns({ $col => $val, ... });
424 Sets more than one column value at once.
429 my ($self,$data) = @_;
430 foreach my $col (keys %$data) {
431 $self->set_column($col,$data->{$col});
438 my $copy = $orig->copy({ change => $to, ... });
440 Inserts a new row with the specified changes.
445 my ($self, $changes) = @_;
447 my $col_data = { %{$self->{_column_data}} };
448 foreach my $col (keys %$col_data) {
449 delete $col_data->{$col}
450 if $self->result_source->column_info($col)->{is_auto_increment};
453 my $new = { _column_data => $col_data };
454 bless $new, ref $self;
456 $new->result_source($self->result_source);
457 $new->set_columns($changes);
459 foreach my $rel ($self->result_source->relationships) {
460 my $rel_info = $self->result_source->relationship_info($rel);
461 if ($rel_info->{attrs}{cascade_copy}) {
462 my $resolved = $self->result_source->resolve_condition(
463 $rel_info->{cond}, $rel, $new);
464 foreach my $related ($self->search_related($rel)) {
465 $related->copy($resolved);
474 $obj->store_column($col => $val);
476 Sets a column value without marking it as dirty.
481 my ($self, $column, $value) = @_;
482 $self->throw_exception( "No such column '${column}'" )
483 unless exists $self->{_column_data}{$column} || $self->has_column($column);
484 $self->throw_exception( "set_column called for ${column} without value" )
486 return $self->{_column_data}{$column} = $value;
489 =head2 inflate_result
491 Class->inflate_result($result_source, \%me, \%prefetch?)
493 Called by ResultSet to inflate a result from storage
498 my ($class, $source, $me, $prefetch) = @_;
500 my ($source_handle) = $source;
502 if ($source->isa('DBIx::Class::ResultSourceHandle')) {
503 $source = $source_handle->resolve
505 $source_handle = $source->handle
509 _source_handle => $source_handle,
513 bless $new, (ref $class || $class);
516 foreach my $pre (keys %{$prefetch||{}}) {
517 my $pre_val = $prefetch->{$pre};
518 my $pre_source = $source->related_source($pre);
519 $class->throw_exception("Can't prefetch non-existent relationship ${pre}")
521 if (ref($pre_val->[0]) eq 'ARRAY') { # multi
523 foreach my $pre_rec (@$pre_val) {
524 unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_}
525 and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) {
528 push(@pre_objects, $pre_source->result_class->inflate_result(
529 $pre_source, @{$pre_rec}));
531 $new->related_resultset($pre)->set_cache(\@pre_objects);
532 } elsif (defined $pre_val->[0]) {
534 unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_}
535 and !defined $pre_val->[0]{$_} } $pre_source->primary_columns)
537 $fetched = $pre_source->result_class->inflate_result(
538 $pre_source, @{$pre_val});
540 my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
541 $class->throw_exception("No accessor for prefetched $pre")
542 unless defined $accessor;
543 if ($accessor eq 'single') {
544 $new->{_relationship_data}{$pre} = $fetched;
545 } elsif ($accessor eq 'filter') {
546 $new->{_inflated_column}{$pre} = $fetched;
548 $class->throw_exception("Prefetch not supported with accessor '$accessor'");
555 =head2 update_or_insert
557 $obj->update_or_insert
559 Updates the object if it's already in the db, else inserts it.
561 =head2 insert_or_update
563 $obj->insert_or_update
565 Alias for L</update_or_insert>
569 *insert_or_update = \&update_or_insert;
570 sub update_or_insert {
572 return ($self->in_storage ? $self->update : $self->insert);
577 my @changed_col_names = $obj->is_changed();
578 if ($obj->is_changed()) { ... }
580 In array context returns a list of columns with uncommited changes, or
581 in scalar context returns a true value if there are uncommitted
587 return keys %{shift->{_dirty_columns} || {}};
590 =head2 is_column_changed
592 if ($obj->is_column_changed('col')) { ... }
594 Returns a true value if the column has uncommitted changes.
598 sub is_column_changed {
599 my( $self, $col ) = @_;
600 return exists $self->{_dirty_columns}->{$col};
605 my $resultsource = $object->result_source;
607 Accessor to the ResultSource this object was created from
615 $self->_source_handle($_[0]->handle);
617 $self->_source_handle->resolve;
621 =head2 register_column
623 $column_info = { .... };
624 $class->register_column($column_name, $column_info);
626 Registers a column on the class. If the column_info has an 'accessor'
627 key, creates an accessor named after the value if defined; if there is
628 no such key, creates an accessor with the same name as the column
630 The column_info attributes are described in
631 L<DBIx::Class::ResultSource/add_columns>
635 sub register_column {
636 my ($class, $col, $info) = @_;
638 if (exists $info->{accessor}) {
639 return unless defined $info->{accessor};
640 $acc = [ $info->{accessor}, $col ];
642 $class->mk_group_accessors('column' => $acc);
646 =head2 throw_exception
648 See Schema's throw_exception.
652 sub throw_exception {
654 if (ref $self && ref $self->result_source) {
655 $self->result_source->schema->throw_exception(@_);
665 Matt S. Trout <mst@shadowcatsystems.co.uk>
669 You may distribute this code under the same terms as Perl itself.