initial spike towards sub naming to collaborate with namespace checks in DBIC

diff --git a/Changes b/Changes
index 273687f..28f9525 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,4 @@
+  - name subs if Sub::Name is available for better stracktraces
   - undefer all subs before creating a concrete Moose metaclass
   - fix bug in _load_module where global vars could cause mis-detection
     of the module already being loaded

diff --git a/lib/Moo.pm b/lib/Moo.pm
index 34be24e..ff1e20d 100644 (file)
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -16,17 +16,17 @@ sub import {
   my $class = shift;
   strictures->import;
   return if $MAKERS{$target}; # already exported into this package
-  *{_getglob("${target}::extends")} = sub {
+  _install_coderef "${target}::extends" => sub {
     _load_module($_) for @_;
     # Can't do *{...} = \@_ or 5.10.0's mro.pm stops seeing @ISA
     @{*{_getglob("${target}::ISA")}{ARRAY}} = @_;
   };
-  *{_getglob("${target}::with")} = sub {
+  _install_coderef "${target}::with" => sub {
     require Moo::Role;
     Moo::Role->apply_roles_to_package($target, $_[0]);
   };
   $MAKERS{$target} = {};
-  *{_getglob("${target}::has")} = sub {
+  _install_coderef "${target}::has" => sub {
     my ($name, %spec) = @_;
     ($MAKERS{$target}{accessor} ||= do {
       require Method::Generate::Accessor;
@@ -36,7 +36,7 @@ sub import {
           ->register_attribute_specs($name, \%spec);
   };
   foreach my $type (qw(before after around)) {
-    *{_getglob "${target}::${type}"} = sub {
+    _install_coderef "${target}::${type}" => sub {
       require Class::Method::Modifiers;
       _install_modifier($target, $type, @_);
     };

diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm
index 66a9948..914f2b7 100644 (file)
--- a/lib/Moo/Role.pm
+++ b/lib/Moo/Role.pm
@@ -14,7 +14,7 @@ sub import {
   return if $INFO{$target}; # already exported into this package
   # get symbol table reference
   my $stash = do { no strict 'refs'; \%{"${target}::"} };
-  *{_getglob "${target}::has"} = sub {
+  _install_coderef "${target}::has" => sub {
     my ($name, %spec) = @_;
     ($INFO{$target}{accessor_maker} ||= do {
       require Method::Generate::Accessor;

diff --git a/lib/Moo/_Utils.pm b/lib/Moo/_Utils.pm
index a228805..047f6ca 100644 (file)
--- a/lib/Moo/_Utils.pm
+++ b/lib/Moo/_Utils.pm
@@ -5,12 +5,8 @@ no warnings 'once'; # guard against -w
 sub _getglob { \*{$_[0]} }
 sub _getstash { \%{"$_[0]::"} }
 
-BEGIN {
-  *lt_5_8_3 = $] < 5.008003
-    ? sub () { 1 }
-    : sub () { 0 }
-  ;
-}
+use constant lt_5_8_3 => ( $] < 5.008003 ) ? 1 : 0;
+use constant can_haz_subname => eval { require Sub::Name };
 
 use strictures 1;
 use Module::Runtime qw(require_module);
@@ -19,7 +15,7 @@ use Moo::_mro;
 
 our @EXPORT = qw(
     _getglob _install_modifier _load_module _maybe_load_module
-    _get_linear_isa _getstash
+    _get_linear_isa _getstash _install_coderef _name_coderef
 );
 
 sub _install_modifier {
@@ -62,7 +58,15 @@ sub _maybe_load_module {
 }
 
 sub _get_linear_isa {
-    return mro::get_linear_isa($_[0]);
+  return mro::get_linear_isa($_[0]);
+}
+
+sub _install_coderef {
+  *{_getglob($_[0])} = _name_coderef(@_);
+}
+
+sub _name_coderef {
+  can_haz_subname ? Sub::Name::subname(@_) : $_[1];
 }
 
 our $_in_global_destruction = 0;

diff --git a/lib/Sub/Defer.pm b/lib/Sub/Defer.pm
index 8202687..1d7b106 100644 (file)
--- a/lib/Sub/Defer.pm
+++ b/lib/Sub/Defer.pm
@@ -18,6 +18,9 @@ sub undefer_sub {
   # make sure the method slot has not changed since deferral time
   if (defined($target) && $deferred eq *{_getglob($target)}{CODE}||'') {
     no warnings 'redefine';
+
+    # I believe $maker already evals with the right package/name, so that
+    # _install_coderef calls are not necessary --ribasushi
     *{_getglob($target)} = $made;
   }
   push @{$DEFERRED{$made} = $DEFERRED{$deferred}}, $made;
@@ -39,7 +42,7 @@ sub defer_sub {
   };
   $deferred_string = "$deferred";
   $DEFERRED{$deferred} = [ $target, $maker, \$undeferred ];
-  *{_getglob $target} = $deferred if defined($target);
+  _install_coderef $target => $deferred if defined $target;
   return $deferred;
 }