From: Gurusamy Sarathy <gsar@cpan.org>
Date: Sun, 12 Jul 1998 02:11:16 +0000 (+0000)
Subject: fix pp_caller() to fully traverse stacklevels
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2c375eb932f2eb03c0f34b2cbba1ce81b7ff1b59;p=p5sagit%2Fp5-mst-13.2.git

fix pp_caller() to fully traverse stacklevels

p4raw-id: //depot/perl@1445
---

diff --git a/objpp.h b/objpp.h
index 469fefc..d65a5b8 100644
--- a/objpp.h
+++ b/objpp.h
@@ -229,6 +229,8 @@
 #define dopoptoloop       CPerlObj::dopoptoloop
 #undef  dopoptosub
 #define dopoptosub        CPerlObj::dopoptosub
+#undef  dopoptosub_at
+#define dopoptosub_at     CPerlObj::dopoptosub_at
 #undef  dounwind
 #define dounwind          CPerlObj::Perl_dounwind
 #undef  do_aexec
diff --git a/pp_ctl.c b/pp_ctl.c
index 672e0e2..631de92 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -36,6 +36,7 @@ static I32 dopoptoeval _((I32 startingblock));
 static I32 dopoptolabel _((char *label));
 static I32 dopoptoloop _((I32 startingblock));
 static I32 dopoptosub _((I32 startingblock));
+static I32 dopoptosub_at _((PERL_CONTEXT *cxstk, I32 startingblock));
 static void save_lines _((AV *array, SV *sv));
 static I32 sortcv _((SV *a, SV *b));
 static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b)));
@@ -957,10 +958,17 @@ STATIC I32
 dopoptosub(I32 startingblock)
 {
     dTHR;
+    return dopoptosub_at(cxstack, startingblock);
+}
+
+STATIC I32
+dopoptosub_at(PERL_CONTEXT *cxstk, I32 startingblock)
+{
+    dTHR;
     I32 i;
     register PERL_CONTEXT *cx;
     for (i = startingblock; i >= 0; i--) {
-	cx = &cxstack[i];
+	cx = &cxstk[i];
 	switch (cx->cx_type) {
 	default:
 	    continue;
@@ -1165,6 +1173,8 @@ PP(pp_caller)
     djSP;
     register I32 cxix = dopoptosub(cxstack_ix);
     register PERL_CONTEXT *cx;
+    register PERL_CONTEXT *ccstack = cxstack;
+    PERL_SI *top_si = curstackinfo;
     I32 dbcxix;
     I32 gimme;
     HV *hv;
@@ -1175,25 +1185,32 @@ PP(pp_caller)
 	count = POPi;
     EXTEND(SP, 6);
     for (;;) {
+	/* we may be in a higher stacklevel, so dig down deeper */
+	while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
+	    top_si = top_si->si_prev;
+	    ccstack = top_si->si_cxstack;
+	    cxix = dopoptosub_at(ccstack, top_si->si_cxix);
+	}
 	if (cxix < 0) {
 	    if (GIMME != G_ARRAY)
 		RETPUSHUNDEF;
 	    RETURN;
 	}
 	if (DBsub && cxix >= 0 &&
-		cxstack[cxix].blk_sub.cv == GvCV(DBsub))
+		ccstack[cxix].blk_sub.cv == GvCV(DBsub))
 	    count++;
 	if (!count--)
 	    break;
-	cxix = dopoptosub(cxix - 1);
+	cxix = dopoptosub_at(ccstack, cxix - 1);
     }
-    cx = &cxstack[cxix];
-    if (cxstack[cxix].cx_type == CXt_SUB) {
-        dbcxix = dopoptosub(cxix - 1);
-	/* We expect that cxstack[dbcxix] is CXt_SUB, anyway, the
+
+    cx = &ccstack[cxix];
+    if (ccstack[cxix].cx_type == CXt_SUB) {
+        dbcxix = dopoptosub_at(ccstack, cxix - 1);
+	/* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
 	   field below is defined for any cx. */
-	if (DBsub && dbcxix >= 0 && cxstack[dbcxix].blk_sub.cv == GvCV(DBsub))
-	    cx = &cxstack[dbcxix];
+	if (DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(DBsub))
+	    cx = &ccstack[dbcxix];
     }
 
     if (GIMME != G_ARRAY) {
@@ -1217,9 +1234,9 @@ PP(pp_caller)
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line)));
     if (!MAXARG)
 	RETURN;
-    if (cx->cx_type == CXt_SUB) { /* So is cxstack[dbcxix]. */
+    if (cx->cx_type == CXt_SUB) { /* So is ccstack[dbcxix]. */
 	sv = NEWSV(49, 0);
-	gv_efullname3(sv, CvGV(cxstack[cxix].blk_sub.cv), Nullch);
+	gv_efullname3(sv, CvGV(ccstack[cxix].blk_sub.cv), Nullch);
 	PUSHs(sv_2mortal(sv));
 	PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
     }
diff --git a/proto.h b/proto.h
index 8599e02..ab57723 100644
--- a/proto.h
+++ b/proto.h
@@ -701,6 +701,7 @@ I32 dopoptoeval _((I32 startingblock));
 I32 dopoptolabel _((char *label));
 I32 dopoptoloop _((I32 startingblock));
 I32 dopoptosub _((I32 startingblock));
+I32 dopoptosub_at _((PERL_CONTEXT* cxstk, I32 startingblock));
 void save_lines _((AV *array, SV *sv));
 OP *doeval _((int gimme, OP** startop));
 SV *mul128 _((SV *sv, U8 m));
diff --git a/t/op/runlevel.t b/t/op/runlevel.t
index bff26e4..307e2a0 100755
--- a/t/op/runlevel.t
+++ b/t/op/runlevel.t
@@ -23,7 +23,7 @@ $tmpfile = "runltmp000";
 END { if ($tmpfile) { 1 while unlink $tmpfile; } }
 
 for (@prgs){
-    my $switch;
+    my $switch = "";
     if (s/^\s*(-\w+)//){
        $switch = $1;
     }
@@ -295,3 +295,23 @@ foo:
 END { print "foobar\n" }
 EXPECT
 foobar
+########
+$SIG{__DIE__} = sub {
+    print "In DIE\n";
+    $i = 0;
+    while (($p,$f,$l,$s) = caller(++$i)) {
+        print "$p|$f|$l|$s\n";
+    }
+};
+eval { die };
+&{sub { eval 'die' }}();
+sub foo { eval { die } } foo();
+EXPECT
+In DIE
+main|-|8|(eval)
+In DIE
+main|-|9|(eval)
+main|-|9|main::__ANON__
+In DIE
+main|-|10|(eval)
+main|-|10|main::foo