X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRow.pm;h=a5f7eaa114a4991fdaa12d45b8458582e1bc7c04;hb=0c11ad0ee5c8407f6b87d6e15c62a1b445076dc0;hp=6945cd6f2d6c03b46a272e7238a390848753eb42;hpb=cde96798a03e3e65b2bca2a3246164faab434a03;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Row.pm b/lib/DBIx/Class/Row.pm index 6945cd6..a5f7eaa 100644 --- a/lib/DBIx/Class/Row.pm +++ b/lib/DBIx/Class/Row.pm @@ -6,7 +6,9 @@ use warnings; use base qw/DBIx::Class/; use DBIx::Class::Exception; -use Scalar::Util (); +use Scalar::Util 'blessed'; +use List::Util 'first'; +use Try::Tiny; ### ### Internal method @@ -19,7 +21,7 @@ BEGIN { : sub () { 0 }; } -__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/); +use namespace::clean; =head1 NAME @@ -62,12 +64,12 @@ this class, you are better off calling it on a L object. When calling it directly, you will not get a complete, usable row -object until you pass or set the C attribute, to a +object until you pass or set the C attribute, to a L instance that is attached to a L with a valid connection. C<$attrs> is a hashref of column name, value data. It can also contain -some other attributes such as the C. +some other attributes such as the C. Passing an object, or an arrayref of objects as a value will call L for you. When @@ -133,7 +135,10 @@ sub __new_related_find_or_new_helper { } else { my $us = $rsrc->source_name; - $self->throw_exception ("'$us' neither depends nor is depended on by '$relname', something is wrong..."); + $self->throw_exception ( + "Unable to determine relationship '$relname' direction from '$us', " + . "possibly due to a missing reverse-relationship on '$relname' to '$us'." + ); } } @@ -155,28 +160,23 @@ sub new { my ($class, $attrs) = @_; $class = ref $class if ref $class; - my $new = { - _column_data => {}, - }; - bless $new, $class; - - if (my $handle = delete $attrs->{-source_handle}) { - $new->_source_handle($handle); - } - - my $source; - if ($source = delete $attrs->{-result_source}) { - $new->result_source($source); - } - - if (my $related = delete $attrs->{-cols_from_relations}) { - @{$new->{_ignore_at_insert}={}}{@$related} = (); - } + my $new = bless { _column_data => {} }, $class; if ($attrs) { $new->throw_exception("attrs must be a hashref") unless ref($attrs) eq 'HASH'; + my $source = delete $attrs->{-result_source}; + if ( my $h = delete $attrs->{-source_handle} ) { + $source ||= $h->resolve; + } + + $new->result_source($source) if $source; + + if (my $col_from_rel = delete $attrs->{-cols_from_relations}) { + @{$new->{_ignore_at_insert}={}}{@$col_from_rel} = (); + } + my ($related,$inflated); foreach my $key (keys %$attrs) { @@ -188,7 +188,7 @@ sub new { my $acc_type = $info->{attrs}{accessor} || ''; if ($acc_type eq 'single') { my $rel_obj = delete $attrs->{$key}; - if(!Scalar::Util::blessed($rel_obj)) { + if(!blessed $rel_obj) { $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj); } @@ -208,7 +208,7 @@ sub new { my @objects; foreach my $idx (0 .. $#$others) { my $rel_obj = $others->[$idx]; - if(!Scalar::Util::blessed($rel_obj)) { + if(!blessed $rel_obj) { $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj); } @@ -226,7 +226,7 @@ sub new { elsif ($acc_type eq 'filter') { ## 'filter' should disappear and get merged in with 'single' above! my $rel_obj = delete $attrs->{$key}; - if(!Scalar::Util::blessed($rel_obj)) { + if(!blessed $rel_obj) { $rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj); } if ($rel_obj->in_storage) { @@ -268,10 +268,8 @@ sub new { =back Inserts an object previously created by L 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 row into -the database, use C (see L). +it isn't already in there. Returns the object itself. To insert an +entirely new row into the database, use L. To fetch an uninserted row object, call L on a resultset. @@ -285,11 +283,11 @@ sub insert { my ($self) = @_; return $self if $self->in_storage; 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; + my $storage = $source->storage; + my $rollback_guard; # Check if we stored uninserted relobjs here in new() @@ -302,15 +300,14 @@ sub insert { my $rel_obj = $related_stuff{$relname}; if (! $self->{_rel_in_storage}{$relname}) { - next unless (Scalar::Util::blessed($rel_obj) - && $rel_obj->isa('DBIx::Class::Row')); + next unless (blessed $rel_obj && $rel_obj->isa('DBIx::Class::Row')); next unless $source->_pk_depends_on( $relname, { $rel_obj->get_columns } ); # The guard will save us if we blow out of this scope via die - $rollback_guard ||= $source->storage->txn_scope_guard; + $rollback_guard ||= $storage->txn_scope_guard; MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n"; @@ -339,52 +336,37 @@ sub insert { # start a transaction here if not started yet and there is more stuff # to insert after us if (keys %related_stuff) { - $rollback_guard ||= $source->storage->txn_scope_guard - } - - ## PK::Auto - my %auto_pri; - my $auto_idx = 0; - for ($self->primary_columns) { - if ( - not defined $self->get_column($_) - || - (ref($self->get_column($_)) eq 'SCALAR') - ) { - my $col_info = $source->column_info($_); - $auto_pri{$_} = $auto_idx++ unless $col_info->{auto_nextval}; # auto_nextval's are pre-fetched in the storage - } + $rollback_guard ||= $storage->txn_scope_guard } MULTICREATE_DEBUG and do { no warnings 'uninitialized'; warn "MC $self inserting (".join(', ', $self->get_columns).")\n"; }; - my $updated_cols = $source->storage->insert( + + # perform the insert - the storage will return everything it is asked to + # (autoinc primary columns and any retrieve_on_insert columns) + my %current_rowdata = $self->get_columns; + my $returned_cols = $storage->insert( $source, - { $self->get_columns }, - (keys %auto_pri) && $source->storage->_supports_insert_returning - ? { returning => [ sort { $auto_pri{$a} <=> $auto_pri{$b} } keys %auto_pri ] } - : () - , + { %current_rowdata }, # what to insert, copy because the storage *will* change it ); - foreach my $col (keys %$updated_cols) { - $self->store_column($col, $updated_cols->{$col}); - delete $auto_pri{$col}; + for (keys %$returned_cols) { + $self->store_column($_, $returned_cols->{$_}) + # this ensures we fire store_column only once + # (some asshats like overriding it) + if ( + (!exists $current_rowdata{$_}) + or + (defined $current_rowdata{$_} xor defined $returned_cols->{$_}) + or + (defined $current_rowdata{$_} and $current_rowdata{$_} ne $returned_cols->{$_}) + ); } - if (keys %auto_pri) { - my @missing = sort { $auto_pri{$a} <=> $auto_pri{$b} } keys %auto_pri; - MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @missing )."\n"; - my $storage = $self->result_source->storage; - $self->throw_exception( "Missing primary key but Storage doesn't support last_insert_id" ) - unless $storage->can('last_insert_id'); - my @ids = $storage->last_insert_id($self->result_source, @missing); - $self->throw_exception( "Can't get last insert id" ) - unless (@ids == @missing); - $self->store_column($missing[$_] => $ids[$_]) for 0 .. $#missing; - } + delete $self->{_column_data_in_storage}; + $self->in_storage(1); $self->{_dirty_columns} = {}; $self->{related_resultsets} = {}; @@ -397,25 +379,18 @@ sub insert { : $related_stuff{$relname} ; - if (@cands - && Scalar::Util::blessed($cands[0]) - && $cands[0]->isa('DBIx::Class::Row') + if (@cands && blessed $cands[0] && $cands[0]->isa('DBIx::Class::Row') ) { my $reverse = $source->reverse_relationship_info($relname); foreach my $obj (@cands) { $obj->set_from_related($_, $self) for keys %$reverse; - my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns }; if ($self->__their_pk_needs_us($relname)) { if (exists $self->{_ignore_at_insert}{$relname}) { MULTICREATE_DEBUG and warn "MC $self skipping post-insert on $relname"; - } else { - MULTICREATE_DEBUG and warn "MC $self re-creating $relname $obj"; - my $re = $self->result_source - ->related_source($relname) - ->resultset - ->create($them); - %{$obj} = %{$re}; - MULTICREATE_DEBUG and warn "MC $self new $relname $obj"; + } + else { + MULTICREATE_DEBUG and warn "MC $self inserting $relname $obj"; + $obj->insert; } } else { MULTICREATE_DEBUG and warn "MC $self post-inserting $obj"; @@ -425,9 +400,8 @@ sub insert { } } - $self->in_storage(1); - delete $self->{_orig_ident}; delete $self->{_ignore_at_insert}; + $rollback_guard->commit if $rollback_guard; return $self; @@ -494,7 +468,7 @@ to C, e.g. ( { %{ $href } } ) If the values passed or any of the column values set on the object contain scalar references, e.g.: - $row->last_modified(\'NOW()'); + $row->last_modified(\'NOW()')->update(); # OR $row->update({ last_modified => \'NOW()' }); @@ -518,18 +492,16 @@ this method. sub update { my ($self, $upd) = @_; - $self->throw_exception( "Not in database" ) unless $self->in_storage; - my $ident_cond = $self->{_orig_ident} || $self->ident_condition; + $self->set_inflated_columns($upd) if $upd; - $self->throw_exception('Unable to update a row with incomplete or no identity') - if ! keys %$ident_cond; + my %to_update = $self->get_dirty_columns + or return $self; + + $self->throw_exception( "Not in database" ) unless $self->in_storage; - $self->set_inflated_columns($upd) if $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, $ident_cond + $self->result_source, \%to_update, $self->_storage_ident_condition ); if ($rows == 0) { $self->throw_exception( "Can't update ${self}: row not found" ); @@ -538,7 +510,7 @@ sub update { } $self->{_dirty_columns} = {}; $self->{related_resultsets} = {}; - delete $self->{_orig_ident}; + delete $self->{_column_data_in_storage}; return $self; } @@ -590,23 +562,20 @@ sub delete { if (ref $self) { $self->throw_exception( "Not in database" ) unless $self->in_storage; - my $ident_cond = $self->{_orig_ident} || $self->ident_condition; - $self->throw_exception('Unable to delete a row with incomplete or no identity') - if ! keys %$ident_cond; - $self->result_source->storage->delete( - $self->result_source, $ident_cond + $self->result_source, $self->_storage_ident_condition ); - delete $self->{_orig_ident}; + delete $self->{_column_data_in_storage}; $self->in_storage(undef); } else { - $self->throw_exception("Can't do class delete without a ResultSource instance") - unless $self->can('result_source_instance'); + my $rsrc = try { $self->result_source_instance } + or $self->throw_exception("Can't do class delete without a ResultSource instance"); + my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? { %{pop(@_)} } : {}; my $query = ref $_[0] eq 'HASH' ? $_[0] : {@_}; - $self->result_source_instance->resultset->search(@_)->delete; + $rsrc->resultset->search(@_)->delete; } return $self; } @@ -624,7 +593,7 @@ sub delete { =back Throws an exception if the column name given doesn't exist according -to L. +to L. Returns a raw column value from the row object, if it has already been fetched from the database or set by an accessor. @@ -798,15 +767,14 @@ See L for how to setup inflation. sub get_inflated_columns { my $self = shift; - my %loaded_colinfo = (map - { $_ => $self->column_info($_) } - (grep { $self->has_column_loaded($_) } $self->columns) - ); + my $loaded_colinfo = $self->columns_info ([ + grep { $self->has_column_loaded($_) } $self->columns + ]); my %inflated; - for my $col (keys %loaded_colinfo) { - if (exists $loaded_colinfo{$col}{accessor}) { - my $acc = $loaded_colinfo{$col}{accessor}; + for my $col (keys %$loaded_colinfo) { + if (exists $loaded_colinfo->{$col}{accessor}) { + my $acc = $loaded_colinfo->{$col}{accessor}; $inflated{$col} = $self->$acc if defined $acc; } else { @@ -815,7 +783,7 @@ sub get_inflated_columns { } # return all loaded columns with the inflations overlayed on top - return ($self->get_columns, %inflated); + return %{ { $self->get_columns, %inflated } }; } sub _is_column_numeric { @@ -823,9 +791,13 @@ sub _is_column_numeric { my $colinfo = $self->column_info ($column); # cache for speed (the object may *not* have a resultsource instance) - if (not defined $colinfo->{is_numeric} && $self->_source_handle) { + if ( + ! defined $colinfo->{is_numeric} + and + my $storage = try { $self->result_source->schema->storage } + ) { $colinfo->{is_numeric} = - $self->result_source->schema->storage->is_datatype_numeric ($colinfo->{data_type}) + $storage->is_datatype_numeric ($colinfo->{data_type}) ? 1 : 0 ; @@ -859,25 +831,60 @@ instead, see L. sub set_column { my ($self, $column, $new_value) = @_; - # if we can't get an ident condition on first try - mark the object as unidentifiable - $self->{_orig_ident} ||= (eval { $self->ident_condition }) || {}; + my $had_value = $self->has_column_loaded($column); + my ($old_value, $in_storage) = ($self->get_column($column), $self->in_storage) + if $had_value; - my $old_value = $self->get_column($column); $new_value = $self->store_column($column, $new_value); my $dirty = $self->{_dirty_columns}{$column} || - $self->in_storage # no point tracking dirtyness on uninserted data + $in_storage # no point tracking dirtyness on uninserted data ? ! $self->_eq_column_values ($column, $old_value, $new_value) : 1 ; - # FIXME sadly the update code just checks for keys, not for their value - $self->{_dirty_columns}{$column} = 1 if $dirty; + if ($dirty) { + # FIXME sadly the update code just checks for keys, not for their value + $self->{_dirty_columns}{$column} = 1; + + # Clear out the relation/inflation cache related to this column + # + # FIXME - this is a quick *largely incorrect* hack, pending a more + # serious rework during the merge of single and filter rels + my $rels = $self->result_source->{_relationships}; + for my $rel (keys %$rels) { + + my $acc = $rels->{$rel}{attrs}{accessor} || ''; + + if ( $acc eq 'single' and $rels->{$rel}{attrs}{fk_columns}{$column} ) { + delete $self->{related_resultsets}{$rel}; + delete $self->{_relationship_data}{$rel}; + #delete $self->{_inflated_column}{$rel}; + } + elsif ( $acc eq 'filter' and $rel eq $column) { + delete $self->{related_resultsets}{$rel}; + #delete $self->{_relationship_data}{$rel}; + delete $self->{_inflated_column}{$rel}; + } + } - # XXX clear out the relation cache for this column - delete $self->{related_resultsets}{$column}; + if ( + # value change from something (even if NULL) + $had_value + and + # no storage - no storage-value + $in_storage + and + # no value already stored (multiple changes before commit to storage) + ! exists $self->{_column_data_in_storage}{$column} + and + $self->_track_storage_value($column) + ) { + $self->{_column_data_in_storage}{$column} = $old_value; + } + } return $new_value; } @@ -902,6 +909,13 @@ sub _eq_column_values { } } +# returns a boolean indicating if the passed column should have its original +# value tracked between column changes and commitment to storage +sub _track_storage_value { + my ($self, $col) = @_; + return defined first { $col eq $_ } ($self->primary_columns); +} + =head2 set_columns $row->set_columns({ $col => $val, ... }); @@ -1016,9 +1030,11 @@ sub copy { my ($self, $changes) = @_; $changes ||= {}; my $col_data = { %{$self->{_column_data}} }; + + my $colinfo = $self->columns_info([ keys %$col_data ]); foreach my $col (keys %$col_data) { delete $col_data->{$col} - if $self->result_source->column_info($col)->{is_auto_increment}; + if $colinfo->{$col}{is_auto_increment}; } my $new = { _column_data => $col_data }; @@ -1039,7 +1055,7 @@ sub copy { next unless $rel_info->{attrs}{cascade_copy}; my $resolved = $self->result_source->_resolve_condition( - $rel_info->{cond}, $rel, $new + $rel_info->{cond}, $rel, $new, $rel ); my $copied = $rels_copied->{ $rel_info->{source} } ||= {}; @@ -1113,40 +1129,48 @@ L, see L. sub inflate_result { my ($class, $source, $me, $prefetch) = @_; - my ($source_handle) = $source; + $source = $source->resolve + if $source->isa('DBIx::Class::ResultSourceHandle'); - if ($source->isa('DBIx::Class::ResultSourceHandle')) { - $source = $source_handle->resolve - } - else { - $source_handle = $source->handle - } - - my $new = { - _source_handle => $source_handle, - _column_data => $me, - }; - bless $new, (ref $class || $class); + my $new = bless + { _column_data => $me, _result_source => $source }, + ref $class || $class + ; foreach my $pre (keys %{$prefetch||{}}) { - my $pre_source = $source->related_source($pre) - or $class->throw_exception("Can't prefetch non-existent relationship ${pre}"); - - my $accessor = $source->relationship_info($pre)->{attrs}{accessor} - or $class->throw_exception("No accessor for prefetched $pre"); - - my @pre_vals; + my (@pre_vals, $is_multi); if (ref $prefetch->{$pre}[0] eq 'ARRAY') { + $is_multi = 1; @pre_vals = @{$prefetch->{$pre}}; } - elsif ($accessor eq 'multi') { - $class->throw_exception("Implicit prefetch (via select/columns) not supported with accessor 'multi'"); - } else { @pre_vals = $prefetch->{$pre}; } + my $pre_source = try { + $source->related_source($pre) + } + catch { + $class->throw_exception(sprintf + + "Can't inflate manual prefetch into non-existent relationship '%s' from '%s', " + . "check the inflation specification (columns/as) ending in '%s.%s'.", + + $pre, + $source->source_name, + $pre, + (keys %{$pre_vals[0][0]})[0] || 'something.something...', + ); + }; + + my $accessor = $source->relationship_info($pre)->{attrs}{accessor} + or $class->throw_exception("No accessor type declared for prefetched $pre"); + + if (! $is_multi and $accessor eq 'multi') { + $class->throw_exception("Manual prefetch (via select/columns) not supported with accessor 'multi'"); + } + my @pre_objects; for my $me_pref (@pre_vals) { @@ -1261,7 +1285,7 @@ sub is_column_changed { =over -=item Arguments: none +=item Arguments: $result_source_instance =item Returns: a ResultSource instance @@ -1272,13 +1296,22 @@ Accessor to the L this object was created from. =cut sub result_source { - my $self = shift; - - if (@_) { - $self->_source_handle($_[0]->handle); - } else { - $self->_source_handle->resolve; - } + $_[0]->throw_exception( 'result_source can be called on instances only' ) + unless ref $_[0]; + + @_ > 1 + ? $_[0]->{_result_source} = $_[1] + + # note this is a || not a ||=, the difference is important + : $_[0]->{_result_source} || do { + my $class = ref $_[0]; + $_[0]->can('result_source_instance') + ? $_[0]->result_source_instance + : $_[0]->throw_exception( + "No result source instance registered for $class, did you forget to call $class->table(...) ?" + ) + } + ; } =head2 register_column @@ -1354,28 +1387,39 @@ sub get_from_storage { $resultset = $resultset->search(undef, $attrs); } - my $ident_cond = $self->{_orig_ident} || $self->ident_condition; + return $resultset->find($self->_storage_ident_condition); +} - $self->throw_exception('Unable to requery a row with incomplete or no identity') - if ! keys %$ident_cond; +=head2 discard_changes ($attrs?) - return $resultset->find($ident_cond); -} + $row->discard_changes + +=over + +=item Arguments: none or $attrs + +=item Returns: self (updates object in-place) -=head2 discard_changes ($attrs) +=back Re-selects the row from the database, losing any changes that had -been made. Throws an exception if a proper WHERE clause identifying +been made. Throws an exception if a proper C clause identifying the database row can not be constructed (i.e. if the original object does not contain its entire -L -). +L). This method can also be used to refresh from storage, retrieving any changes made since the row was last read from storage. -$attrs is expected to be a hashref of attributes suitable for passing as the -second argument to $resultset->search($cond, $attrs); +$attrs, if supplied, is expected to be a hashref of attributes suitable for passing as the +second argument to C<< $resultset->search($cond, $attrs) >>; + +Note: If you are using L as your +storage, please kept in mind that if you L on a row that you +just updated or created, you should wrap the entire bit inside a transaction. +Otherwise you run the risk that you insert or update to the master database +but read from a replicant database that has not yet been updated from the +master. This will result in unexpected results. =cut @@ -1403,7 +1447,6 @@ sub discard_changes { } } - =head2 throw_exception See L. @@ -1413,8 +1456,8 @@ See L. sub throw_exception { my $self=shift; - if (ref $self && ref $self->result_source && $self->result_source->schema) { - $self->result_source->schema->throw_exception(@_) + if (ref $self && ref $self->result_source ) { + $self->result_source->throw_exception(@_) } else { DBIx::Class::Exception->throw(@_); @@ -1436,42 +1479,14 @@ sub throw_exception { Returns the primary key(s) for a row. Can't be called as a class method. Actually implemented in L -=head2 discard_changes - - $row->discard_changes - -=over - -=item Arguments: none - -=item Returns: nothing (updates object in-place) - -=back - -Retrieves and sets the row object data from the database, losing any -local changes made. - -This method can also be used to refresh from storage, retrieving any -changes made since the row was last read from storage. Actually -implemented in L - -Note: If you are using L as your -storage, please kept in mind that if you L on a row that you -just updated or created, you should wrap the entire bit inside a transaction. -Otherwise you run the risk that you insert or update to the master database -but read from a replicant database that has not yet been updated from the -master. This will result in unexpected results. - -=cut - -1; +=head1 AUTHOR AND CONTRIBUTORS -=head1 AUTHORS - -Matt S. Trout +See L and L in DBIx::Class =head1 LICENSE You may distribute this code under the same terms as Perl itself. =cut + +1;