diff options
author | Jesse Luehrs <doy@tozt.net> | 2010-05-31 12:53:53 -0500 |
---|---|---|
committer | Jesse Luehrs <doy@tozt.net> | 2010-08-27 11:47:08 -0500 |
commit | 136add003a9d7cf795718f7af6cc7565b71052c2 (patch) | |
tree | 4e0f30c6fce5e5f7d8dd3d263e4f79a1bfef42a8 | |
parent | 9488328b8551006f79cc8e3cf144209e39774dd1 (diff) | |
download | package-stash-topic/subname.tar.gz package-stash-topic/subname.zip |
optionally subname added substopic/subname
-rw-r--r-- | dist.ini | 1 | ||||
-rw-r--r-- | lib/Package/Stash.pm | 19 | ||||
-rw-r--r-- | t/07-subname.t | 21 |
3 files changed, 38 insertions, 3 deletions
@@ -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; |