X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FRelationship%2FAccessor.pm;h=fb95c35b057c230f7c5cdaab3e6c0e3df3dfdc50;hb=6dd43920c45d7ae898f1bb902a086a9f99741976;hp=1609122fd03813a1f3320913a9f447481c627f44;hpb=560978e22520434c67eebb2de72f0e571e47ee40;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
index 1609122..fb95c35 100644
--- a/lib/DBIx/Class/Relationship/Accessor.pm
+++ b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -3,7 +3,9 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-use Sub::Name ();
+use Sub::Name;
+use DBIx::Class::Carp;
+use namespace::clean;
 
 our %_pod_inherit_config =
   (
@@ -56,8 +58,24 @@ sub add_relationship_accessor {
         deflate => sub {
           my ($val, $self) = @_;
           $self->throw_exception("'$val' isn't a $f_class") unless $val->isa($f_class);
-          return ($val->_ident_values)[0];
-            # WARNING: probably breaks for multi-pri sometimes. FIXME
+
+          # MASSIVE FIXME - this code assumes we pointed at the PK, but the belongs_to
+          # helper does not check any of this
+          # fixup the code a bit to make things saner, but ideally 'filter' needs to
+          # be deprecated ASAP and removed shortly after
+          # Not doing so before 0.08250 however, too many things in motion already
+          my ($pk_col, @rest) = $val->_pri_cols;
+          $self->throw_exception(
+            "Relationship '$rel' of type 'filter' can not work with a multicolumn primary key on source '$f_class'"
+          ) if @rest;
+
+          my $v = $val->$pk_col;
+          carp_unique (
+            "Unable to deflate 'filter'-type relationship '$rel' (related object "
+          . "primary key not retrieved), assuming undef instead"
+          ) if ( ! defined $v and $val->in_storage );
+
+          return $v;
         }
       }
     );
@@ -73,7 +91,7 @@ sub add_relationship_accessor {
     no warnings 'redefine';
     foreach my $meth (keys %meth) {
       my $name = join '::', $class, $meth;
-      *$name = Sub::Name::subname($name, $meth{$meth});
+      *$name = subname($name, $meth{$meth});
     }
   }
 }