From: glasser@tang-eleven-seventy-nine.mit.edu <glasser@tang-eleven-seventy-nine.mit.edu>
Date: Wed, 20 Apr 2005 19:28:14 +0000 (+0000)
Subject: [perl #35059] [PATCH] caller() skips frames (such as eval() frames) if $^P set
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f2a7f2982c10dbcfc2084d281af6ad8b959d5fb9;p=p5sagit%2Fp5-mst-13.2.git

[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
--- 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
--- 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
--- 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' );
+