[perl #120998] avoid caller() crashing on eval '' stack frames

Starting from v5.17.3-150-g19bcb54e caller() on an eval frame would
end up calling Perl_sv_grow() with newlen = 0xFFFFFFFF on 32-bit
systems.

This eventually started segfaulting with v5.19.0-442-gcbcb2a1 which
added code to round up allocations to the nearest 0x100, setting
newlen to 0, faulting when sv_setpvn() attempted to copy its source
string into the zero space provided.

diff --git a/pp_ctl.c b/pp_ctl.c
index e13e450..380a7fe 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1847,9 +1847,16 @@ PP(pp_caller)
     if (CxTYPE(cx) == CXt_EVAL) {
        /* eval STRING */
        if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
-           PUSHs(newSVpvn_flags(SvPVX(cx->blk_eval.cur_text),
-                                SvCUR(cx->blk_eval.cur_text)-2,
-                                SvUTF8(cx->blk_eval.cur_text)|SVs_TEMP));
+            SV *cur_text = cx->blk_eval.cur_text;
+            if (SvCUR(cur_text) >= 2) {
+                PUSHs(newSVpvn_flags(SvPVX(cur_text), SvCUR(cur_text)-2,
+                                     SvUTF8(cur_text)|SVs_TEMP));
+            }
+            else {
+                /* I think this is will always be "", but be sure */
+                PUSHs(sv_2mortal(newSVsv(cur_text)));
+            }
+
            PUSHs(&PL_sv_no);
        }
        /* require */

diff --git a/t/op/caller.t b/t/op/caller.t
index 61a3816..54a6bac 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 => 94 );
+    plan( tests => 95 );
 }
 
 my @c;
@@ -318,6 +318,18 @@ sub doof { caller(0) }
 print +(doof())[3];
 END
     "caller should not SEGV when the current package is undefined";
+
+# caller should not SEGV when the eval entry has been cleared #120998
+fresh_perl_is <<'END', 'main', {},
+$SIG{__DIE__} = \&dbdie;
+eval '/x';
+sub dbdie {
+    @x = caller(1);
+    print $x[0];
+}
+END
+    "caller should not SEGV for eval '' stack frames";
+
 $::testing_caller = 1;
 
 do './op/caller.pl' or die $@;