On Fri Nov 18 08:40:04 2011, SPROUT wrote:
Show quoted text> On Fri Nov 18 08:35:14 2011, SPROUT wrote:
> > On Thu Nov 17 21:26:17 2011, SPROUT wrote:
> > > On Thu Nov 17 21:23:03 2011, SPROUT wrote:
> > > > On Thu Nov 17 19:40:07 2011, SPROUT wrote:
> > > > > I think that initial logic is faulty in all Perl versions.
> Now
> > I
> > > > just
> > > > > need to think of a workaround.
> > > >
> > > > I believe that renaming the GV itself (the one bound to the ops)
> > and
> > > > inserting it into the symbol
> > > > table under its new name will solve the problem. I don’t know
> > > whether
> > > > there are any CPAN
> > > > modules that do that already. If I can’t find a way to do it in
> > pure
> > > > Perl....
> > >
> > > Actually, it’s easy. The C code in perl is using gv_efullname:
> > >
> > > gv_efullname3(dbsv, gv, NULL);
> > >
> > > (with an e before fullname), so assigning another glob to it
> (after
> > > saving the slots) should do
> > > the trick (and then restore the slots).
> >
> > I have a patch for you. It fixes #72368 as well in 5.14.
>
> And I have just confirmed that it works in 5.8.8, too, so you can
> remove the skip from 07-
> debugger.t.
And you should be able to skip the workarounds in 5.15.5. I haven’t merged the perl fixes
yet, but they are attached here in case you want to try things out before I get to that.
From e9b078c829d964f27a86eb40c84e74e44918e01c Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Fri, 18 Nov 2011 09:08:32 -0800
Subject: [PATCH] Make sure $DB::sub is callable
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
When DB::sub is about to be called (to handle a subroutine call under
the debugger), $DB::sub is set to the name of the subroutine or a ref-
erence to it.
Sometimes $DB::sub is set to the name when the subroutine is not call-
able under that name. That should not happen.
This logic in util.c:Perl_get_db_sub decides whether a reference
should be used:
if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
!( (SvTYPE(*svp) == SVt_PVGV)
&& (GvCV((const GV *)*svp) == cv)
&& (gv = (GV *)*svp)
)
)
)) {
/* Use GV from the stack as a fallback. */
(That comment about using the GV from the stack as a fallback applies
to the assignment to gv, but was mistakenly divorced from it in commit
3de9ffa12.)
This logic (introduced in 71be2cbc7 [inseparable changes from
perl5.003_13 to perl5.003_14] and integrated into blead in 491527d02)
tries to find a GV that points to the CV, trying the CV’s own GV
first, and falling back to what is on the stack. But it does not
account for GVs that are not found under their names, which can hap-
pen when a glob is copied and the original is undefined ($foo = *bar;
undef *bar; &$foo) or when a stash element or package is deleted, such
as via Symbol::delete_package.
If the subroutine is not locatable under its own name or the name
under which it was called (the name of the GV argument to entersub),
then a reference should be passed. Otherwise a name that can access
the sub should be passed.
So this commit adds more (no, not more!) conditions to make sure the
gv is actually reachable under its name before using a string.
Since, for effiency, those conditions do not perform an actual symbol
lookup, but simply look inside the GV’s stash, we can no longer rely
on gv_efullname (or even gv_fullname), as the stash may have been
moved around, but use HvENAME and construct the GV name ourselves.
diff --git a/t/run/switchd.t b/t/run/switchd.t
index 3ea4681..9246b35 100644
--- a/t/run/switchd.t
+++ b/t/run/switchd.t
@@ -9,7 +9,7 @@ BEGIN { require "./test.pl"; }
# This test depends on t/lib/Devel/switchd*.pm.
-plan(tests => 5);
+plan(tests => 6);
my $r;
@@ -78,3 +78,19 @@ like(
qr "1\r?\n2\r?\n",
'Subroutine redefinition works in the debugger [perl #48332]',
);
+
+# [rt.cpan.org #69862]
+like(
+ runperl(
+ switches => [ '-Ilib', '-d:switchd_empty' ],
+ progs => [
+ 'sub DB::sub { goto &$DB::sub }',
+ 'sub foo { print qq _1\n_ }',
+ 'sub bar { print qq _2\n_ }',
+ 'delete $::{foo}; eval { foo() };',
+ 'my $bar = *bar; undef *bar; eval { &$bar };',
+ ],
+ ),
+ qr "1\r?\n2\r?\n",
+ 'Subroutines no longer found under their names can be called',
+);
diff --git a/util.c b/util.c
index 221dee5..866565a 100644
--- a/util.c
+++ b/util.c
@@ -6523,6 +6523,19 @@ long _ftol( double ); /* Defined by VC6 C libs. */
long _ftol2( double dblSource ) { return _ftol( dblSource ); }
#endif
+PERL_STATIC_INLINE bool
+S_gv_has_usable_name(pTHX_ GV *gv)
+{
+ GV **gvp;
+ return GvSTASH(gv)
+ && HvENAME(GvSTASH(gv))
+ && (gvp = (GV **)hv_fetch(
+ GvSTASH(gv), GvNAME(gv),
+ GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0
+ ))
+ && *gvp == gv;
+}
+
void
Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
{
@@ -6543,21 +6556,28 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
- || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ || ( /* Could be imported, and old sub redefined. */
+ (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv))
+ &&
!( (SvTYPE(*svp) == SVt_PVGV)
&& (GvCV((const GV *)*svp) == cv)
- && (gv = (GV *)*svp)
+ /* Use GV from the stack as a fallback. */
+ && S_gv_has_usable_name(gv = (GV *)*svp)
)
)
)) {
- /* Use GV from the stack as a fallback. */
/* GV is potentially non-unique, or contain different CV. */
SV * const tmp = newRV(MUTABLE_SV(cv));
sv_setsv(dbsv, tmp);
SvREFCNT_dec(tmp);
}
else {
- gv_efullname3(dbsv, gv, NULL);
+ sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv)));
+ sv_catpvs(dbsv, "::");
+ sv_catpvn_flags(
+ dbsv, GvNAME(gv), GvNAMELEN(gv),
+ GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
+ );
}
}
else {
