X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRelationship%2FBase.pm;fp=lib%2FDBIx%2FClass%2FRelationship%2FBase.pm;h=f82d2ec5d2b0b89a395472dbb6b5ea00fe534d5f;hp=8e4b280150954ee3d200170a7b01b79b4462aa5c;hb=786c1cddede6675b9fc5fc46ae4e1e136ef2c392;hpb=3aac91f35f319b3bf6bad743d956f037ba857012

diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm
index 8e4b280..f82d2ec 100644
--- a/lib/DBIx/Class/Relationship/Base.pm
+++ b/lib/DBIx/Class/Relationship/Base.pm
@@ -7,6 +7,7 @@ use base qw/DBIx::Class/;
 
 use Scalar::Util qw/weaken blessed/;
 use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION fail_on_internal_call );
+use DBIx::Class::Carp;
 use namespace::clean;
 
 =head1 NAME
@@ -822,7 +823,34 @@ sub set_from_related {
   $self->set_columns( $self->result_source->_resolve_relationship_condition (
     infer_values_based_on => {},
     rel_name => $rel,
-    foreign_values => $f_obj,
+    foreign_values => (
+      # maintain crazy set_from_related interface
+      #
+      ( ! defined $f_obj )          ? +{}
+    : ( ! defined blessed $f_obj )  ? $f_obj
+                                    : do {
+
+        my $f_result_class = $self->result_source->related_source($rel)->result_class;
+
+        unless( $f_obj->isa($f_result_class) ) {
+
+          $self->throw_exception(
+            'Object supplied to set_from_related() must inherit from '
+          . "'$DBIx::Class::ResultSource::__expected_result_class_isa'"
+          ) unless $f_obj->isa(
+            $DBIx::Class::ResultSource::__expected_result_class_isa
+          );
+
+          carp_unique(
+            'Object supplied to set_from_related() usually should inherit from '
+          . "the related ResultClass ('$f_result_class'), perhaps you've made "
+          . 'a mistake?'
+          );
+        }
+
+        +{ $f_obj->get_columns };
+      }
+    ),
     foreign_alias => $rel,
     self_alias => 'me',
   )->{inferred_values} );