use base qw/DBIx::Class/;
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util ();
+use Scope::Guard;
__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
=cut
-## NB (JER) - this assumes set_from_related can cope with multi-rels
## 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().
## This only works because DBIC doesnt yet care to check whether the new_related objects have been passed all their mandatory columns
## When doing the later insert, we need to make sure the PKs are set.
## tests!
sub new {
- my ($class, $attrs, $source) = @_;
+ my ($class, $attrs) = @_;
$class = ref $class if ref $class;
my $new = { _column_data => {} };
bless $new, $class;
- $new->_source_handle($source) if $source;
+ 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_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
my ($related,$inflated);
+ ## Pretend all the rels are actual objects, unset below if not, for insert() to fix
+ $new->{_rel_in_storage} = 1;
+
foreach my $key (keys %$attrs) {
if (ref $attrs->{$key}) {
+ ## Can we extract this lot to use with update(_or .. ) ?
my $info = $class->relationship_info($key);
if ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'single')
{
- my $rel_obj = $attrs->{$key};
- $new->{_rel_in_storage} = 1;
+ my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $new->new_related($key, $rel_obj);
- $new->{_rel_in_storage} = 0;
+ $rel_obj = $new->find_or_new_related($key, $rel_obj);
}
- $new->set_from_related($key, $attrs->{$key});
- $related->{$key} = $attrs->{$key};
+
+ $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+
+ $new->set_from_related($key, $rel_obj);
+ $related->{$key} = $rel_obj;
next;
} elsif ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'multi'
&& ref $attrs->{$key} eq 'ARRAY') {
- my $others = $attrs->{$key};
- $new->{_rel_in_storage} = 1;
- foreach my $rel_obj (@$others) {
- if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $new->new_related($key, $rel_obj);
- $new->{_rel_in_storage} = 0;
- }
+ my $others = delete $attrs->{$key};
+ foreach my $rel_obj (@$others) {
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $new->new_related($key, $rel_obj);
+ $new->{_rel_in_storage} = 0;
}
- $new->set_from_related($key, $others);
- $related->{$key} = $attrs->{$key};
- } elsif ($class->has_column($key)
- && exists $class->column_info($key)->{_inflate_info})
+
+ $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ }
+ $related->{$key} = $others;
+ next;
+ } elsif ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'filter')
{
## 'filter' should disappear and get merged in with 'single' above!
- my $rel_obj = $attrs->{$key};
- $new->{_rel_in_storage} = 1;
+ my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
- $rel_obj = $new->new_related($key, $rel_obj);
- $new->{_rel_in_storage} = 0;
+ $rel_obj = $new->find_or_new_related($key, $rel_obj);
+ $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
}
$inflated->{$key} = $rel_obj;
next;
+ } elsif ($class->has_column($key)
+ && $class->column_info($key)->{_inflate_info}) {
+ $inflated->{$key} = $attrs->{$key};
+ next;
}
}
+ use Data::Dumper;
$new->throw_exception("No such column $key on $class")
unless $class->has_column($key);
$new->store_column($key => $attrs->{$key});
}
- if (my $source = delete $attrs->{-result_source}) {
- $new->result_source($source);
- }
$new->{_relationship_data} = $related if $related;
$new->{_inflated_column} = $inflated if $inflated;
$self->throw_exception("No result_source set on this object; can't insert")
unless $source;
- # Check if we stored uninserted relobjs here in new()
- $source->storage->txn_begin if(!$self->{_rel_in_storage});
+ my $rollback_guard;
+ # Check if we stored uninserted relobjs here in new()
my %related_stuff = (%{$self->{_relationship_data} || {}},
%{$self->{_inflated_column} || {}});
- ## Should all be in relationship_data, but we need to get rid of the
- ## 'filter' reltype..
- foreach my $relname (keys %related_stuff) {
- my $relobj = $related_stuff{$relname};
- if(ref $relobj ne 'ARRAY') {
- $relobj->insert() if(!$relobj->in_storage);
- $self->set_from_related($relname, $relobj);
+
+ if(!$self->{_rel_in_storage}) {
+ $source->storage->txn_begin;
+
+ # The guard will save us if we blow out of this scope via die
+
+ $rollback_guard = Scope::Guard->new(sub { $source->storage->txn_rollback });
+
+ ## Should all be in relationship_data, but we need to get rid of the
+ ## 'filter' reltype..
+ ## These are the FK rels, need their IDs for the insert.
+
+ my @pri = $self->primary_columns;
+
+ REL: foreach my $relname (keys %related_stuff) {
+
+ my $rel_obj = $related_stuff{$relname};
+
+ next REL unless (Scalar::Util::blessed($rel_obj)
+ && $rel_obj->isa('DBIx::Class::Row'));
+
+ my $cond = $source->relationship_info($relname)->{cond};
+
+ next REL unless ref($cond) eq 'HASH';
+
+ # map { foreign.foo => 'self.bar' } to { bar => 'foo' }
+
+ my $keyhash = { map { my $x = $_; $x =~ s/.*\.//; $x; } reverse %$cond };
+
+ # assume anything that references our PK probably is dependent on us
+ # rather than vice versa, unless the far side is (a) defined or (b)
+ # auto-increment
+
+ foreach my $p (@pri) {
+ if (exists $keyhash->{$p}) {
+ unless (defined($rel_obj->get_column($keyhash->{$p}))
+ || $rel_obj->column_info($keyhash->{$p})
+ ->{is_auto_increment}) {
+ next REL;
+ }
+ }
+ }
+
+ $rel_obj->insert();
+ $self->set_from_related($relname, $rel_obj);
+ delete $related_stuff{$relname};
}
}
- $source->storage->insert($source->from, { $self->get_columns });
-
- foreach my $relname (keys %related_stuff) {
- my $relobj = $related_stuff{$relname};
- if(ref $relobj eq 'ARRAY') {
- foreach my $obj (@$relobj) {
- my $info = $self->relationship_info($relname);
- ## What about multi-col FKs ?
- my $key = $1 if($info && (keys %{$info->{cond}})[0] =~ /^foreign\.(\w+)/);
- $obj->set_from_related($key, $self);
- $obj->insert() if(!$obj->in_storage);
+ $source->storage->insert($source, { $self->get_columns });
+
+ ## PK::Auto
+ my @auto_pri = grep {
+ !defined $self->get_column($_) ||
+ ref($self->get_column($_)) eq 'SCALAR'
+ } $self->primary_columns;
+
+ if (@auto_pri) {
+ #$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
+ # if defined $too_many;
+
+ 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,@auto_pri);
+ $self->throw_exception( "Can't get last insert id" )
+ unless (@ids == @auto_pri);
+ $self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
+ }
+
+ if(!$self->{_rel_in_storage}) {
+ ## Now do the has_many rels, that need $selfs ID.
+ foreach my $relname (keys %related_stuff) {
+ my $rel_obj = $related_stuff{$relname};
+ my @cands;
+ if (Scalar::Util::blessed($rel_obj)
+ && $rel_obj->isa('DBIx::Class::Row')) {
+ @cands = ($rel_obj);
+ } elsif (ref $rel_obj eq 'ARRAY') {
+ @cands = @$rel_obj;
+ }
+ if (@cands) {
+ my $reverse = $source->reverse_relationship_info($relname);
+ foreach my $obj (@cands) {
+ $obj->set_from_related($_, $self) for keys %$reverse;
+ $obj->insert() if(!$obj->in_storage);
+ }
}
}
+ $source->storage->txn_commit;
+ $rollback_guard->dismiss;
}
- $source->storage->txn_commit if(!$self->{_rel_in_storage});
$self->in_storage(1);
$self->{_dirty_columns} = {};
=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 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<update>. If you need to preserve the hashref,
+it is sufficient to pass a shallow copy to C<update>, e.g. ( { %{ $href } } )
+
=cut
sub update {
my $rel = delete $upd->{$key};
$self->set_from_related($key => $rel);
$self->{_relationship_data}{$key} = $rel;
- }
+ } elsif ($info && $info->{attrs}{accessor}
+ && $info->{attrs}{accessor} eq 'multi'
+ && ref $upd->{$key} eq 'ARRAY') {
+ my $others = delete $upd->{$key};
+ foreach my $rel_obj (@$others) {
+ if(!Scalar::Util::blessed($rel_obj)) {
+ $rel_obj = $self->create_related($key, $rel_obj);
+ }
+ }
+ $self->{_relationship_data}{$key} = $others;
+# $related->{$key} = $others;
+ next;
+ }
elsif ($self->has_column($key)
&& exists $self->column_info($key)->{_inflate_info})
{
keys %{$self->{_dirty_columns}};
}
+=head2 get_inflated_columns
+
+ my $inflated_data = $obj->get_inflated_columns;
+
+Similar to get_columns but objects are returned for inflated columns instead of their raw non-inflated values.
+
+=cut
+
+sub get_inflated_columns {
+ my $self = shift;
+ return map {
+ my $accessor = $self->column_info($_)->{'accessor'} || $_;
+ ($_ => $self->$accessor);
+ } $self->columns;
+}
+
=head2 set_column
$obj->set_column($col => $val);
$fetched = $pre_source->result_class->inflate_result(
$pre_source, @{$pre_val});
}
+ $new->related_resultset($pre)->set_cache([ $fetched ]);
my $accessor = $source->relationship_info($pre)->{attrs}{accessor};
$class->throw_exception("No accessor for prefetched $pre")
unless defined $accessor;
sub throw_exception {
my $self=shift;
- if (ref $self && ref $self->result_source) {
+ if (ref $self && ref $self->result_source && $self->result_source->schema) {
$self->result_source->schema->throw_exception(@_);
} else {
croak(@_);
projects / dbsrgits/DBIx-Class.git / blobdiff