Replace many closure-based proxy methods with static qsubs

Not only does this buy a quantum of performance, but it greatly enhances readability of these methods on deparse Deliberately not converting the ManyToMany helper - this code needs a thorough regut :(
Altreus · Jul 21, 2014 · 8d73fcd · 8d73fcd
1 parent 6243d42
commit 8d73fcd
Show file tree

Hide file tree

Showing 15 changed files with 130 additions and 163 deletions.
diff --git a/lib/DBIx/Class/CDBICompat/Constructor.pm b/lib/DBIx/Class/CDBICompat/Constructor.pm
@@ -1,14 +1,13 @@
 package # hide from PAUSE
     DBIx::Class::CDBICompat::Constructor;
 
-use base qw(DBIx::Class::CDBICompat::ImaDBI);
-
-use Sub::Name();
-
 use strict;
 use warnings;
 
+use base 'DBIx::Class::CDBICompat::ImaDBI';
+
 use Carp;
+use DBIx::Class::_Util qw(quote_sub perlstring);
 
 __PACKAGE__->set_sql(Retrieve => <<'');
 SELECT __ESSENTIAL__
@@ -17,17 +16,16 @@ WHERE  %s
 
 sub add_constructor {
     my ($class, $method, $fragment) = @_;
-    return croak("constructors needs a name") unless $method;
 
-    no strict 'refs';
-    my $meth = "$class\::$method";
-    return carp("$method already exists in $class")
-            if *$meth{CODE};
+    croak("constructors needs a name") unless $method;
+
+    carp("$method already exists in $class") && return
+       if $class->can($method);
 
-    *$meth = Sub::Name::subname $meth => sub {
-            my $self = shift;
-            $self->sth_to_objects($self->sql_Retrieve($fragment), \@_);
-    };
+    quote_sub "${class}::${method}" => sprintf( <<'EOC', perlstring $fragment );
+      my $self = shift;
+      $self->sth_to_objects($self->sql_Retrieve(%s), \@_);
+EOC
 }
 
 1;
diff --git a/lib/DBIx/Class/CDBICompat/ImaDBI.pm b/lib/DBIx/Class/CDBICompat/ImaDBI.pm
@@ -4,7 +4,7 @@ package # hide from PAUSE
 use strict;
 use warnings;
 use DBIx::ContextualFetch;
-use Sub::Name ();
+use DBIx::Class::_Util qw(quote_sub perlstring);
 
 use base qw(Class::Data::Inheritable);
 
@@ -81,26 +81,20 @@ sub __driver {
 
 sub set_sql {
   my ($class, $name, $sql) = @_;
-  no strict 'refs';
-  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->dbh_do(
-        _prepare_sth => $class->transform_sql($sql, @_)
-      );
-    };
-  if ($sql =~ /select/i) {
-    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->$sql_name;
-        return $class->sth_to_objects($sth, \@args);
-      };
+
+  quote_sub "${class}::sql_${name}", sprintf( <<'EOC', perlstring $sql );
+    my $class = shift;
+    return $class->storage->dbh_do(
+      _prepare_sth => $class->transform_sql(%s, @_)
+    );
+EOC
+
+
+  if ($sql =~ /select/i) {  # FIXME - this should be anchore surely...?
+    quote_sub "${class}::search_${name}", sprintf( <<'EOC', "sql_$name" );
+      my ($class, @args) = @_;
+      $class->sth_to_objects( $class->%s, \@args);
+EOC
   }
 }
 

diff --git a/lib/DBIx/Class/CDBICompat/Relationship.pm b/lib/DBIx/Class/CDBICompat/Relationship.pm
@@ -3,7 +3,8 @@ package
 
 use strict;
 use warnings;
-use Sub::Name ();
+
+use DBIx::Class::_Util 'quote_sub';
 
 =head1 NAME
 
@@ -23,20 +24,13 @@ my %method2key = (
     args            => 'args',
 );
 
+quote_sub __PACKAGE__ . "::$_" => "\$_[0]->{$method2key{$_}}"
+  for keys %method2key;
+
 sub new {
     my($class, $args) = @_;
 
     return bless $args, $class;
 }
 
-for my $method (keys %method2key) {
-    my $key = $method2key{$method};
-    my $code = sub {
-        $_[0]->{$key};
-    };
-
-    no strict 'refs';
-    *{$method} = Sub::Name::subname $method, $code;
-}
-
 1;
diff --git a/lib/DBIx/Class/CDBICompat/Relationships.pm b/lib/DBIx/Class/CDBICompat/Relationships.pm
@@ -3,11 +3,11 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-use Sub::Name ();
-use base qw/Class::Data::Inheritable/;
+use base 'Class::Data::Inheritable';
 
 use Clone;
 use DBIx::Class::CDBICompat::Relationship;
+use DBIx::Class::_Util qw(quote_sub perlstring);
 
 __PACKAGE__->mk_classdata('__meta_info' => {});
 
@@ -119,19 +119,14 @@ sub has_many {
   );
 
   if (@f_method) {
-    no strict 'refs';
-    no warnings 'redefine';
-    my $post_proc = sub { my $o = shift; $o = $o->$_ for @f_method; $o; };
-    my $name = join '::', $class, $rel;
-    *$name = Sub::Name::subname $name,
-      sub {
-        my $rs = shift->search_related($rel => @_);
-        $rs->{attrs}{record_filter} = $post_proc;
-        return (wantarray ? $rs->all : $rs);
-      };
+    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel), { '$rf' => \sub { my $o = shift; $o = $o->$_ for @f_method; $o } };
+      my $rs = shift->search_related( %s => @_);
+      $rs->{attrs}{record_filter} = $rf;
+      return (wantarray ? $rs->all : $rs);
+EOC
+
     return 1;
   }
-
 }
 
 

diff --git a/lib/DBIx/Class/Relationship/Accessor.pm b/lib/DBIx/Class/Relationship/Accessor.pm
@@ -3,9 +3,8 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-use Sub::Name;
 use DBIx::Class::Carp;
-use DBIx::Class::_Util 'fail_on_internal_wantarray';
+use DBIx::Class::_Util qw(quote_sub perlstring);
 use namespace::clean;
 
 our %_pod_inherit_config =
@@ -24,33 +23,32 @@ sub register_relationship {
 sub add_relationship_accessor {
   my ($class, $rel, $acc_type) = @_;
 
-  my %meth;
   if ($acc_type eq 'single') {
-    $meth{$rel} = sub {
+    quote_sub "${class}::${rel}" => sprintf(<<'EOC', perlstring $rel);
       my $self = shift;
 
       if (@_) {
-        $self->set_from_related($rel, @_);
-        return $self->{_relationship_data}{$rel} = $_[0];
+        $self->set_from_related( %1$s => @_ );
+        return $self->{_relationship_data}{%1$s} = $_[0];
       }
-      elsif (exists $self->{_relationship_data}{$rel}) {
-        return $self->{_relationship_data}{$rel};
+      elsif (exists $self->{_relationship_data}{%1$s}) {
+        return $self->{_relationship_data}{%1$s};
       }
       else {
-        my $rel_info = $class->relationship_info($rel);
+        my $rel_info = $self->result_source->relationship_info(%1$s);
         my $cond = $self->result_source->_resolve_condition(
-          $rel_info->{cond}, $rel, $self, $rel
+          $rel_info->{cond}, %1$s, $self, %1$s
         );
         if ($rel_info->{attrs}->{undef_on_null_fk}){
           return undef unless ref($cond) eq 'HASH';
-          return undef if grep { not defined $_ } values %$cond;
+          return undef if grep { not defined $_ } values %%$cond;
         }
-        my $val = $self->find_related($rel, {}, {});
+        my $val = $self->find_related( %1$s => {} );
         return $val unless $val;  # $val instead of undef so that null-objects can go through
 
-        return $self->{_relationship_data}{$rel} = $val;
+        return $self->{_relationship_data}{%1$s} = $val;
       }
-    };
+EOC
   }
   elsif ($acc_type eq 'filter') {
     $class->throw_exception("No such column '$rel' to filter")
@@ -89,25 +87,17 @@ sub add_relationship_accessor {
   }
   elsif ($acc_type eq 'multi') {
 
-    $meth{$rel} = sub {
-      DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = fail_on_internal_wantarray;
-      shift->search_related($rel, @_)
-    };
-    $meth{"${rel}_rs"} = sub { shift->search_related_rs($rel, @_) };
-    $meth{"add_to_${rel}"} = sub { shift->create_related($rel, @_); };
+    quote_sub "${class}::${rel}_rs", "shift->search_related_rs( $rel => \@_ )";
+    quote_sub "${class}::add_to_${rel}", "shift->create_related( $rel => \@_ )";
+    quote_sub "${class}::${rel}", sprintf( <<'EOC', perlstring $rel );
+      DBIx::Class::_ENV_::ASSERT_NO_INTERNAL_WANTARRAY and my $sog = DBIx::Class::_Util::fail_on_internal_wantarray;
+      shift->search_related( %s => @_ )
+EOC
   }
   else {
     $class->throw_exception("No such relationship accessor type '$acc_type'");
   }
 
-  {
-    no strict 'refs';
-    no warnings 'redefine';
-    foreach my $meth (keys %meth) {
-      my $name = join '::', $class, $meth;
-      *$name = subname($name, $meth{$meth});
-    }
-  }
 }
 
 1;
diff --git a/lib/DBIx/Class/Relationship/ProxyMethods.pm b/lib/DBIx/Class/Relationship/ProxyMethods.pm
@@ -3,8 +3,9 @@ package # hide from PAUSE
 
 use strict;
 use warnings;
-use Sub::Name ();
-use base qw/DBIx::Class/;
+use base 'DBIx::Class';
+use DBIx::Class::_Util 'quote_sub';
+use namespace::clean;
 
 our %_pod_inherit_config =
   (
@@ -22,21 +23,17 @@ sub register_relationship {
 sub proxy_to_related {
   my ($class, $rel, $proxy_args) = @_;
   my %proxy_map = $class->_build_proxy_map_from($proxy_args);
-  no strict 'refs';
-  no warnings 'redefine';
-  foreach my $meth_name ( keys %proxy_map ) {
-    my $proxy_to_col = $proxy_map{$meth_name};
-    my $name = join '::', $class, $meth_name;
-    *$name = Sub::Name::subname $name => sub {
-      my $self = shift;
-      my $relobj = $self->$rel;
-      if (@_ && !defined $relobj) {
-        $relobj = $self->create_related($rel, { $proxy_to_col => $_[0] });
-        @_ = ();
-      }
-      return ($relobj ? $relobj->$proxy_to_col(@_) : undef);
-   }
-  }
+
+  quote_sub "${class}::$_", sprintf( <<'EOC', $rel, $proxy_map{$_} )
+    my $self = shift;
+    my $relobj = $self->%1$s;
+    if (@_ && !defined $relobj) {
+      $relobj = $self->create_related( %1$s => { %2$s => $_[0] } );
+      @_ = ();
+    }
+    $relobj ? $relobj->%2$s(@_) : undef;
+EOC
+    for keys %proxy_map
 }
 
 sub _build_proxy_map_from {

diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm
@@ -4,9 +4,10 @@ package # hide from PAUSE
 use strict;
 use warnings;
 
-use base qw/DBIx::Class/;
-use Scalar::Util qw/blessed/;
-use Sub::Name qw/subname/;
+use base 'DBIx::Class';
+
+use Scalar::Util 'blessed';
+use DBIx::Class::_Util 'quote_sub';
 use namespace::clean;
 
 __PACKAGE__->mk_group_accessors('inherited_ro_instance' => 'source_name');
@@ -80,10 +81,10 @@ for my $method_to_proxy (qw/
   relationship_info
   has_relationship
 /) {
-  no strict qw/refs/;
-  *{__PACKAGE__."::$method_to_proxy"} = subname $method_to_proxy => sub {
-    shift->result_source_instance->$method_to_proxy (@_);
-  };
+  quote_sub
+    __PACKAGE__."::$method_to_proxy"
+      => "shift->result_source_instance->$method_to_proxy (\@_);"
+  ;
 }
 
 1;
diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
@@ -8,8 +8,7 @@ use base 'DBIx::Class';
 use DBIx::Class::Carp;
 use Try::Tiny;
 use Scalar::Util qw/weaken blessed/;
-use DBIx::Class::_Util 'refcount';
-use Sub::Name 'subname';
+use DBIx::Class::_Util qw(refcount quote_sub);
 use Devel::GlobalDestruction;
 use namespace::clean;
 
@@ -897,7 +896,6 @@ sub compose_namespace {
     local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
     use warnings qw/redefine/;
 
-    no strict qw/refs/;
     foreach my $source_name ($self->sources) {
       my $orig_source = $self->source($source_name);
 
@@ -919,11 +917,8 @@ sub compose_namespace {
       }
     }
 
-    foreach my $meth (qw/class source resultset/) {
-      no warnings 'redefine';
-      *{"${target}::${meth}"} = subname "${target}::${meth}" =>
-        sub { shift->schema->$meth(@_) };
-    }
+    quote_sub "${target}::${_}" => "shift->schema->$_(\@_)"
+      for qw(class source resultset);
   }
 
   Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
@@ -1497,11 +1492,7 @@ sub compose_connection {
   }
 
   my $schema = $self->compose_namespace($target, $base);
-  {
-    no strict 'refs';
-    my $name = join '::', $target, 'schema';
-    *$name = subname $name, sub { $schema };
-  }
+  quote_sub "${target}::schema", '$s', { '$s' => \$schema };
 
   $schema->connection(@info);
   foreach my $source_name ($schema->sources) {