In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/78beb4ca6d139a7188817b2d3f61702d5cfd5365?hp=78269f095bc831a3ca7c226f93a5bba93565dfad>
- Log -----------------------------------------------------------------
commit 78beb4ca6d139a7188817b2d3f61702d5cfd5365
Author: Tony Cook <t...@develop-help.com>
Date: Tue Apr 8 11:12:38 2014 +1000
[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.
-----------------------------------------------------------------------
Summary of changes:
pp_ctl.c | 13 ++++++++++---
t/op/caller.t | 14 +++++++++++++-
2 files changed, 23 insertions(+), 4 deletions(-)
diff --git a/pp_ctl.c b/pp_ctl.c
index e13e450..380a7fe 100644
--- 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
--- 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 $@;
--
Perl5 Master Repository
