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
: sub () { 0 };
}
-__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
+use namespace::clean;
=head1 NAME
L<DBIx::Class::ResultSet> object.
When calling it directly, you will not get a complete, usable row
-object until you pass or set the C<source_handle> attribute, to a
+object until you pass or set the C<result_source> attribute, to a
L<DBIx::Class::ResultSource> instance that is attached to a
L<DBIx::Class::Schema> 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<source_handle>.
+some other attributes such as the C<result_source>.
Passing an object, or an arrayref of objects as a value will call
L<DBIx::Class::Relationship::Base/set_from_related> for you. When
}
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'."
+ );
}
}
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) {
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);
}
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);
}
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) {
=back
Inserts an object previously created by L</new> 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<create> (see L<DBIx::Class::ResultSet/create>).
+it isn't already in there. Returns the object itself. To insert an
+entirely new row into the database, use L<DBIx::Class::ResultSet/create>.
To fetch an uninserted row object, call
L<new|DBIx::Class::ResultSet/new> on a resultset.
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()
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";
- my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
+ my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_columns };
my $existing;
# if there are no keys - nothing to search for
# 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} = {};
: $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";
}
}
- $self->in_storage(1);
- delete $self->{_orig_ident};
delete $self->{_ignore_at_insert};
+
$rollback_guard->commit if $rollback_guard;
return $self;
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()' });
sub update {
my ($self, $upd) = @_;
- my $ident_cond = $self->{_orig_ident} || $self->ident_condition;
-
$self->set_inflated_columns($upd) if $upd;
- my %to_update = $self->get_dirty_columns;
- return $self unless keys %to_update;
- $self->throw_exception( "Not in database" ) unless $self->in_storage;
+ my %to_update = $self->get_dirty_columns
+ or return $self;
- $self->throw_exception('Unable to update a row with incomplete or no identity')
- if ! keys %$ident_cond;
+ $self->throw_exception( "Not in database" ) unless $self->in_storage;
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" );
}
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
- delete $self->{_orig_ident};
+ delete $self->{_column_data_in_storage};
return $self;
}
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;
}
=back
Throws an exception if the column name given doesn't exist according
-to L</has_column>.
+to L<has_column|DBIx::Class::ResultSource/has_column>.
Returns a raw column value from the row object, if it has already
been fetched from the database or set by an accessor.
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 {
}
# return all loaded columns with the inflations overlayed on top
- return ($self->get_columns, %inflated);
+ return %{ { $self->get_columns, %inflated } };
}
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
;
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;
- if (!$self->in_storage) { # no point tracking dirtyness on uninserted data
- $dirty = 1;
- }
- elsif (defined $old_value xor defined $new_value) {
- $dirty = 1;
- }
- elsif (not defined $old_value) { # both undef
- $dirty = 0;
- }
- elsif ($old_value eq $new_value) {
- $dirty = 0;
- }
- else { # do a numeric comparison if datatype allows it
- if ($self->_is_column_numeric($column)) {
- $dirty = $old_value != $new_value;
+ my $dirty =
+ $self->{_dirty_columns}{$column}
+ ||
+ $in_storage # no point tracking dirtyness on uninserted data
+ ? ! $self->_eq_column_values ($column, $old_value, $new_value)
+ : 1
+ ;
+
+ 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};
+ }
}
- else {
- $dirty = 1;
+
+ 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;
}
}
- # sadly the update code just checks for keys, not for their value
- $self->{_dirty_columns}{$column} = 1 if $dirty;
+ return $new_value;
+}
- # XXX clear out the relation cache for this column
- delete $self->{related_resultsets}{$column};
+sub _eq_column_values {
+ my ($self, $col, $old, $new) = @_;
- return $new_value;
+ if (defined $old xor defined $new) {
+ return 0;
+ }
+ elsif (not defined $old) { # both undef
+ return 1;
+ }
+ elsif ($old eq $new) {
+ return 1;
+ }
+ elsif ($self->_is_column_numeric($col)) { # do a numeric comparison if datatype allows it
+ return $old == $new;
+ }
+ else {
+ return 0;
+ }
+}
+
+# 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
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 };
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} } ||= {};
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) {
=over
-=item Arguments: none
+=item Arguments: $result_source_instance
=item Returns: a ResultSource instance
=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
$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
-=head2 discard_changes ($attrs)
+=item Returns: self (updates object in-place)
+
+=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<WHERE> clause identifying
the database row can not be constructed (i.e. if the original object
does not contain its entire
-L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>
-).
+L<primary key|DBIx::Class::Manual::Intro/The Significance and Importance of Primary Keys>).
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<DBIx::Class::Storage::DBI::Replicated> as your
+storage, please kept in mind that if you L</discard_changes> 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
sub discard_changes {
my ($self, $attrs) = @_;
- delete $self->{_dirty_columns};
return unless $self->in_storage; # Don't reload if we aren't real!
# add a replication default to read from the master only
}
}
-
=head2 throw_exception
See L<DBIx::Class::Schema/throw_exception>.
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(@_);
Returns the primary key(s) for a row. Can't be called as a class method.
Actually implemented in L<DBIx::Class::PK>
-=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<DBIx::Class::PK>
-
-Note: If you are using L<DBIx::Class::Storage::DBI::Replicated> as your
-storage, please kept in mind that if you L</discard_changes> 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 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
You may distribute this code under the same terms as Perl itself.
=cut
+
+1;