use sub::name to fix compat with moose method modifiers

diff --git a/Changes b/Changes
index 630dfe5..d665ab7 100644 (file)
--- a/Changes
+++ b/Changes
@@ -28,6 +28,8 @@ Revision history for DBIx::Class
           names
         - Add ResultSet::_is_deterministic_value, make new_result filter the
           values passed to new to drop values that would generate invalid SQL.
+        - Use Sub::Name to name closures before installing them. Fixes 
+          incompatibility with Moose method modifiers on generated methods.
 
 0.08010 2008-03-01 10:30
         - Fix t/94versioning.t so it passes with latest SQL::Translator

diff --git a/Makefile.PL b/Makefile.PL
index 58e7e3f..35e30ad 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -24,6 +24,7 @@ requires 'JSON::Any'                 => 1.00;
 requires 'Scope::Guard'              => 0.03;
 requires 'Path::Class'               => 0;
 requires 'List::Util'                => 1.19;
+requires 'Sub::Name'                 => 0.04;
 
 # Perl 5.8.0 doesn't have utf8::is_utf8()
 requires 'Encode'                    => 0 if ($] <= 5.008000);  

diff --git a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
index 6efd725..2dcd878 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
+++ b/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
@@ -3,7 +3,7 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-
+use Sub::Name ();
 use Storable 'dclone';
 
 use base qw/DBIx::Class::Row/;
@@ -87,7 +87,8 @@ sub _register_column_group {
     {
       no strict 'refs';
       no warnings 'redefine';
-      *{$class .'::'. $name} = $accessor;
+      my $fullname = join '::', $class, $name;
+      *$fullname = Sub::Name::subname $fullname, $accessor;
     }
     
     $our_accessors{$accessor}++;

diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
index 346c52f..896eca7 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/ImaDBI.pm
+++ b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
@@ -4,6 +4,7 @@ package # hide from PAUSE
 use strict;
 use warnings;
 use DBIx::ContextualFetch;
+use Sub::Name ();
 
 use base qw/DBIx::Class/;
 
@@ -79,18 +80,21 @@ sub __driver {
 sub set_sql {
   my ($class, $name, $sql) = @_;
   no strict 'refs';
-  *{"${class}::sql_${name}"} =
+  my $sql_name = "sql_${name}";
+  my $full_sql_name = join '::', $class, $sql_name;
+  *$full_sql_name = Sub::Name::subname $full_sql_name,
     sub {
       my $sql = $sql;
       my $class = shift;
       return $class->storage->sth($class->transform_sql($sql, @_));
     };
   if ($sql =~ /select/i) {
-    my $meth = "sql_${name}";
-    *{"${class}::search_${name}"} =
+    my $search_name = "search_${name}";
+    my $full_search_name = join '::', $class, $search_name;
+    *$full_search_name = Sub::Name::subname $full_search_name,
       sub {
         my ($class, @args) = @_;
-        my $sth = $class->$meth;
+        my $sth = $class->$sql_name;
         return $class->sth_to_objects($sth, \@args);
       };
   }

diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm
index 55fff10..880ffc2 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/Relationship.pm
+++ b/lib/DBIx/Class/CDBICompat/Relationship.pm
@@ -3,7 +3,7 @@ package
 
 use strict;
 use warnings;
-
+use Sub::Name ();
 
 =head1 NAME
 
@@ -36,7 +36,7 @@ for my $method (keys %method2key) {
     };
     
     no strict 'refs';
-    *{$method} = $code;
+    *{$method} = Sub::Name::subname $method, $code;
 }
 
 1;

diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm
index 0a4b475..d6120bc 100644 (file)
--- a/lib/DBIx/Class/CDBICompat/Relationships.pm
+++ b/lib/DBIx/Class/CDBICompat/Relationships.pm
@@ -3,7 +3,7 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-
+use Sub::Name ();
 use base qw/Class::Data::Inheritable/;
 
 use Clone;
@@ -122,7 +122,8 @@ sub has_many {
     no strict 'refs';
     no warnings 'redefine';
     my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
-    *{"${class}::${rel}"} =
+    my $name = join '::', $class, $rel;
+    *$name = Sub::Name::subname $name,
       sub {
         my $rs = shift->search_related($rel => @_);
         $rs->{attrs}{record_filter} = $post_proc;

diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
index 76183de..fb15f10 100644 (file)
--- a/lib/DBIx/Class/Relationship/Accessor.pm
+++ b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -3,6 +3,8 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
+use Sub::Name ();
+use Class::Inspector ();
 
 sub register_relationship {
   my ($class, $rel, $info) = @_;
@@ -57,7 +59,8 @@ sub add_relationship_accessor {
     no strict 'refs';
     no warnings 'redefine';
     foreach my $meth (keys %meth) {
-      *{"${class}::${meth}"} = $meth{$meth};
+      my $name = join '::', $class, $meth;
+      *$name = Sub::Name::subname($name, $meth{$meth});
     }
   }
 }

diff --git a/lib/DBIx/Class/Relationship/ManyToMany.pm b/lib/DBIx/Class/Relationship/ManyToMany.pm
index 451e435..76042c0 100644 (file)
--- a/lib/DBIx/Class/Relationship/ManyToMany.pm
+++ b/lib/DBIx/Class/Relationship/ManyToMany.pm
@@ -3,6 +3,7 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
+use Sub::Name ();
 
 sub many_to_many {
   my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
@@ -33,7 +34,8 @@ sub many_to_many {
 
     $rel_attrs->{alias} ||= $f_rel;
 
-    *{"${class}::${meth}_rs"} = sub {
+    my $rs_meth_name = join '::', $class, $rs_meth;
+    *$rs_meth_name = Sub::Name::subname $rs_meth_name, sub {
       my $self = shift;
       my $attrs = @_ > 1 && ref $_[$#_] eq 'HASH' ? pop(@_) : {};
       my @args = ($f_rel, @_ > 0 ? @_ : undef, { %{$rel_attrs||{}}, %$attrs });
@@ -43,13 +45,15 @@ sub many_to_many {
          return $rs;
     };
 
-       *{"${class}::${meth}"} = sub {
+    my $meth_name = join '::', $class, $meth;
+    *$meth_name = Sub::Name::subname $meth_name, sub {
                my $self = shift;
                my $rs = $self->$rs_meth( @_ );
                return (wantarray ? $rs->all : $rs);
        };
 
-    *{"${class}::${add_meth}"} = sub {
+    my $add_meth_name = join '::', $class, $add_meth;
+    *$add_meth_name = Sub::Name::subname $add_meth_name, sub {
       my $self = shift;
       @_ > 0 or $self->throw_exception(
         "${add_meth} needs an object or hashref"
@@ -79,7 +83,8 @@ sub many_to_many {
          return $obj;
     };
 
-    *{"${class}::${set_meth}"} = sub {
+    my $set_meth_name = join '::', $class, $set_meth;
+    *$set_meth_name = Sub::Name::subname $set_meth_name, sub {
       my $self = shift;
       @_ > 0 or $self->throw_exception(
         "{$set_meth} needs a list of objects or hashrefs"
@@ -89,7 +94,8 @@ sub many_to_many {
       $self->$add_meth($_) for (@to_set);
     };
 
-    *{"${class}::${remove_meth}"} = sub {
+    my $remove_meth_name = join '::', $class, $remove_meth;
+    *$remove_meth_name = Sub::Name::subname $remove_meth_name, sub {
       my $self = shift;
       @_ > 0 && ref $_[0] ne 'HASH'
         or $self->throw_exception("${remove_meth} needs an object");

diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm
index 11e4879..b2cc547 100644 (file)
--- a/lib/DBIx/Class/Relationship/ProxyMethods.pm
+++ b/lib/DBIx/Class/Relationship/ProxyMethods.pm
@@ -3,7 +3,7 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-
+use Sub::Name ();
 use base qw/DBIx::Class/;
 
 sub register_relationship {
@@ -20,7 +20,8 @@ sub proxy_to_related {
   no strict 'refs';
   no warnings 'redefine';
   foreach my $proxy (@proxy) {
-    *{"${class}::${proxy}"} =
+    my $name = join '::', $class, $proxy;
+    *$name = Sub::Name::subname $name,
       sub {
         my $self = shift;
         my $val = $self->$rel;

diff --git a/lib/DBIx/Class/ResultSetManager.pm b/lib/DBIx/Class/ResultSetManager.pm
index 721c84c..d2746e5 100644 (file)
--- a/lib/DBIx/Class/ResultSetManager.pm
+++ b/lib/DBIx/Class/ResultSetManager.pm
@@ -2,6 +2,7 @@ package DBIx::Class::ResultSetManager;
 use strict;
 use warnings;
 use base 'DBIx::Class';
+use Sub::Name ();
 use Class::Inspector;
 
 warn "DBIx::Class::ResultSetManager never left experimental status and
@@ -58,7 +59,8 @@ sub _register_attributes {
         if ($attrs->[0] eq 'ResultSet') {
             no strict 'refs';
             my $resultset_class = $self->_setup_resultset_class;
-            *{"$resultset_class\::$meth"} = $self->can($meth);
+            my $name = join '::',$resultset_class, $meth;
+            *$name = Sub::Name::subname $name, $self->can($meth);
             delete ${"${self}::"}{$meth};
         }
     }

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index 1aa36cf..ddef110 100644 (file)
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -7,6 +7,7 @@ use DBIx::Class::Exception;
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util qw/weaken/;
 use File::Spec;
+use Sub::Name ();
 require Module::Find;
 
 use base qw/DBIx::Class/;
@@ -535,7 +536,8 @@ more information.
     my $schema = $self->compose_namespace($target, $base);
     {
       no strict 'refs';
-      *{"${target}::schema"} = sub { $schema };
+      my $name = join '::', $target, 'schema';
+      *$name = Sub::Name::subname $name, sub { $schema };
     }
   
     $schema->connection(@info);
@@ -606,8 +608,8 @@ sub compose_namespace {
     no strict 'refs';
     no warnings 'redefine';
     foreach my $meth (qw/class source resultset/) {
-      *{"${target}::${meth}"} =
-        sub { shift->schema->$meth(@_) };
+      my $name = join '::', $target, $meth;
+      *$name = Sub::Name::subname $name, sub { shift->schema->$meth(@_) };
     }
   }
   return $schema;