Make 'filter' rels work half-way sanely with partial prefetch
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Relationship / Accessor.pm
index 1609122..fb95c35 100644 (file)
@@ -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});
     }
   }
 }