From: Jesse Luehrs <doy@tozt.net>
Date: Mon, 31 May 2010 17:53:53 +0000 (-0500)
Subject: optionally subname added subs
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=136add003a9d7cf795718f7af6cc7565b71052c2;p=gitmo%2FPackage-Stash.git

optionally subname added subs
---

diff --git a/dist.ini b/dist.ini
index f4aed77..3de67b1 100644
--- a/dist.ini
+++ b/dist.ini
@@ -8,6 +8,7 @@ dist = Package-Stash
 
 [Prereq]
 Scalar::Util = 0
+Sub::Name = 0
 
 [Prereq / TestRequires]
 Test::Exception = 0
diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm
index 77236d0..714cd6e 100644
--- a/lib/Package/Stash.pm
+++ b/lib/Package/Stash.pm
@@ -5,6 +5,7 @@ use warnings;
 
 use Carp qw(confess);
 use Scalar::Util qw(reftype);
+use Sub::Name;
 use Symbol;
 
 =head1 SYNOPSIS
@@ -104,8 +105,8 @@ variable including the sigil, so
 
 will create C<%Foo::foo>.
 
-Valid options (all optional) are C<filename>, C<first_line_num>, and
-C<last_line_num>.
+Valid options (all optional) are C<filename>, C<first_line_num>,
+C<last_line_num>, and C<subname>.
 
 C<$opts{filename}>, C<$opts{first_line_num}>, and C<$opts{last_line_num}> can
 be used to indicate where the symbol should be regarded as having been defined.
@@ -120,6 +121,11 @@ determine where the source code for a subroutine can be found.  See
 L<http://perldoc.perl.org/perldebguts.html#Debugger-Internals> for more
 information about C<%DB::sub>.
 
+C<$opts{subname}> is used to set the name for the installed subroutine (it is
+ignored if the symbol isn't a subroutine). It uses L<Sub::Name> to set the
+name. If an unqualified name is given, it will add the name of the package
+corresponding to this C<Package::Stash> instance.
+
 =cut
 
 sub _valid_for_type {
@@ -165,7 +171,14 @@ sub add_package_symbol {
 
     no strict 'refs';
     no warnings 'redefine', 'misc', 'prototype';
-    *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
+    if ($type eq 'CODE' && $initial_value && exists $opts{subname}) {
+        $opts{subname} = $pkg . '::' . $opts{subname}
+            if $opts{subname} !~ /::/;
+        *{$pkg . '::' . $name} = subname $opts{subname} => $initial_value;
+    }
+    else {
+        *{$pkg . '::' . $name} = ref $initial_value ? $initial_value : \$initial_value;
+    }
 }
 
 =method remove_package_glob $name
diff --git a/t/07-subname.t b/t/07-subname.t
new file mode 100644
index 0000000..a686384
--- /dev/null
+++ b/t/07-subname.t
@@ -0,0 +1,21 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More;
+
+use Package::Stash;
+
+my $foo_stash = Package::Stash->new('Foo');
+$foo_stash->add_package_symbol('&foo' => sub { caller(0) });
+is((Foo::foo())[3], 'main::__ANON__', "no subname if not requested");
+
+$foo_stash->add_package_symbol('&bar' => sub { caller(0) }, subname => 'bar');
+is((Foo::bar())[3], 'Foo::bar', "got the right subname with implicit package");
+
+$foo_stash->add_package_symbol('&baz' => sub { caller(0) }, subname => 'BAZ');
+is((Foo::baz())[3], 'Foo::BAZ', "got the right subname with implicit package and different glob name");
+
+$foo_stash->add_package_symbol('&quux' => sub { caller(0) }, subname => 'Bar::quux');
+is((Foo::quux())[3], 'Bar::quux', "got the right subname with explicit package");
+
+done_testing;