[perl #35059] [PATCH] caller() skips frames (such as eval() frames) if $^P set

From:  glasser@tang-eleven-seventy-nine.mit.edu (via RT) <perlbug-followup@perl.org>
Message-Id:  <rt-3.0.11-35059-111134.0.304511316819145@perl.org>

improved version of change 21842 that copes with glob DB::sub
existing but &DB::sub not existing.

p4raw-id: //depot/perl@24265

diff --git a/mg.c b/mg.c
index 9af4921..af52790 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2162,8 +2162,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        break;
     case '\020':       /* ^P */
        PL_perldb = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
-       if ((PERLDB_SUB || PERLDB_LINE || PERLDB_SUBLINE || PERLDB_ASSERTION)
-               && !PL_DBsingle)
+       if (PL_perldb && !PL_DBsingle)
            init_debugger();
        break;
     case '\024':       /* ^T */

diff --git a/pp_ctl.c b/pp_ctl.c
index 5ce9173..79c38f0 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1567,7 +1567,8 @@ PP(pp_caller)
             }
            RETURN;
        }
-       if (PL_DBsub && cxix >= 0 &&
+       /* caller() should not report the automatic calls to &DB::sub */
+       if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
                ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
            count++;
        if (!count--)
@@ -1580,7 +1581,8 @@ PP(pp_caller)
         dbcxix = dopoptosub_at(ccstack, cxix - 1);
        /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
           field below is defined for any cx. */
-       if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
+       /* caller() should not report the automatic calls to &DB::sub */
+       if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
            cx = &ccstack[dbcxix];
     }
 

diff --git a/t/op/caller.t b/t/op/caller.t
index 4d90aea..578aaaf 100644 (file)
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 27 );
+    plan( tests => 31 );
 }
 
 my @c;
@@ -87,3 +87,32 @@ sub testwarn {
     BEGIN { is( ${^WARNING_BITS}, "UUUUUUUUUUUU", 'warning bits on via "use warnings::register"' ) }
     testwarn("UUUUUUUUUUUU","#3");
 }
+
+
+# The next two cases test for a bug where caller ignored evals if
+# the DB::sub glob existed but &DB::sub did not (for example, if 
+# $^P had been set but no debugger has been loaded).  The tests
+# thus assume that there is no &DB::sub: if there is one, they 
+# should both pass  no matter whether or not this bug has been
+# fixed.
+
+my $debugger_test =  q<
+    my @stackinfo = caller(0);
+    return scalar @stackinfo;
+>;
+
+sub pb { return (caller(0))[3] }
+
+my $i = eval $debugger_test;
+is( $i, 10, "do not skip over eval (and caller returns 10 elements)" );
+
+is( eval 'pb()', 'main::pb', "actually return the right function name" );
+
+my $saved_perldb = $^P;
+$^P = 16;
+$^P = $saved_perldb;
+
+$i = eval $debugger_test;
+is( $i, 10, 'do not skip over eval even if $^P had been on at some point' );
+is( eval 'pb()', 'main::pb', 'actually return the right function name even if $^P had been on at some point' );
+