From: Guillermo Roditi Date: Tue, 29 Jul 2008 18:44:01 +0000 (+0000) Subject: use sub::name to fix compat with moose method modifiers X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ddc0a6c89d212433eb5716b2aa963f63b1f348d1;p=dbsrgits%2FDBIx-Class-Historic.git use sub::name to fix compat with moose method modifiers --- diff --git a/Changes b/Changes index 630dfe5..d665ab7 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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;