X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRelationship%2FBase.pm;h=f82d2ec5d2b0b89a395472dbb6b5ea00fe534d5f;hb=786c1cdd;hp=994e7d70cc00a0ba67666f63628ecbd5fd799342;hpb=ab1043a6bf062356fd698fc984a22abf674885ef;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Relationship/Base.pm b/lib/DBIx/Class/Relationship/Base.pm
index 994e7d7..f82d2ec 100644
--- a/lib/DBIx/Class/Relationship/Base.pm
+++ b/lib/DBIx/Class/Relationship/Base.pm
@@ -6,8 +6,8 @@ use warnings;
 use base qw/DBIx::Class/;
 
 use Scalar::Util qw/weaken blessed/;
-use Try::Tiny;
 use DBIx::Class::_Util qw( UNRESOLVABLE_CONDITION fail_on_internal_call );
+use DBIx::Class::Carp;
 use namespace::clean;
 
 =head1 NAME
@@ -611,7 +611,7 @@ See L<DBIx::Class::ResultSet/search_related> for more information.
 
 =cut
 
-sub search_related {
+sub search_related :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->search(@_);
 }
@@ -623,7 +623,7 @@ it guarantees a resultset, even in list context.
 
 =cut
 
-sub search_related_rs {
+sub search_related_rs :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->search_rs(@_)
 }
@@ -643,7 +643,7 @@ current result or where conditions.
 
 =cut
 
-sub count_related {
+sub count_related :DBIC_method_is_indirect_sugar {
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->search_rs(@_)->count;
 }
@@ -720,7 +720,7 @@ See L<DBIx::Class::ResultSet/find> for details.
 
 =cut
 
-sub find_related {
+sub find_related :DBIC_method_is_indirect_sugar {
   #my ($self, $rel, @args) = @_;
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   return shift->related_resultset(shift)->find(@_);
@@ -785,7 +785,7 @@ L<DBIx::Class::ResultSet/update_or_create> for details.
 
 =cut
 
-sub update_or_create_related {
+sub update_or_create_related :DBIC_method_is_indirect_sugar {
   #my ($self, $rel, @args) = @_;
   DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_INDIRECT_CALLS and fail_on_internal_call;
   shift->related_resultset(shift)->update_or_create(@_);
@@ -823,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} );