[Bast-commits] r4668 - in DBIx-Class/0.08/trunk: . lib/DBIx/Class
lib/DBIx/Class/CDBICompat lib/DBIx/Class/Relationship
groditi at dev.catalyst.perl.org
groditi at dev.catalyst.perl.org
Tue Jul 29 19:44:01 BST 2008
Author: groditi
Date: 2008-07-29 19:44:01 +0100 (Tue, 29 Jul 2008)
New Revision: 4668
Modified:
DBIx-Class/0.08/trunk/Changes
DBIx-Class/0.08/trunk/Makefile.PL
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ProxyMethods.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSetManager.pm
DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm
Log:
use sub::name to fix compat with moose method modifiers
Modified: DBIx-Class/0.08/trunk/Changes
===================================================================
--- DBIx-Class/0.08/trunk/Changes 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/Changes 2008-07-29 18:44:01 UTC (rev 4668)
@@ -28,6 +28,8 @@
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
Modified: DBIx-Class/0.08/trunk/Makefile.PL
===================================================================
--- DBIx-Class/0.08/trunk/Makefile.PL 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/Makefile.PL 2008-07-29 18:44:01 UTC (rev 4668)
@@ -24,6 +24,7 @@
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);
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ColumnGroups.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-
+use Sub::Name ();
use Storable 'dclone';
use base qw/DBIx::Class::Row/;
@@ -87,7 +87,8 @@
{
no strict 'refs';
no warnings 'redefine';
- *{$class .'::'. $name} = $accessor;
+ my $fullname = join '::', $class, $name;
+ *$fullname = Sub::Name::subname $fullname, $accessor;
}
$our_accessors{$accessor}++;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/ImaDBI.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -4,6 +4,7 @@
use strict;
use warnings;
use DBIx::ContextualFetch;
+use Sub::Name ();
use base qw/DBIx::Class/;
@@ -79,18 +80,21 @@
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);
};
}
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationship.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -3,8 +3,8 @@
use strict;
use warnings;
+use Sub::Name ();
-
=head1 NAME
DBIx::Class::CDBICompat::Relationship
@@ -36,7 +36,7 @@
};
no strict 'refs';
- *{$method} = $code;
+ *{$method} = Sub::Name::subname $method, $code;
}
1;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/CDBICompat/Relationships.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-
+use Sub::Name ();
use base qw/Class::Data::Inheritable/;
use Clone;
@@ -122,7 +122,8 @@
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;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/Accessor.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -3,6 +3,8 @@
use strict;
use warnings;
+use Sub::Name ();
+use Class::Inspector ();
sub register_relationship {
my ($class, $rel, $info) = @_;
@@ -57,7 +59,8 @@
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});
}
}
}
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ManyToMany.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -3,6 +3,7 @@
use strict;
use warnings;
+use Sub::Name ();
sub many_to_many {
my ($class, $meth, $rel, $f_rel, $rel_attrs) = @_;
@@ -33,7 +34,8 @@
$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 @@
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 @@
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 @@
$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");
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ProxyMethods.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ProxyMethods.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Relationship/ProxyMethods.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -3,7 +3,7 @@
use strict;
use warnings;
-
+use Sub::Name ();
use base qw/DBIx::Class/;
sub register_relationship {
@@ -20,7 +20,8 @@
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;
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSetManager.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSetManager.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/ResultSetManager.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -2,6 +2,7 @@
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 @@
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};
}
}
Modified: DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm
===================================================================
--- DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm 2008-07-29 18:10:48 UTC (rev 4667)
+++ DBIx-Class/0.08/trunk/lib/DBIx/Class/Schema.pm 2008-07-29 18:44:01 UTC (rev 4668)
@@ -7,6 +7,7 @@
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 @@
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 @@
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;
More information about the Bast-commits
mailing list