fix pp_caller() to fully traverse stacklevels

p4raw-id: //depot/perl@1445

diff --git a/objpp.h b/objpp.h
index 469fefc..d65a5b8 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (executable)
--- 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