X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRow.pm;h=66c6cfbb622cb4a2d055a6a329c6f8298505ee13;hb=fac560c2bcc31d5ab5f981abc521a41501cb1e8a;hp=e00ee8468b70d6c1ac3c72cba207dfdbcaf4d87d;hpb=7411204b288b1df6416832707a8a6ce11e2ab3d8;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index e00ee84..66c6cfb 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -4,8 +4,11 @@ use strict; use warnings; use base qw/DBIx::Class/; +use Carp::Clan qw/^DBIx::Class/; -=head1 NAME +__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/); + +=head1 NAME DBIx::Class::Row - Basic row methods @@ -14,7 +17,7 @@ DBIx::Class::Row - Basic row methods =head1 DESCRIPTION This class is responsible for defining and doing basic operations on rows -derived from L objects. +derived from L objects. =head1 METHODS @@ -29,14 +32,48 @@ Creates a new row object from column => value mappings passed as a hash ref sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; - my $new = bless({ _column_data => { } }, $class); + + my $new = { _column_data => {} }; + bless $new, $class; + + if (my $handle = delete $attrs->{-source_handle}) { + $new->_source_handle($handle); + } + if (my $source = delete $attrs->{-result_source}) { + $new->result_source($source); + } + if ($attrs) { - $new->throw("attrs must be a hashref" ) unless ref($attrs) eq 'HASH'; - while (my ($k, $v) = each %{$attrs}) { - die "No such column $k on $class" unless $class->has_column($k); - $new->store_column($k => $v); + $new->throw_exception("attrs must be a hashref") + unless ref($attrs) eq 'HASH'; + + my ($related,$inflated); + foreach my $key (keys %$attrs) { + if (ref $attrs->{$key}) { + my $info = $class->relationship_info($key); + if ($info && $info->{attrs}{accessor} + && $info->{attrs}{accessor} eq 'single') + { + $new->set_from_related($key, $attrs->{$key}); + $related->{$key} = $attrs->{$key}; + next; + } + elsif ($class->has_column($key) + && exists $class->column_info($key)->{_inflate_info}) + { + $inflated->{$key} = $attrs->{$key}; + next; + } + } + $new->throw_exception("No such column $key on $class") + unless $class->has_column($key); + $new->store_column($key => $attrs->{$key}); } + + $new->{_relationship_data} = $related if $related; + $new->{_inflated_column} = $inflated if $inflated; } + return $new; } @@ -44,23 +81,28 @@ sub new { $obj->insert; -Inserts an object into the database if it isn't already in there. Returns -the object itself. +Inserts an object into the database if it isn't already in +there. Returns the object itself. Requires the object's result source to +be set, or the class to have a result_source_instance method. To insert +an entirely new object into the database, use C (see +L). =cut sub insert { my ($self) = @_; return $self if $self->in_storage; - #use Data::Dumper; warn Dumper($self); - my %in; - $in{$_} = $self->get_column($_) - for grep { defined $self->get_column($_) } $self->columns; - my %out = %{ $self->storage->insert($self->_table_name, \%in) }; - $self->store_column($_, $out{$_}) - for grep { $self->get_column($_) ne $out{$_} } keys %out; + my $source = $self->result_source; + $source ||= $self->result_source($self->result_source_instance) + if $self->can('result_source_instance'); + $self->throw_exception("No result_source set on this object; can't insert") + unless $source; + + $source->storage->insert($source, { $self->get_columns }); $self->in_storage(1); $self->{_dirty_columns} = {}; + $self->{related_resultsets} = {}; + undef $self->{_orig_ident}; return $self; } @@ -79,43 +121,61 @@ sub in_storage { return $self->{_in_storage}; } -=head2 create - - my $new = My::Class->create($attrs); - -A shortcut for My::Class->new($attrs)->insert; - -=cut - -sub create { - my ($class, $attrs) = @_; - $class->throw( "create needs a hashref" ) unless ref $attrs eq 'HASH'; - return $class->new($attrs)->insert; -} - =head2 update - $obj->update; + $obj->update \%columns?; Must be run on an object that is already in the database; issues an SQL -UPDATE query to commit any changes to the object to the db if required. +UPDATE query to commit any changes to the object to the database if +required. + +Also takes an options hashref of C<< column_name => value> pairs >> to update +first. But be aware that this hashref might be edited in place, so dont rely on +it being the same after a call to C. =cut sub update { my ($self, $upd) = @_; - $self->throw( "Not in database" ) unless $self->in_storage; - my %to_update; - $to_update{$_} = $self->get_column($_) for $self->is_changed; - return -1 unless keys %to_update; - my $rows = $self->storage->update($self->_table_name, \%to_update, - $self->ident_condition); + $self->throw_exception( "Not in database" ) unless $self->in_storage; + my $ident_cond = $self->ident_condition; + $self->throw_exception("Cannot safely update a row in a PK-less table") + if ! keys %$ident_cond; + + if ($upd) { + foreach my $key (keys %$upd) { + if (ref $upd->{$key}) { + my $info = $self->relationship_info($key); + if ($info && $info->{attrs}{accessor} + && $info->{attrs}{accessor} eq 'single') + { + my $rel = delete $upd->{$key}; + $self->set_from_related($key => $rel); + $self->{_relationship_data}{$key} = $rel; + } + elsif ($self->has_column($key) + && exists $self->column_info($key)->{_inflate_info}) + { + $self->set_inflated_column($key, delete $upd->{$key}); + } + } + } + $self->set_columns($upd); + } + my %to_update = $self->get_dirty_columns; + return $self unless keys %to_update; + my $rows = $self->result_source->storage->update( + $self->result_source, \%to_update, + $self->{_orig_ident} || $ident_cond + ); if ($rows == 0) { - $self->throw( "Can't update ${self}: row not found" ); + $self->throw_exception( "Can't update ${self}: row not found" ); } elsif ($rows > 1) { - $self->throw("Can't update ${self}: updated more than one row"); + $self->throw_exception("Can't update ${self}: updated more than one row"); } $self->{_dirty_columns} = {}; + $self->{related_resultsets} = {}; + undef $self->{_orig_ident}; return $self; } @@ -123,29 +183,37 @@ sub update { $obj->delete -Deletes the object from the database. The object is still perfectly usable -accessor-wise etc. but ->in_storage will now return 0 and the object must -be re ->insert'ed before it can be ->update'ed +Deletes the object from the database. The object is still perfectly +usable, but C<< ->in_storage() >> will now return 0 and the object must +reinserted using C<< ->insert() >> before C<< ->update() >> can be used +on it. If you delete an object in a class with a C +relationship, all the related objects will be deleted as well. To turn +this behavior off, pass C 0> in the C<$attr> +hashref. Any database-level cascade or restrict will take precedence +over a DBIx-Class-based cascading delete. See also L. =cut sub delete { my $self = shift; if (ref $self) { - $self->throw( "Not in database" ) unless $self->in_storage; - #warn $self->_ident_cond.' '.join(', ', $self->_ident_values); - $self->storage->delete($self->_table_name, $self->ident_condition); + $self->throw_exception( "Not in database" ) unless $self->in_storage; + my $ident_cond = $self->ident_condition; + $self->throw_exception("Cannot safely delete a row in a PK-less table") + if ! keys %$ident_cond; + foreach my $column (keys %$ident_cond) { + $self->throw_exception("Can't delete the object unless it has loaded the primary keys") + unless exists $self->{_column_data}{$column}; + } + $self->result_source->storage->delete( + $self->result_source, $ident_cond); $self->in_storage(undef); - #$self->store_column($_ => undef) for $self->primary_columns; - # Should probably also arrange to trash PK if auto - # but if we do, post-delete cascade triggers fail :/ } else { - my $attrs = { }; - if (@_ > 1 && ref $_[$#_] eq 'HASH') { - $attrs = { %{ pop(@_) } }; - } - my $query = (ref $_[0] eq 'HASH' ? $_[0] : {@_}); - $self->storage->delete($self->_table_name, $query); + $self->throw_exception("Can't do class delete without a ResultSource instance") + unless $self->can('result_source_instance'); + my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; + my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; + $self->result_source_instance->resultset->search(@_)->delete; } return $self; } @@ -154,21 +222,43 @@ sub delete { my $val = $obj->get_column($col); -Gets a column value from a row object. Currently, does not do -any queries; the column must have already been fetched from -the database and stored in the object. +Gets a column value from a row object. Does not do any queries; the column +must have already been fetched from the database and stored in the object. If +there is an inflated value stored that has not yet been deflated, it is deflated +when the method is invoked. =cut sub get_column { my ($self, $column) = @_; - $self->throw( "Can't fetch data as class method" ) unless ref $self; - $self->throw( "No such column '${column}'" ) unless $self->has_column($column); - return $self->{_column_data}{$column} - if exists $self->{_column_data}{$column}; + $self->throw_exception( "Can't fetch data as class method" ) unless ref $self; + return $self->{_column_data}{$column} if exists $self->{_column_data}{$column}; + if (exists $self->{_inflated_column}{$column}) { + return $self->store_column($column, + $self->_deflated_column($column, $self->{_inflated_column}{$column})); + } + $self->throw_exception( "No such column '${column}'" ) unless $self->has_column($column); return undef; } +=head2 has_column_loaded + + if ( $obj->has_column_loaded($col) ) { + print "$col has been loaded from db"; + } + +Returns a true value if the column value has been loaded from the +database (or set locally). + +=cut + +sub has_column_loaded { + my ($self, $column) = @_; + $self->throw_exception( "Can't call has_column data as class method" ) unless ref $self; + return 1 if exists $self->{_inflated_column}{$column}; + return exists $self->{_column_data}{$column}; +} + =head2 get_columns my %data = $obj->get_columns; @@ -179,7 +269,27 @@ Does C, for all column values at once. sub get_columns { my $self = shift; - return map { $_ => $self->get_column($_) } $self->columns; + if (exists $self->{_inflated_column}) { + foreach my $col (keys %{$self->{_inflated_column}}) { + $self->store_column($col, $self->_deflated_column($col, $self->{_inflated_column}{$col})) + unless exists $self->{_column_data}{$col}; + } + } + return %{$self->{_column_data}}; +} + +=head2 get_dirty_columns + + my %data = $obj->get_dirty_columns; + +Identical to get_columns but only returns those that have been changed. + +=cut + +sub get_dirty_columns { + my $self = shift; + return map { $_ => $self->{_column_data}{$_} } + keys %{$self->{_dirty_columns}}; } =head2 set_column @@ -194,9 +304,11 @@ the column is marked as dirty for when you next call $obj->update. sub set_column { my $self = shift; my ($column) = @_; + $self->{_orig_ident} ||= $self->ident_condition; my $old = $self->get_column($column); my $ret = $self->store_column(@_); - $self->{_dirty_columns}{$column} = 1 unless defined $old && $old eq $ret; + $self->{_dirty_columns}{$column} = 1 + if (defined $old ^ defined $ret) || (defined $old && $old ne $ret); return $ret; } @@ -210,9 +322,10 @@ Sets more than one column value at once. sub set_columns { my ($self,$data) = @_; - while (my ($col,$val) = each %$data) { - $self->set_column($col,$val); + foreach my $col (keys %$data) { + $self->set_column($col,$data->{$col}); } + return $self; } =head2 copy @@ -223,6 +336,34 @@ Inserts a new row with the specified changes. =cut +sub copy { + my ($self, $changes) = @_; + $changes ||= {}; + my $col_data = { %{$self->{_column_data}} }; + foreach my $col (keys %$col_data) { + delete $col_data->{$col} + if $self->result_source->column_info($col)->{is_auto_increment}; + } + + my $new = { _column_data => $col_data }; + bless $new, ref $self; + + $new->result_source($self->result_source); + $new->set_columns($changes); + $new->insert; + foreach my $rel ($self->result_source->relationships) { + my $rel_info = $self->result_source->relationship_info($rel); + if ($rel_info->{attrs}{cascade_copy}) { + my $resolved = $self->result_source->resolve_condition( + $rel_info->{cond}, $rel, $new); + foreach my $related ($self->search_related($rel)) { + $related->copy($resolved); + } + } + } + return $new; +} + =head2 store_column $obj->store_column($col => $val); @@ -233,72 +374,107 @@ Sets a column value without marking it as dirty. sub store_column { my ($self, $column, $value) = @_; - $self->throw( "No such column '${column}'" ) - unless $self->has_column($column); - $self->throw( "set_column called for ${column} without value" ) + $self->throw_exception( "No such column '${column}'" ) + unless exists $self->{_column_data}{$column} || $self->has_column($column); + $self->throw_exception( "set_column called for ${column} without value" ) if @_ < 3; return $self->{_column_data}{$column} = $value; } =head2 inflate_result - Class->inflate_result(\%me, \%prefetch?) + Class->inflate_result($result_source, \%me, \%prefetch?) Called by ResultSet to inflate a result from storage =cut sub inflate_result { - my ($class, $me, $prefetch) = @_; - #use Data::Dumper; print Dumper(@_); - my $new = bless({ _column_data => $me }, ref $class || $class); - $new->in_storage(1); - PRE: foreach my $pre (keys %{$prefetch||{}}) { - my $rel_obj = $class->_relationships->{$pre}; - my $pre_class = $class->resolve_class($rel_obj->{class}); - my $fetched = $pre_class->inflate_result(@{$prefetch->{$pre}}); - $class->throw("No accessor for prefetched $pre") - unless defined $rel_obj->{attrs}{accessor}; - if ($rel_obj->{attrs}{accessor} eq 'single') { - PRIMARY: foreach my $pri ($rel_obj->{class}->primary_columns) { - unless (defined $fetched->get_column($pri)) { - undef $fetched; - last PRIMARY; + my ($class, $source, $me, $prefetch) = @_; + + my ($source_handle) = $source; + + if ($source->isa('DBIx::Class::ResultSourceHandle')) { + $source = $source_handle->resolve + } else { + $source_handle = $source->handle + } + + my $new = { + _source_handle => $source_handle, + _column_data => $me, + _in_storage => 1 + }; + bless $new, (ref $class || $class); + + my $schema; + foreach my $pre (keys %{$prefetch||{}}) { + my $pre_val = $prefetch->{$pre}; + my $pre_source = $source->related_source($pre); + $class->throw_exception("Can't prefetch non-existent relationship ${pre}") + unless $pre_source; + if (ref($pre_val->[0]) eq 'ARRAY') { # multi + my @pre_objects; + foreach my $pre_rec (@$pre_val) { + unless ($pre_source->primary_columns == grep { exists $pre_rec->[0]{$_} + and defined $pre_rec->[0]{$_} } $pre_source->primary_columns) { + next; } + push(@pre_objects, $pre_source->result_class->inflate_result( + $pre_source, @{$pre_rec})); + } + $new->related_resultset($pre)->set_cache(\@pre_objects); + } elsif (defined $pre_val->[0]) { + my $fetched; + unless ($pre_source->primary_columns == grep { exists $pre_val->[0]{$_} + and !defined $pre_val->[0]{$_} } $pre_source->primary_columns) + { + $fetched = $pre_source->result_class->inflate_result( + $pre_source, @{$pre_val}); + } + my $accessor = $source->relationship_info($pre)->{attrs}{accessor}; + $class->throw_exception("No accessor for prefetched $pre") + unless defined $accessor; + if ($accessor eq 'single') { + $new->{_relationship_data}{$pre} = $fetched; + } elsif ($accessor eq 'filter') { + $new->{_inflated_column}{$pre} = $fetched; + } else { + $class->throw_exception("Prefetch not supported with accessor '$accessor'"); } - $new->{_relationship_data}{$pre} = $fetched; - } elsif ($rel_obj->{attrs}{accessor} eq 'filter') { - $new->{_inflated_column}{$pre} = $fetched; - } else { - $class->throw("Don't know how to store prefetched $pre"); } } return $new; } -sub copy { - my ($self, $changes) = @_; - my $new = bless({ _column_data => { %{$self->{_column_data}}} }, ref $self); - $new->set_column($_ => $changes->{$_}) for keys %$changes; - return $new->insert; -} +=head2 update_or_insert + + $obj->update_or_insert + +Updates the object if it's already in the db, else inserts it. =head2 insert_or_update $obj->insert_or_update -Updates the object if it's already in the db, else inserts it. +Alias for L =cut -sub insert_or_update { +*insert_or_update = \&update_or_insert; +sub update_or_insert { my $self = shift; return ($self->in_storage ? $self->update : $self->insert); } =head2 is_changed - my @changed_col_names = $obj->is_changed + my @changed_col_names = $obj->is_changed(); + if ($obj->is_changed()) { ... } + +In array context returns a list of columns with uncommited changes, or +in scalar context returns a true value if there are uncommitted +changes. =cut @@ -306,6 +482,77 @@ sub is_changed { return keys %{shift->{_dirty_columns} || {}}; } +=head2 is_column_changed + + if ($obj->is_column_changed('col')) { ... } + +Returns a true value if the column has uncommitted changes. + +=cut + +sub is_column_changed { + my( $self, $col ) = @_; + return exists $self->{_dirty_columns}->{$col}; +} + +=head2 result_source + + my $resultsource = $object->result_source; + +Accessor to the ResultSource this object was created from + +=cut + +sub result_source { + my $self = shift; + + if (@_) { + $self->_source_handle($_[0]->handle); + } else { + $self->_source_handle->resolve; + } +} + +=head2 register_column + + $column_info = { .... }; + $class->register_column($column_name, $column_info); + +Registers a column on the class. If the column_info has an 'accessor' +key, creates an accessor named after the value if defined; if there is +no such key, creates an accessor with the same name as the column + +The column_info attributes are described in +L + +=cut + +sub register_column { + my ($class, $col, $info) = @_; + my $acc = $col; + if (exists $info->{accessor}) { + return unless defined $info->{accessor}; + $acc = [ $info->{accessor}, $col ]; + } + $class->mk_group_accessors('column' => $acc); +} + + +=head2 throw_exception + +See Schema's throw_exception. + +=cut + +sub throw_exception { + my $self=shift; + if (ref $self && ref $self->result_source) { + $self->result_source->schema->throw_exception(@_); + } else { + croak(@_); + } +} + 1; =head1 AUTHORS @@ -317,4 +564,3 @@ Matt S. Trout You may distribute this code under the same terms as Perl itself. =cut -