From: Nicholas Clark <nick@ccl4.org>
Date: Mon, 27 Mar 2006 21:04:58 +0000 (+0000)
Subject: Merge the cut & paste code from Perl_call_sv/Perl_fold_constants with
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=edb2152a8435aa2e1308442c03e82c10e128574e;p=p5sagit%2Fp5-mst-13.2.git
Merge the cut & paste code from Perl_call_sv/Perl_fold_constants with
the near identical code in pp_entertry into Perl_create_eval_scope.
Move the cut & paste code from Perl_call_sv/Perl_fold_constants into
Perl_delete_eval_scope.
p4raw-id: //depot/perl@27617
---
diff --git a/cop.h b/cop.h
index ef92d8e..359a427 100644
--- a/cop.h
+++ b/cop.h
@@ -646,6 +646,8 @@ L<perlcall>.
#define G_KEEPERR 16 /* Append errors to $@, don't overwrite it */
#define G_NODEBUG 32 /* Disable debugging at toplevel. */
#define G_METHOD 64 /* Calling method. */
+#define G_FAKINGEVAL 256 /* Faking en eval context for call_sv or
+ fold_constants. */
/* flag bits for PL_in_eval */
#define EVAL_NULL 0 /* not in an eval */
diff --git a/embed.fnc b/embed.fnc
index a124e20..d74193e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -129,6 +129,7 @@ ApR |UV |cast_uv |NV f
ApR |I32 |my_chsize |int fd|Off_t length
#endif
pR |OP* |convert |I32 optype|I32 flags|NULLOK OP* o
+pM |PERL_CONTEXT* |create_eval_scope|U32 flags
: croak()'s first parm can be NULL. Otherwise, mod_perl breaks.
Afprd |void |croak |NULLOK const char* pat|...
Apr |void |vcroak |NN const char* pat|NULLOK va_list* args
@@ -173,6 +174,7 @@ Ap |I32 |debstack
Ap |I32 |debstackptrs
Ap |char* |delimcpy |NN char* to|NN const char* toend|NN const char* from \
|NN const char* fromend|int delim|NN I32* retlen
+pM |void |delete_eval_scope
p |void |deprecate |NN const char* s
p |void |deprecate_old |NN const char* s
Afp |OP* |die |NULLOK const char* pat|...
diff --git a/embed.h b/embed.h
index 93dda39..d6b9bfa 100644
--- a/embed.h
+++ b/embed.h
@@ -94,6 +94,7 @@
#endif
#ifdef PERL_CORE
#define convert Perl_convert
+#define create_eval_scope Perl_create_eval_scope
#endif
#define croak Perl_croak
#define vcroak Perl_vcroak
@@ -146,6 +147,7 @@
#define debstackptrs Perl_debstackptrs
#define delimcpy Perl_delimcpy
#ifdef PERL_CORE
+#define delete_eval_scope Perl_delete_eval_scope
#define deprecate Perl_deprecate
#define deprecate_old Perl_deprecate_old
#endif
@@ -2272,6 +2274,7 @@
#endif
#ifdef PERL_CORE
#define convert(a,b,c) Perl_convert(aTHX_ a,b,c)
+#define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a)
#endif
#define vcroak(a,b) Perl_vcroak(aTHX_ a,b)
#if defined(PERL_IMPLICIT_CONTEXT)
@@ -2307,6 +2310,7 @@
#define debstackptrs() Perl_debstackptrs(aTHX)
#define delimcpy(a,b,c,d,e,f) Perl_delimcpy(aTHX_ a,b,c,d,e,f)
#ifdef PERL_CORE
+#define delete_eval_scope() Perl_delete_eval_scope(aTHX)
#define deprecate(a) Perl_deprecate(aTHX_ a)
#define deprecate_old(a) Perl_deprecate_old(aTHX_ a)
#endif
diff --git a/ext/B/t/concise-xs.t b/ext/B/t/concise-xs.t
index dcd868f..9a69030 100644
--- a/ext/B/t/concise-xs.t
+++ b/ext/B/t/concise-xs.t
@@ -117,7 +117,7 @@ use Getopt::Std;
use Carp;
use Test::More tests => ( # per-pkg tests (function ct + require_ok)
40 + 16 # Data::Dumper, Digest::MD5
- + 511 + 234 # B::Deparse, B
+ + 511 + 235 # B::Deparse, B
+ 588 + 189 # POSIX, IO::Socket
+ 3 * ($] > 5.009)
+ 14 * ($] >= 5.009003)
diff --git a/op.c b/op.c
index 1fd94c2..ef05f5b 100644
--- a/op.c
+++ b/op.c
@@ -2183,22 +2183,8 @@ Perl_fold_constants(pTHX_ register OP *o)
PL_op = curop;
oldscope = PL_scopestack_ix;
+ create_eval_scope(G_FAKINGEVAL);
- /* we're trying to emulate pp_entertry() here */
- {
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
-
- ENTER;
- SAVETMPS;
-
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
- PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
-
- PL_in_eval = EVAL_INEVAL;
- sv_setpvn(ERRSV,"",0);
- }
JMPENV_PUSH(ret);
switch (ret) {
@@ -2225,21 +2211,9 @@ Perl_fold_constants(pTHX_ register OP *o)
}
JMPENV_POP;
- if (PL_scopestack_ix > oldscope) {
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- I32 optype;
-
- POPBLOCK(cx,newpm);
- POPEVAL(cx);
- PL_curpm = newpm;
- LEAVE;
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
- PERL_UNUSED_VAR(optype);
- }
+
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
if (ret)
goto nope;
diff --git a/perl.c b/perl.c
index a98314b..7e0f842 100644
--- a/perl.c
+++ b/perl.c
@@ -2604,27 +2604,11 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
else {
myop.op_other = (OP*)&myop;
PL_markstack_ptr--;
- /* we're trying to emulate pp_entertry() here */
- {
- register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
-
- ENTER;
- SAVETMPS;
-
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
- PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
-
- PL_in_eval = EVAL_INEVAL;
- if (flags & G_KEEPERR)
- PL_in_eval |= EVAL_KEEPERR;
- else
- sv_setpvn(ERRSV,"",0);
- }
+ create_eval_scope(flags|G_FAKINGEVAL);
PL_markstack_ptr++;
JMPENV_PUSH(ret);
+
switch (ret) {
case 0:
redo_body:
@@ -2661,21 +2645,8 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
break;
}
- if (PL_scopestack_ix > oldscope) {
- SV **newsp;
- PMOP *newpm;
- I32 gimme;
- register PERL_CONTEXT *cx;
- I32 optype;
-
- POPBLOCK(cx,newpm);
- POPEVAL(cx);
- PL_curpm = newpm;
- LEAVE;
- PERL_UNUSED_VAR(newsp);
- PERL_UNUSED_VAR(gimme);
- PERL_UNUSED_VAR(optype);
- }
+ if (PL_scopestack_ix > oldscope)
+ delete_eval_scope();
JMPENV_POP;
}
diff --git a/pp_ctl.c b/pp_ctl.c
index 87a383d..c0e3a09 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3562,22 +3562,57 @@ PP(pp_leaveeval)
RETURNOP(retop);
}
-PP(pp_entertry)
+/* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
+ close to the related Perl_create_eval_scope. */
+void
+Perl_delete_eval_scope(pTHX)
{
- dVAR; dSP;
+ SV **newsp;
+ PMOP *newpm;
+ I32 gimme;
register PERL_CONTEXT *cx;
- const I32 gimme = GIMME_V;
+ I32 optype;
+
+ POPBLOCK(cx,newpm);
+ POPEVAL(cx);
+ PL_curpm = newpm;
+ LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
+}
+/* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
+ also needed by Perl_fold_constants. */
+PERL_CONTEXT *
+Perl_create_eval_scope(pTHX_ U32 flags)
+{
+ PERL_CONTEXT *cx;
+ const I32 gimme = GIMME_V;
+
ENTER;
SAVETMPS;
- PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
+ PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
- cx->blk_eval.retop = cLOGOP->op_other->op_next;
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
PL_in_eval = EVAL_INEVAL;
- sv_setpvn(ERRSV,"",0);
- PUTBACK;
+ if (flags & G_KEEPERR)
+ PL_in_eval |= EVAL_KEEPERR;
+ else
+ sv_setpvn(ERRSV,"",0);
+ if (flags & G_FAKINGEVAL) {
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
+ }
+ return cx;
+}
+
+PP(pp_entertry)
+{
+ dVAR;
+ PERL_CONTEXT *cx = create_eval_scope(0);
+ cx->blk_eval.retop = cLOGOP->op_other->op_next;
return DOCATCH(PL_op->op_next);
}
diff --git a/proto.h b/proto.h
index eb996cb..528bcf6 100644
--- a/proto.h
+++ b/proto.h
@@ -224,6 +224,7 @@ PERL_CALLCONV I32 Perl_my_chsize(pTHX_ int fd, Off_t length)
PERL_CALLCONV OP* Perl_convert(pTHX_ I32 optype, I32 flags, OP* o)
__attribute__warn_unused_result__;
+PERL_CALLCONV PERL_CONTEXT* Perl_create_eval_scope(pTHX_ U32 flags);
PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...)
__attribute__noreturn__
__attribute__format__(__printf__,pTHX_1,pTHX_2);
@@ -373,6 +374,7 @@ PERL_CALLCONV char* Perl_delimcpy(pTHX_ char* to, const char* toend, const char*
__attribute__nonnull__(pTHX_4)
__attribute__nonnull__(pTHX_6);
+PERL_CALLCONV void Perl_delete_eval_scope(pTHX);
PERL_CALLCONV void Perl_deprecate(pTHX_ const char* s)
__attribute__nonnull__(pTHX_1);