new component to make m2ms introspectables so we can hint the reflector

3 files changed, 85 insertions, 39 deletions

diff --git a/lib/DBIx/Class/IntrospectableM2M.pm b/lib/DBIx/Class/IntrospectableM2M.pm
new file mode 100644
index 0000000..7e8146c
--- /dev/null
+++ b/lib/DBIx/Class/IntrospectableM2M.pm
@@ -0,0 +1,29 @@
+package DBIx::Class::IntrospectableM2M;
+
+use strict;
+use warnings;
+use base 'DBIx::Class';
+
+#namespace pollution. sadface.
+__PACKAGE__->mk_classdata( _m2m_metadata => {} );
+
+sub many_to_many {
+  my $class = shift;
+  my ($meth_name, $link, $far_side) = @_;
+
+  $class->_m2m_metadata->{$meth_name} =
+    {
+     accessor => $meth_name, 
+     relation => $link, #"link" table or imediate relation
+     foreign_relation => $far_side, #'far' table or foreign relation
+     (@_ > 3 ? (attrs => $_[3]) : ()), #only store if exist
+     rs_method => "${meth_name}_rs",      #for completeness..
+     add_method => "add_to_${meth_name}",
+     set_method => "set_${meth_name}",
+     remove_method => "remove_from_${meth_name}",
+    };
+
+  $class->next::method(@_);
+}
+
+1;
diff --git a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm
index 21887b5..5c852b6 100644
--- a/lib/Reaction/InterfaceModel/Reflector/DBIC.pm
+++ b/lib/Reaction/InterfaceModel/Reflector/DBIC.pm
@@ -686,6 +686,11 @@ class DBIC, which {
                     );
 
     #m2m / has_many
+    my $m2m_meta;
+    if(my $coderef = $source->result_class->can('_m2m_metadata')){
+      $m2m_meta = $source->result_class->$coderef;
+    }
+
     my $constraint_is_ArrayRef =
       $from_attr->type_constraint->name eq 'ArrayRef' ||
         $from_attr->type_constraint->is_subtype_of('ArrayRef');
@@ -698,22 +703,21 @@ class DBIC, which {
         #has_many
         my $sm = $self->class_name_from_source_name($parent_class, $rel_moniker);
         #type constraint is a collection, and default builds it
-        $attr_opts{isa} = $self->class_name_for_collection_of($sm);
-        $attr_opts{default} = sub {
-          my $rs = shift->$dm_name->related_resultset($attr_name);
-          return $attr_opts{isa}->new(_source_resultset => $rs);
-        };
+        my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm);
+        $attr_opts{default} = eval "sub {
+          my \$rs = shift->${dm_name}->related_resultset('${attr_name}');
+          return ${isa}->new(_source_resultset => \$rs);
+        }";
       } elsif( $rel_accessor eq 'single') {
         #belongs_to
         #type constraint is the foreign IM object, default inflates it
-        $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
-        $attr_opts{default} = sub {
-          if (defined(my $o = shift->$dm_name->$reader)) {
-            return $attr_opts{isa}->inflate_result($o->result_source, { $o->get_columns });
+        my $isa = $attr_opts{isa} = $self->class_name_from_source_name($parent_class, $rel_moniker);
+        $attr_opts{default} = eval "sub {
+          if (defined(my \$o = shift->${dm_name}->${reader})) {
+            return ${isa}->inflate_result(\$o->result_source, { \$o->get_columns });
           }
           return undef;
-            #->find_related($attr_name, {},{result_class => $attr_opts{isa}});
-        };
+        }";
       }
     } elsif( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/ ) {
       #m2m magic
@@ -727,26 +731,31 @@ class DBIC, which {
           ." traversing many-many for ${mm_name}_list";
 
       my $sm = $self->class_name_from_source_name($parent_class,$far_side->source_name);
-      $attr_opts{isa} = $self->class_name_for_collection_of($sm);
+      my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm);
 
       #proper collections will remove the result_class uglyness.
-      $attr_opts{default} = sub {
-        my $rs = shift->$dm_name->related_resultset($link_table)->related_resultset($mm_name);
-        return $attr_opts{isa}->new(_source_resultset => $rs);
-      };
-    #} elsif( $constraint_is_ArrayRef ){
-      #test these to see if rel is m2m
-      #my $meth = $attr_name;
-      #if( $source->can("set_${meth}") && $source->can("add_to_${meth}") &&
-      #    $source->can("${meth}_rs") && $source->can("remove_from_${meth}") ){
-
-
-      #}
+      $attr_opts{default} = eval "sub {
+        my \$rs = shift->${dm_name}->related_resultset('${link_table}')->related_resultset('${mm_name}');
+        return ${isa}->new(_source_resultset => \$rs);
+      }";
+    } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){
+      #m2m if using introspectable m2m component
+      my $rel = $m2m_meta->{$attr_name}->{relation};
+      my $far_rel   = $m2m_meta->{$attr_name}->{foreign_relation};
+      my $far_source = $source->related_source($rel)->related_source($far_rel);
+      my $sm = $self->class_name_from_source_name($parent_class, $far_source->source_name);
+      my $isa = $attr_opts{isa} = $self->class_name_for_collection_of($sm);
+
+      my $rs_meth = $m2m_meta->{$attr_name}->{rs_method};
+      $attr_opts{default} = eval "sub {
+        return ${isa}->new(_source_resultset => shift->${dm_name}->${rs_meth});
+      }";
     } else {
       #no rel
       $attr_opts{isa} = $from_attr->_isa_metadata;
-      $attr_opts{default} = sub{ shift->$dm_name->$reader };
+      $attr_opts{default} = eval "sub{ shift->${dm_name}->${reader} }";
     }
+
     return \%attr_opts;
   };
 
@@ -860,6 +869,11 @@ class DBIC, which {
         }
     }
 
+
+    my $m2m_meta;
+    if(my $coderef = $source_class->result_class->can('_m2m_metadata')){
+      $m2m_meta = $source_class->result_class->$coderef;
+    }
     #test for relationships
     my $constraint_is_ArrayRef =
       $from_attr->type_constraint->name eq 'ArrayRef' ||
@@ -879,18 +893,20 @@ class DBIC, which {
     } elsif ( $constraint_is_ArrayRef && $attr_name =~ m/^(.*)_list$/) {
       my $mm_name = $1;
       my $link_table = "links_to_${mm_name}_list";
-      my ($hm_source, $far_side);
-      eval { $hm_source = $source->related_source($link_table); }
-        || confess "Can't find ${link_table} has_many for ${mm_name}_list";
-      eval { $far_side = $hm_source->related_source($mm_name); }
-        || confess "Can't find ${mm_name} belongs_to on ".$hm_source->result_class
-          ." traversing many-many for ${mm_name}_list";
-
       $attr_opts{default} = sub { [] };
       $attr_opts{valid_values} = sub {
         shift->target_model->result_source->related_source($link_table)
           ->related_source($mm_name)->resultset;
       };
+    } elsif( $constraint_is_ArrayRef && defined $m2m_meta && exists $m2m_meta->{$attr_name} ){
+      #m2m if using introspectable m2m component
+      my $rel = $m2m_meta->{$attr_name}->{relation};
+      my $far_rel   = $m2m_meta->{$attr_name}->{foreign_relation};
+      $attr_opts{default} = sub { [] };
+      $attr_opts{valid_values} = sub {
+        shift->target_model->result_source->related_source($rel)
+          ->related_source($far_rel)->resultset;
+      };
     }
     #use Data::Dumper;
     #print STDERR "\n" .$attr_name ." - ". $object . "\n";
diff --git a/t/lib/RTest/TestDB/Foo.pm b/t/lib/RTest/TestDB/Foo.pm
index 76e920f..7d8ab61 100644
--- a/t/lib/RTest/TestDB/Foo.pm
+++ b/t/lib/RTest/TestDB/Foo.pm
@@ -1,7 +1,7 @@
 package # hide from PAUSE
   RTest::TestDB::Foo;
 
-use base qw/DBIx::Class::Core/;
+use base qw/DBIx::Class/;
 use metaclass 'Reaction::Meta::Class';
 use Moose;
 
@@ -11,16 +11,17 @@ use Reaction::Types::Core qw/NonEmptySimpleStr/;
 has 'id' => (isa => Int, is => 'ro', required => 1);
 has 'first_name' => (isa => NonEmptySimpleStr, is => 'rw', required => 1);
 has 'last_name' => (isa => NonEmptySimpleStr, is => 'rw', required => 1);
-has 'baz_list' =>
+has 'bazes' =>
   (
    isa => ArrayRef,
    required => 1,
-   reader => 'get_baz_list',
-   writer => 'set_baz_list'
+   reader => 'get_bazes',
+   writer => 'set_bazes'
 );
 
 use namespace::clean -except => [ 'meta' ];
 
+__PACKAGE__->load_components(qw/IntrospectableM2M Core/);
 __PACKAGE__->table('foo');
 
 __PACKAGE__->add_columns(
@@ -31,15 +32,15 @@ __PACKAGE__->add_columns(
 
 __PACKAGE__->set_primary_key('id');
 
-__PACKAGE__->has_many('links_to_baz_list' => 'RTest::TestDB::FooBaz', 'foo');
-__PACKAGE__->many_to_many('baz_list' => 'links_to_baz_list' => 'baz');
+__PACKAGE__->has_many('foo_baz' => 'RTest::TestDB::FooBaz', 'foo');
+__PACKAGE__->many_to_many('bazes' => 'foo_baz' => 'baz');
 
 sub display_name {
   my $self = shift;
   return join(' ', $self->first_name, $self->last_name);
 }
 
-sub get_baz_list { [ shift->baz_list->all ] };
+sub get_bazes { [ shift->bazes_rs->all ] };
 
 __PACKAGE__->meta->make_immutable(inline_constructor => 0);