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 /lib/Package/Stash.pm | |
parent | 9488328b8551006f79cc8e3cf144209e39774dd1 (diff) | |
download | package-stash-136add003a9d7cf795718f7af6cc7565b71052c2.tar.gz package-stash-136add003a9d7cf795718f7af6cc7565b71052c2.zip |
optionally subname added substopic/subname
Diffstat (limited to 'lib/Package/Stash.pm')
-rw-r--r-- | lib/Package/Stash.pm | 19 |
1 files changed, 16 insertions, 3 deletions
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 |