Make sure $DB::sub is callable

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 (file)
--- 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 (file)
--- 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 {