Skip Menu |

This queue is for tickets about the Sub-Name CPAN distribution.

Report information
The Basics
Id: 50524
Status: resolved
Priority: 0/
Queue: Sub-Name

People
Owner: ether [...] cpan.org
Requestors: ilmari+cpan [...] ilmari.org
Cc: CARNIL [...] cpan.org
AdminCc:

Bug Information
Severity: (no value)
Broken in: (no value)
Fixed in: 0.09



Subject: Should update %DB::Sub when $^P & 0x10 is set
Using Sub::Name breaks Devel::NYTProf's anon sub handling, because the new name isn't in %DB::Sub. subname() needs to do the equivalent of $DB::sub{$new_full_name} = $DB::sub{Sub::Identify::sub_fullname($sub)} if $^P & 0x10;
I've ran into the same issue and wrote small patch for it. It's probably not the best way to solve this problem, but, since this code is executed only under debugger, this seems not to matter at all. --- /root/.cpan/build/Sub-Name-0.04-cyP0n0/Name.xs 2008-07-18 17:23:41.000000000 +0400 +++ Sub-Name/Name.xs 2009-10-25 04:17:49.000000000 +0300 @@ -62,6 +62,38 @@ *end = saved; name = end; } + + /* under debugger, provide information about sub location */ + if (PL_DBsub && CvGV(cv)) { + HV *hv = GvHV(PL_DBsub); + + char* new_pkg = CopSTASHPV(PL_curcop); + + char* old_name = GvNAME( CvGV(cv) ); + char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); + + int old_len = strlen(old_name) + strlen(old_pkg); + int new_len = strlen(name) + strlen(new_pkg); + + char* full_name; + Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); + + strcat(full_name, old_pkg); + strcat(full_name, "::"); + strcat(full_name, old_name); + + SV** old_data = hv_fetch(hv, full_name, strlen(full_name), 0); + + if(old_data != NULL){ + stpcpy(full_name, new_pkg); + strcat(full_name, "::"); + strcat(full_name, name); + + hv_store(hv, full_name, strlen(full_name), *old_data, 0); + } + Safefree(full_name); + } + gv = (GV *) newSV(0); gv_init(gv, stash, name, s - name, TRUE); #ifndef USE_5005THREADS
Here's an updated patch which uses the correct stash name and includes tests.
From 3ea90cf21edc14fd413b9b2d527b1525c1eda155 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= <ilmari@ilmari.org> Date: Mon, 23 Nov 2009 12:39:19 +0000 Subject: [PATCH] RT#50524 - Update DB::sub if it exists --- Name.xs | 32 ++++++++++++++++++++++++++++++++ t/smoke.t | 18 +++++++++++++++++- 2 files changed, 49 insertions(+), 1 deletions(-) diff --git a/Name.xs b/Name.xs index b32411b..3fa9ab9 100644 --- a/Name.xs +++ b/Name.xs @@ -62,6 +62,38 @@ subname(name, sub) *end = saved; name = end; } + + /* under debugger, provide information about sub location */ + if (PL_DBsub && CvGV(cv)) { + HV *hv = GvHV(PL_DBsub); + + char* new_pkg = HvNAME(stash); + + char* old_name = GvNAME( CvGV(cv) ); + char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); + + int old_len = strlen(old_name) + strlen(old_pkg); + int new_len = strlen(name) + strlen(new_pkg); + + char* full_name; + Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); + + strcat(full_name, old_pkg); + strcat(full_name, "::"); + strcat(full_name, old_name); + + SV** old_data = hv_fetch(hv, full_name, strlen(full_name), 0); + + if (old_data != NULL) { + strcpy(full_name, new_pkg); + strcat(full_name, "::"); + strcat(full_name, name); + + hv_store(hv, full_name, strlen(full_name), *old_data, 0); + } + Safefree(full_name); + } + gv = (GV *) newSV(0); gv_init(gv, stash, name, s - name, TRUE); #ifndef USE_5005THREADS diff --git a/t/smoke.t b/t/smoke.t index 87508ed..a383789 100644 --- a/t/smoke.t +++ b/t/smoke.t @@ -1,11 +1,15 @@ #!/usr/bin/perl -BEGIN { print "1..5\n"; } +BEGIN { print "1..10\n"; $^P |= 0x210 } use Sub::Name; my $x = subname foo => sub { (caller 0)[3] }; +my $line = __LINE__ - 1; +my $file = __FILE__; +my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"}; + print $x->() eq "main::foo" ? "ok 1\n" : "not ok 1\n"; @@ -26,4 +30,16 @@ for (4 .. 5) { print $x->() eq "Blork::Dynamic $_" ? "ok $_\n" : "not ok $_\n"; } +print $DB::sub{"main::foo"} eq $anon ? "ok 6\n" : "not ok 6\n"; + +for (4 .. 5) { + print $DB::sub{"Blork::Dynamic $_"} eq $anon ? "ok ".($_+3)."\n" : "not ok ".($_+3)."\n"; +} + +my $i = 9; +for ("Blork:: Bar!", "Foo::Bar::Baz") { + print $DB::sub{$_} eq $anon ? "ok $i\n" : "not ok $_ \n"; + $i++; +} + # vim: ft=perl -- 1.6.5
Here's yet another updated patch, now with correct reference counting of the %DB::sub value.
From 4d66addaedd6dab6544b279e3b7a0a094ee74023 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Dagfinn=20Ilmari=20Manns=C3=A5ker?= <ilmari@ilmari.org> Date: Mon, 23 Nov 2009 12:39:19 +0000 Subject: [PATCH 1/2] RT#50524 - Update DB::sub if it exists --- Name.xs | 33 +++++++++++++++++++++++++++++++++ t/smoke.t | 18 +++++++++++++++++- 2 files changed, 50 insertions(+), 1 deletions(-) diff --git a/Name.xs b/Name.xs index b32411b..3067e09 100644 --- a/Name.xs +++ b/Name.xs @@ -62,6 +62,39 @@ subname(name, sub) *end = saved; name = end; } + + /* under debugger, provide information about sub location */ + if (PL_DBsub && CvGV(cv)) { + HV *hv = GvHV(PL_DBsub); + + char* new_pkg = HvNAME(stash); + + char* old_name = GvNAME( CvGV(cv) ); + char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); + + int old_len = strlen(old_name) + strlen(old_pkg); + int new_len = strlen(name) + strlen(new_pkg); + + char* full_name; + Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); + + strcat(full_name, old_pkg); + strcat(full_name, "::"); + strcat(full_name, old_name); + + SV** old_data = hv_fetch(hv, full_name, strlen(full_name), 0); + + if (old_data != NULL) { + strcpy(full_name, new_pkg); + strcat(full_name, "::"); + strcat(full_name, name); + + SvREFCNT_inc(*old_data); + hv_store(hv, full_name, strlen(full_name), *old_data, 0); + } + Safefree(full_name); + } + gv = (GV *) newSV(0); gv_init(gv, stash, name, s - name, TRUE); #ifndef USE_5005THREADS diff --git a/t/smoke.t b/t/smoke.t index 87508ed..a383789 100644 --- a/t/smoke.t +++ b/t/smoke.t @@ -1,11 +1,15 @@ #!/usr/bin/perl -BEGIN { print "1..5\n"; } +BEGIN { print "1..10\n"; $^P |= 0x210 } use Sub::Name; my $x = subname foo => sub { (caller 0)[3] }; +my $line = __LINE__ - 1; +my $file = __FILE__; +my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"}; + print $x->() eq "main::foo" ? "ok 1\n" : "not ok 1\n"; @@ -26,4 +30,16 @@ for (4 .. 5) { print $x->() eq "Blork::Dynamic $_" ? "ok $_\n" : "not ok $_\n"; } +print $DB::sub{"main::foo"} eq $anon ? "ok 6\n" : "not ok 6\n"; + +for (4 .. 5) { + print $DB::sub{"Blork::Dynamic $_"} eq $anon ? "ok ".($_+3)."\n" : "not ok ".($_+3)."\n"; +} + +my $i = 9; +for ("Blork:: Bar!", "Foo::Bar::Baz") { + print $DB::sub{$_} eq $anon ? "ok $i\n" : "not ok $_ \n"; + $i++; +} + # vim: ft=perl -- 1.6.5
Thanks for additions, this seems to solve problem with local()ized subref assigments to globs.
Another request for this to be added. I'd also like to be able to pass extra args for $filename, $firstlinenumber, $lastlinenumber because there are cases where the actual source code of the sub is in a different location to the subname call (Moose and Devel::Declare are the main examples). I'm happy to submit a patch for this. Just let me know.
RT-Send-CC: timb [...] cpan.org
I'd love Sub::Name to take care of updating DB::sub. On Mon May 31 17:20:02 2010, TIMB wrote: Show quoted text
> I'd also like to be able to pass extra args for $filename, > $firstlinenumber, $lastlinenumber > because there are cases where the actual source code of the sub is in > a different location to the > subname call (Moose and Devel::Declare are the main examples). > > I'm happy to submit a patch for this. Just let me know.
I agree that, in addition to the existing patch, it should be possible to override the defaults for DB::sub. I patch for this will be very welcome!
Subject: [rt.cpan.org #50524] Copy the contents of the %DB::sub entry if it exists
Date: Thu, 9 Sep 2010 02:25:13 +0100
To: bug-Sub-Name [...] rt.cpan.org
From: Dagfinn Ilmari Mannsåker <ilmari [...] ilmari.org>
Closes RT#50524 --- Name.xs | 34 ++++++++++++++++++++++++++++++++++ t/smoke.t | 18 +++++++++++++++++- 2 files changed, 51 insertions(+), 1 deletions(-) diff --git a/Name.xs b/Name.xs index f6d7bc2..89d2dd8 100644 --- a/Name.xs +++ b/Name.xs @@ -64,6 +64,40 @@ subname(name, sub) *end = saved; name = end; } + + /* under debugger, provide information about sub location */ + if (PL_DBsub && CvGV(cv)) { + HV *hv = GvHV(PL_DBsub); + + char* new_pkg = HvNAME(stash); + + char* old_name = GvNAME( CvGV(cv) ); + char* old_pkg = HvNAME( GvSTASH(CvGV(cv)) ); + + int old_len = strlen(old_name) + strlen(old_pkg); + int new_len = strlen(name) + strlen(new_pkg); + + char* full_name; + Newxz(full_name, (old_len > new_len ? old_len : new_len) + 3, char); + + strcat(full_name, old_pkg); + strcat(full_name, "::"); + strcat(full_name, old_name); + + SV** old_data = hv_fetch(hv, full_name, strlen(full_name), 0); + + if (old_data) { + strcpy(full_name, new_pkg); + strcat(full_name, "::"); + strcat(full_name, name); + + SvREFCNT_inc(*old_data); + if (!hv_store(hv, full_name, strlen(full_name), *old_data, 0)) + SvREFCNT_dec(*old_data); + } + Safefree(full_name); + } + gv = (GV *) newSV(0); gv_init(gv, stash, name, s - name, TRUE); diff --git a/t/smoke.t b/t/smoke.t index 87508ed..a383789 100644 --- a/t/smoke.t +++ b/t/smoke.t @@ -1,11 +1,15 @@ #!/usr/bin/perl -BEGIN { print "1..5\n"; } +BEGIN { print "1..10\n"; $^P |= 0x210 } use Sub::Name; my $x = subname foo => sub { (caller 0)[3] }; +my $line = __LINE__ - 1; +my $file = __FILE__; +my $anon = $DB::sub{"main::__ANON__[${file}:${line}]"}; + print $x->() eq "main::foo" ? "ok 1\n" : "not ok 1\n"; @@ -26,4 +30,16 @@ for (4 .. 5) { print $x->() eq "Blork::Dynamic $_" ? "ok $_\n" : "not ok $_\n"; } +print $DB::sub{"main::foo"} eq $anon ? "ok 6\n" : "not ok 6\n"; + +for (4 .. 5) { + print $DB::sub{"Blork::Dynamic $_"} eq $anon ? "ok ".($_+3)."\n" : "not ok ".($_+3)."\n"; +} + +my $i = 9; +for ("Blork:: Bar!", "Foo::Bar::Baz") { + print $DB::sub{$_} eq $anon ? "ok $i\n" : "not ok $_ \n"; + $i++; +} + # vim: ft=perl -- 1.7.0.4
I'm testing this now with NYTProf. Sorry for the delay. More news when I have it.
This is fine as-is. I think this ticket could be closed and 0.06 released with this applied. Thanks! (We can discuss how to optionally specify an alternative file and line range via email. There are issues to explore, mainly how to make it efficient for the caller.)
From: paul [...] city-fan.org
Using Newz rather than Newxz would give compatibility with older perls (not sure when Newxz came in but it's certainly not in 5.8.0).
Test #8 will fail with the changes proposed in #65540 included, and I'm not sure what the right thing to do is.
From: chip [...] pobox.com
On Sun Aug 05 21:01:37 2012, DOHERTY wrote: Show quoted text
> Test #8 will fail with the changes proposed in #65540 included, and I'm > not sure what the right thing to do is.
The changes in #65540 are based on the sound principle that altering a sub name is *renaming* it, so the old name goes away. I don't see how any test that fails when that's true is a good test.
RT-Send-CC: ilmari [...] ilmari.org, chip [...] pobox.com, TIMB [...] cpan.org, paul [...] city-fan.org
hi all, if someone can prepare an updated patch, I'd be happy to release it.
Fixed in 0.09!