use Scalar::Util ();
use Scope::Guard;
+BEGIN {
+ *MULTICREATE_DEBUG =
+ $ENV{DBIC_MULTICREATE_DEBUG}
+ ? sub () { 1 }
+ : sub () { 0 };
+}
+
__PACKAGE__->mk_group_accessors('simple' => qw/_source_handle/);
=head1 NAME
sub __new_related_find_or_new_helper {
my ($self, $relname, $data) = @_;
if ($self->__their_pk_needs_us($relname, $data)) {
-# print STDERR "PK needs us\n";
-# print STDERR "Data: ", Data::Dumper::Dumper($data);
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via new_result";
return $self->result_source
->related_source($relname)
->resultset
->new_result($data);
}
if ($self->result_source->pk_depends_on($relname, $data)) {
-# print STDERR "PK depends on\n";
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new";
return $self->result_source
->related_source($relname)
->resultset
- ->find_or_create($data);
+ ->find_or_new($data);
}
-# print STDERR "Neither, find_or_new\n";
+ MULTICREATE_DEBUG and warn "MC $self constructing $relname via find_or_new_related";
return $self->find_or_new_related($relname, $data);
}
my ($self, $relname, $data) = @_;
my $source = $self->result_source;
my $reverse = $source->reverse_relationship_info($relname);
-# print STDERR "Found reverse rel info: ", Data::Dumper::Dumper($reverse);
my $rel_source = $source->related_source($relname);
my $us = { $self->get_columns };
-# print STDERR "Test on self cols: ", Data::Dumper::Dumper($us);
foreach my $key (keys %$reverse) {
# if their primary key depends on us, then we have to
# just create a result and we'll fill it out afterwards
- my $dep = $rel_source->pk_depends_on($key, $us);
- if($dep) {
-# print STDERR "Assigning $self to $key\n";
- $data->{$key} = $self;
- return 1;
- }
-# return 1 if $rel_source->pk_depends_on($key, $us);
+ return 1 if $rel_source->pk_depends_on($key, $us);
}
return 0;
}
$new->result_source($source);
}
-# print "Source ", $source->source_name, " is $new\n";
+ if (my $related = delete $attrs->{-from_resultset}) {
+ @{$new->{_ignore_at_insert}={}}{@$related} = ();
+ }
+
if ($attrs) {
$new->throw_exception("attrs must be a hashref")
unless ref($attrs) eq 'HASH';
if ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'single')
{
-# print STDERR "Single $key ", Data::Dumper::Dumper($attrs);
-# print STDERR "from $class to: $info->{class}\n";
my $rel_obj = delete $attrs->{$key};
if(!Scalar::Util::blessed($rel_obj)) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
- $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ if ($rel_obj->in_storage) {
+ $new->set_from_related($key, $rel_obj);
+ } else {
+ $new->{_rel_in_storage} = 0;
+ MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj\n";
+ }
- $new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
$related->{$key} = $rel_obj;
-# print STDERR "Related :", join(", ", keys %$related), "\n";
next;
} elsif ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'multi'
&& ref $attrs->{$key} eq 'ARRAY') {
-# print STDERR "Multi $key ", Data::Dumper::Dumper($attrs);
-# print STDERR "from $class to: $info->{class}\n";
my $others = delete $attrs->{$key};
- foreach my $rel_obj (@$others) {
+ my $total = @$others;
+ my @objects;
+ foreach my $idx (0 .. $#$others) {
+ my $rel_obj = $others->[$idx];
if(!Scalar::Util::blessed($rel_obj)) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
- $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ if ($rel_obj->in_storage) {
+ $new->set_from_related($key, $rel_obj);
+ } else {
+ $new->{_rel_in_storage} = 0;
+ MULTICREATE_DEBUG and
+ warn "MC $new uninserted $key $rel_obj (${\($idx+1)} of $total)\n";
+ }
$new->set_from_related($key, $rel_obj) if $rel_obj->in_storage;
+ push(@objects, $rel_obj);
}
- $related->{$key} = $others;
-# print STDERR "Related :", join(", ", keys %$related), "\n";
+ $related->{$key} = \@objects;
next;
} elsif ($info && $info->{attrs}{accessor}
&& $info->{attrs}{accessor} eq 'filter')
if(!Scalar::Util::blessed($rel_obj)) {
$rel_obj = $new->__new_related_find_or_new_helper($key, $rel_obj);
}
- $new->{_rel_in_storage} = 0 unless ($rel_obj->in_storage);
+ unless ($rel_obj->in_storage) {
+ $new->{_rel_in_storage} = 0;
+ MULTICREATE_DEBUG and warn "MC $new uninserted $key $rel_obj";
+ }
$inflated->{$key} = $rel_obj;
next;
} elsif ($class->has_column($key)
$inflated->{$key} = $attrs->{$key};
next;
}
-# print STDERR "Done :", join(", ", keys %$related), "\n";
}
$new->throw_exception("No such column $key on $class")
unless $class->has_column($key);
my @pri = $self->primary_columns;
REL: foreach my $relname (keys %related_stuff) {
-# print STDERR "Looking at: $relname\n";
+
my $rel_obj = $related_stuff{$relname};
next REL unless (Scalar::Util::blessed($rel_obj)
&& $rel_obj->isa('DBIx::Class::Row'));
-# print STDERR "Check pk: from ", $source->source_name, " to $relname\n";
-# print STDERR "With ", Data::Dumper::Dumper({ $rel_obj->get_columns });
next REL unless $source->pk_depends_on(
$relname, { $rel_obj->get_columns }
);
-# print STDERR "$rel_obj\n";
-# print STDERR "in_storage: ", $rel_obj->in_storage, "\n";
-# print STDERR "Inserting $relname\n";
- $rel_obj->insert();
+
+ MULTICREATE_DEBUG and warn "MC $self pre-reconstructing $relname $rel_obj\n";
+
+ my $them = { %{$rel_obj->{_relationship_data} || {} }, $rel_obj->get_inflated_columns };
+ my $re = $self->result_source
+ ->related_source($relname)
+ ->resultset
+ ->find_or_create($them);
+ %{$rel_obj} = %{$re};
$self->set_from_related($relname, $rel_obj);
delete $related_stuff{$relname};
}
}
-# print STDERR "self $self\n";
-# print STDERR "self in_storage ", $self->in_storage, "\n";
-# print STDERR "Ran out of rels, insert ", $source->source_name, "\n";
+ MULTICREATE_DEBUG and do {
+ no warnings 'uninitialized';
+ warn "MC $self inserting (".join(', ', $self->get_columns).")\n";
+ };
my $updated_cols = $source->storage->insert($source, { $self->get_columns });
- $self->set_columns($updated_cols);
- $self->in_storage(1);
-# print STDERR "$self\n";
+ foreach my $col (keys %$updated_cols) {
+ $self->store_column($col, $updated_cols->{$col});
+ }
## PK::Auto
my @auto_pri = grep {
if (@auto_pri) {
#$self->throw_exception( "More than one possible key found for auto-inc on ".ref $self )
# if defined $too_many;
-
+ MULTICREATE_DEBUG and warn "MC $self fetching missing PKs ".join(', ', @auto_pri)."\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');
$self->throw_exception( "Can't get last insert id" )
unless (@ids == @auto_pri);
$self->store_column($auto_pri[$_] => $ids[$_]) for 0 .. $#ids;
+#use Data::Dumper; warn Dumper($self);
}
+
$self->{_dirty_columns} = {};
$self->{related_resultsets} = {};
if(!$self->{_rel_in_storage}) {
- ## Now do the has_many rels, that need $selfs ID.
+ ## Now do the relationships that need our ID (has_many etc.)
foreach my $relname (keys %related_stuff) {
my $rel_obj = $related_stuff{$relname};
my @cands;
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 };
- my $them = { $obj->get_inflated_columns };
-# print STDERR "Does $relname need our PK?\n";
+ my $them = { %{$obj->{_relationship_data} || {} }, $obj->get_inflated_columns };
if ($self->__their_pk_needs_us($relname, $them)) {
-# print STDERR "Yes\n";
- # $obj = $self->find_or_create_related($relname, $them);
- $obj->insert();
+ 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
+ ->find_or_create($them);
+ %{$obj} = %{$re};
+ MULTICREATE_DEBUG and warn "MC $self new $relname $obj";
+ }
} else {
-# print STDERR "No\n";
+ MULTICREATE_DEBUG and warn "MC $self post-inserting $obj";
$obj->insert();
}
}
}
}
+ delete $self->{_ignore_at_insert};
$rollback_guard->commit;
}
-# $self->in_storage(1);
+ $self->in_storage(1);
undef $self->{_orig_ident};
return $self;
}
database-level cascade or restrict will take precedence over a
DBIx-Class-based cascading delete.
+If you delete an object within a txn_do() (see L<DBIx::Class::Storage/txn_do>)
+and the transaction subsequently fails, the row object will remain marked as
+not being in storage. If you know for a fact that the object is still in
+storage (i.e. by inspecting the cause of the transaction's failure), you can
+use C<< $obj->in_storage(1) >> to restore consistency between the object and
+the database. This would allow a subsequent C<< $obj->delete >> to work
+as expected.
+
See also L<DBIx::Class::ResultSet/delete>.
=cut
return map {
my $accessor = $self->column_info($_)->{'accessor'} || $_;
($_ => $self->$accessor);
- } $self->columns;
+ } grep $self->has_column_loaded($_), $self->columns;
}
=head2 set_column