keep eval"" CVs alive until the end of the statement in which

they're called; this avoids a coredump ensuing from search for
lexicals in code such as:

    sub bug {
	my $s = @_;
	eval q[sub { eval 'sub { &$s }' }];
    }
    bug("x")->()->();

this code still doesn't work as intended (as it has remained
since time immemorial), but it doesn't provoke a coredump anymore

p4raw-id: //depot/maint-5.6/perl@9584

11 files changed, 48 insertions, 3 deletions

diff --git a/embed.h b/embed.h
index 90e13cbf5b..78fa0890bd 100644
--- a/embed.h
+++ b/embed.h
@@ -592,6 +592,7 @@
 #define save_iv			Perl_save_iv
 #define save_list		Perl_save_list
 #define save_long		Perl_save_long
+#define save_mortalizesv	Perl_save_mortalizesv
 #define save_nogv		Perl_save_nogv
 #define save_op			Perl_save_op
 #define save_scalar		Perl_save_scalar
@@ -2059,6 +2060,7 @@
 #define save_iv(a)		Perl_save_iv(aTHX_ a)
 #define save_list(a,b)		Perl_save_list(aTHX_ a,b)
 #define save_long(a)		Perl_save_long(aTHX_ a)
+#define save_mortalizesv(a)	Perl_save_mortalizesv(aTHX_ a)
 #define save_nogv(a)		Perl_save_nogv(aTHX_ a)
 #define save_op()		Perl_save_op(aTHX)
 #define save_scalar(a)		Perl_save_scalar(aTHX_ a)
@@ -4035,6 +4037,8 @@
 #define save_list		Perl_save_list
 #define Perl_save_long		CPerlObj::Perl_save_long
 #define save_long		Perl_save_long
+#define Perl_save_mortalizesv	CPerlObj::Perl_save_mortalizesv
+#define save_mortalizesv	Perl_save_mortalizesv
 #define Perl_save_nogv		CPerlObj::Perl_save_nogv
 #define save_nogv		Perl_save_nogv
 #define Perl_save_op		CPerlObj::Perl_save_op
diff --git a/embed.pl b/embed.pl
index cd8acca74b..2b0f2aabfe 100755
--- a/embed.pl
+++ b/embed.pl
@@ -1940,6 +1940,7 @@ Ap	|void	|save_item	|SV* item
 Ap	|void	|save_iv	|IV* iv
 Ap	|void	|save_list	|SV** sarg|I32 maxsarg
 Ap	|void	|save_long	|long* longp
+Ap	|void	|save_mortalizesv|SV* sv
 Ap	|void	|save_nogv	|GV* gv
 p	|void	|save_op
 Ap	|SV*	|save_scalar	|GV* gv
diff --git a/global.sym b/global.sym
index 7d070d3e23..2028723a61 100644
--- a/global.sym
+++ b/global.sym
@@ -354,6 +354,7 @@ Perl_save_item
 Perl_save_iv
 Perl_save_list
 Perl_save_long
+Perl_save_mortalizesv
 Perl_save_nogv
 Perl_save_scalar
 Perl_save_pptr
diff --git a/objXSUB.h b/objXSUB.h
index 1b7e55836d..d4ba2a22a9 100644
--- a/objXSUB.h
+++ b/objXSUB.h
@@ -1417,6 +1417,10 @@
 #define Perl_save_long		pPerl->Perl_save_long
 #undef  save_long
 #define save_long		Perl_save_long
+#undef  Perl_save_mortalizesv
+#define Perl_save_mortalizesv	pPerl->Perl_save_mortalizesv
+#undef  save_mortalizesv
+#define save_mortalizesv	Perl_save_mortalizesv
 #undef  Perl_save_nogv
 #define Perl_save_nogv		pPerl->Perl_save_nogv
 #undef  save_nogv
diff --git a/perlapi.c b/perlapi.c
index fc912bb9c5..5fc0c4d767 100644
--- a/perlapi.c
+++ b/perlapi.c
@@ -2582,6 +2582,13 @@ Perl_save_long(pTHXo_ long* longp)
     ((CPerlObj*)pPerl)->Perl_save_long(longp);
 }
 
+#undef  Perl_save_mortalizesv
+void
+Perl_save_mortalizesv(pTHXo_ SV* sv)
+{
+    ((CPerlObj*)pPerl)->Perl_save_mortalizesv(sv);
+}
+
 #undef  Perl_save_nogv
 void
 Perl_save_nogv(pTHXo_ GV* gv)
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index 3518df9edc..9993cc114e 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -1126,8 +1126,20 @@ and back.
 =item C<SAVEFREESV(SV *sv)>
 
 The refcount of C<sv> would be decremented at the end of
-I<pseudo-block>. This is similar to C<sv_2mortal>, which should (?) be
-used instead.
+I<pseudo-block>.  This is similar to C<sv_2mortal> in that it is also a
+mechanism for doing a delayed C<SvREFCNT_dec>.  However, while C<sv_2mortal>
+extends the lifetime of C<sv> until the beginning of the next statement,
+C<SAVEFREESV> extends it until the end of the enclosing scope.  These
+lifetimes can be wildly different.
+
+Also compare C<SAVEMORTALIZESV>.
+
+=item C<SAVEMORTALIZESV(SV *sv)>
+
+Just like C<SAVEFREESV>, but mortalizes C<sv> at the end of the current
+scope instead of decrementing its reference count.  This usually has the
+effect of keeping C<sv> alive until the statement that called the currently
+live scope has finished executing.
 
 =item C<SAVEFREEOP(OP *op)>
 
diff --git a/pp_ctl.c b/pp_ctl.c
index 31cfcd4478..b26706019a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2790,7 +2790,7 @@ S_doeval(pTHX_ int gimme, OP** startop)
 	CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
     }
 
-    SAVEFREESV(PL_compcv);
+    SAVEMORTALIZESV(PL_compcv);	/* must remain until end of current statement */
 
     /* make sure we compile in the right package */
 
diff --git a/proto.h b/proto.h
index d343e62f6a..879495195d 100644
--- a/proto.h
+++ b/proto.h
@@ -668,6 +668,7 @@ PERL_CALLCONV void	Perl_save_item(pTHX_ SV* item);
 PERL_CALLCONV void	Perl_save_iv(pTHX_ IV* iv);
 PERL_CALLCONV void	Perl_save_list(pTHX_ SV** sarg, I32 maxsarg);
 PERL_CALLCONV void	Perl_save_long(pTHX_ long* longp);
+PERL_CALLCONV void	Perl_save_mortalizesv(pTHX_ SV* sv);
 PERL_CALLCONV void	Perl_save_nogv(pTHX_ GV* gv);
 PERL_CALLCONV void	Perl_save_op(pTHX);
 PERL_CALLCONV SV*	Perl_save_scalar(pTHX_ GV* gv);
diff --git a/scope.c b/scope.c
index d449ad9247..bb4143b079 100644
--- a/scope.c
+++ b/scope.c
@@ -504,6 +504,14 @@ Perl_save_freesv(pTHX_ SV *sv)
 }
 
 void
+Perl_save_mortalizesv(pTHX_ SV *sv)
+{
+    SSCHECK(2);
+    SSPUSHPTR(sv);
+    SSPUSHINT(SAVEt_MORTALIZESV);
+}
+
+void
 Perl_save_freeop(pTHX_ OP *o)
 {
     SSCHECK(2);
@@ -803,6 +811,10 @@ Perl_leave_scope(pTHX_ I32 base)
 	    ptr = SSPOPPTR;
 	    SvREFCNT_dec((SV*)ptr);
 	    break;
+	case SAVEt_MORTALIZESV:
+	    ptr = SSPOPPTR;
+	    sv_2mortal((SV*)ptr);
+	    break;
 	case SAVEt_FREEOP:
 	    ptr = SSPOPPTR;
 	    if (PL_comppad)
diff --git a/scope.h b/scope.h
index 3e05962e68..798304d0e1 100644
--- a/scope.h
+++ b/scope.h
@@ -34,6 +34,7 @@
 #define SAVEt_COMPPAD		33
 #define SAVEt_GENERIC_PVREF	34
 #define SAVEt_PADSV		35
+#define SAVEt_MORTALIZESV	36
 
 #define SSCHECK(need) if (PL_savestack_ix + need > PL_savestack_max) savestack_grow()
 #define SSPUSHINT(i) (PL_savestack[PL_savestack_ix++].any_i32 = (I32)(i))
@@ -104,6 +105,7 @@ Closing bracket on a callback.  See C<ENTER> and L<perlcall>.
 #define SAVEVPTR(s)	save_vptr((void*)&(s))
 #define SAVEPADSV(s)	save_padsv(s)
 #define SAVEFREESV(s)	save_freesv((SV*)(s))
+#define SAVEMORTALIZESV(s)	save_mortalizesv((SV*)(s))
 #define SAVEFREEOP(o)	save_freeop(SOFT_CAST(OP*)(o))
 #define SAVEFREEPV(p)	save_freepv(SOFT_CAST(char*)(p))
 #define SAVECLEARSV(sv)	save_clearsv(SOFT_CAST(SV**)&(sv))
diff --git a/sv.c b/sv.c
index 316c1b34e8..7b8263b601 100644
--- a/sv.c
+++ b/sv.c
@@ -7548,6 +7548,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
 	    TOPIV(nss,ix) = iv;
             break;
 	case SAVEt_FREESV:
+	case SAVEt_MORTALIZESV:
 	    sv = (SV*)POPPTR(ss,ix);
 	    TOPPTR(nss,ix) = sv_dup_inc(sv);
 	    break;