Extend add_package_symbol to set %DB::sub if appropriate.

Helps NYTProf and debuggers.

diff --git a/lib/Package/Stash.pm b/lib/Package/Stash.pm
index 84a4d0b..d3c3071 100644 (file)
--- a/lib/Package/Stash.pm
+++ b/lib/Package/Stash.pm
@@ -98,7 +98,7 @@ sub namespace {
     }
 }
 
-=head2 add_package_symbol $variable $value
+=head2 add_package_symbol $variable $value $filename $firstlinenum $lastlinenum
 
 Adds a new package symbol, for the symbol given as C<$variable>, and optionally
 gives it an initial value of C<$value>. C<$variable> should be the name of
@@ -108,6 +108,18 @@ variable including the sigil, so
 
 will create C<%Foo::foo>.
 
+The optional $filename, $firstlinenum, and $lastlinenum arguments can be used
+to indicate where the symbol should be regarded as having been defined.
+Currently these values are only used if the symbol is a subroutine ('C<&>'
+sigil) and only if C<$^P & 0x10> is true.  In which case the special
+C<%DB::sub> hash is updated to record the values of $filename, $firstlinenum,
+and $lastlinenum for the subroutine.
+
+This is especially useful for debuggers and profilers, which use C<%DB::sub> to
+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>.
+
 =cut
 
 sub _valid_for_type {
@@ -124,18 +136,31 @@ sub _valid_for_type {
 }
 
 sub add_package_symbol {
-    my ($self, $variable, $initial_value) = @_;
+    my ($self, $variable, $initial_value) = @_; # extra args unpacked below
 
     my ($name, $sigil, $type) = ref $variable eq 'HASH'
         ? @{$variable}{qw[name sigil type]}
         : $self->_deconstruct_variable_name($variable);
 
+    my $pkg = $self->name;
+
     if (@_ > 2) {
         $self->_valid_for_type($initial_value, $type)
             || confess "$initial_value is not of type $type";
-    }
 
-    my $pkg = $self->name;
+        # cheap fail-fast check for PERLDBf_SUBLINE and '&'
+        if ($^P and $^P & 0x10 && $sigil eq '&') {
+            my (undef, undef, undef, $filename, $firstlinenum, $lastlinenum) = @_;
+
+            (undef, $filename, $firstlinenum) = caller
+                if not defined $filename;
+            $lastlinenum = $firstlinenum ||= 0
+                if not defined $lastlinenum;
+
+            # http://perldoc.perl.org/perldebguts.html#Debugger-Internals
+            $DB::sub{$pkg . '::' . $name} = "$filename:$firstlinenum-$lastlinenum";
+        }
+    }
 
     no strict 'refs';
     no warnings 'redefine', 'misc', 'prototype';

diff --git a/t/006-addsub.t b/t/006-addsub.t
new file mode 100644 (file)
index 0000000..b5a5822
--- /dev/null
+++ b/t/006-addsub.t
@@ -0,0 +1,40 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+
+BEGIN { $^P |= 0x210 } # PERLDBf_SUBLINE
+
+use Package::Stash;
+
+my $foo_stash = Package::Stash->new('Foo');
+
+# ----------------------------------------------------------------------
+## test adding a CODE
+
+ok(!defined($Foo::{funk}), '... the &funk slot has not been created yet');
+
+lives_ok {
+    $foo_stash->add_package_symbol('&funk' => sub { "Foo::funk", __LINE__ });
+} '... created &Foo::funk successfully';
+
+ok(defined($Foo::{funk}), '... the &funk slot was created successfully');
+
+{
+    no strict 'refs';
+    ok(defined &{'Foo::funk'}, '... our &funk exists');
+}
+
+is((Foo->funk())[0], 'Foo::funk', '... got the right value from the function');
+
+my $line = (Foo->funk())[1];
+is $DB::sub{'Foo::funk'}, sprintf "%s:%d-%d", __FILE__, $line, $line,
+    '... got the right %DB::sub value for funk default args';
+
+$foo_stash->add_package_symbol('&dunk' => sub { "Foo::dunk" }, "FileName", 100, 199);
+
+is $DB::sub{'Foo::dunk'}, sprintf "%s:%d-%d", "FileName", 100, 199,
+    '... got the right %DB::sub value for dunk with specified args';
+
+done_testing;