#define debprofdump Perl_debprofdump
#define debstack Perl_debstack
#define debstackptrs Perl_debstackptrs
+#define default_protect Perl_default_protect
#define delimcpy Perl_delimcpy
#define deprecate Perl_deprecate
#define die Perl_die
#define debprofdump CPerlObj::Perl_debprofdump
#define debstack CPerlObj::Perl_debstack
#define debstackptrs CPerlObj::Perl_debstackptrs
+#define default_protect CPerlObj::Perl_default_protect
#define del_he CPerlObj::Perl_del_he
#define del_sv CPerlObj::Perl_del_sv
#define del_xiv CPerlObj::Perl_del_xiv
debprofdump
debstack
debstackptrs
+default_protect
delimcpy
deprecate
die
#define PL_preprocess pPerl->PL_preprocess
#undef PL_profiledata
#define PL_profiledata pPerl->PL_profiledata
+#undef PL_protect
+#define PL_protect pPerl->PL_protect
#undef PL_reg_call_cc
#define PL_reg_call_cc pPerl->PL_reg_call_cc
#undef PL_reg_curpm
#define debstack pPerl->Perl_debstack
#undef debstackptrs
#define debstackptrs pPerl->Perl_debstackptrs
+#undef default_protect
+#define default_protect pPerl->Perl_default_protect
#undef del_he
#define del_he pPerl->Perl_del_he
#undef del_sv
static void init_debugger _((void));
static void init_lexer _((void));
static void init_main_stash _((void));
+static void *perl_parse_body _((va_list args));
+static void *perl_run_body _((va_list args));
+static void *perl_call_body _((va_list args));
+static void perl_call_xbody _((OP *myop, int is_eval));
+static void *call_list_body _((va_list args));
#ifdef USE_THREADS
static struct perl_thread * init_main_thread _((void));
#endif /* USE_THREADS */
thr = init_main_thread();
#endif /* USE_THREADS */
+ PL_protect = FUNC_NAME_TO_PTR(default_protect); /* for exceptions */
+
PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
PL_linestr = NEWSV(65,79);
init_ids();
PL_lex_state = LEX_NOTPARSING;
- PL_start_env.je_prev = NULL;
- PL_start_env.je_ret = -1;
- PL_start_env.je_mustcatch = TRUE;
- PL_top_env = &PL_start_env;
+ JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
SET_NUMERIC_STANDARD();
#endif
{
dTHR;
- register SV *sv;
- register char *s;
- char *scriptname = NULL;
- VOL bool dosearch = FALSE;
- char *validarg = "";
I32 oldscope;
- AV* comppadlist;
- dJMPENV;
int ret;
- int fdscript = -1;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
oldscope = PL_scopestack_ix;
PL_dowarn = G_WARN_OFF;
- JMPENV_PUSH(ret);
+ CALLPROTECT(&ret, perl_parse_body, env
+#ifndef PERL_OBJECT
+ , xsinit
+#endif
+ );
switch (ret) {
+ case 0:
+ return 0;
case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
PL_curstash = PL_defstash;
if (PL_endav)
call_list(oldscope, PL_endav);
- JMPENV_POP;
return STATUS_NATIVE_EXPORT;
case 3:
- JMPENV_POP;
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
return 1;
}
+}
+
+STATIC void *
+perl_parse_body(va_list args)
+{
+ dTHR;
+ int argc = PL_origargc;
+ char **argv = PL_origargv;
+ char **env = va_arg(args, char**);
+ char *scriptname = NULL;
+ int fdscript = -1;
+ VOL bool dosearch = FALSE;
+ char *validarg = "";
+ AV* comppadlist;
+ register SV *sv;
+ register char *s;
+
+#ifndef PERL_OBJECT
+ typedef void (*xs_init_t)(void);
+ xs_init_t xsinit = va_arg(args, xs_init_t);
+#endif
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
ENTER;
PL_restartop = 0;
- JMPENV_POP;
- return 0;
+ return NULL;
}
int
{
dTHR;
I32 oldscope;
- dJMPENV;
int ret;
#ifndef PERL_OBJECT
oldscope = PL_scopestack_ix;
- JMPENV_PUSH(ret);
+ redo_body:
+ CALLPROTECT(&ret, perl_run_body, oldscope);
switch (ret) {
case 1:
cxstack_ix = -1; /* start context stack again */
- break;
- case 2:
- /* my_exit() was called */
+ goto redo_body;
+ case 0: /* normal completion */
+ case 2: /* my_exit() */
while (PL_scopestack_ix > oldscope)
LEAVE;
FREETMPS;
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- JMPENV_POP;
return STATUS_NATIVE_EXPORT;
case 3:
- if (!PL_restartop) {
- PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
- FREETMPS;
- JMPENV_POP;
- return 1;
+ if (PL_restartop) {
+ POPSTACK_TO(PL_mainstack);
+ goto redo_body;
}
- POPSTACK_TO(PL_mainstack);
- break;
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ FREETMPS;
+ return 1;
}
+ /* NOTREACHED */
+ return 0;
+}
+
+STATIC void *
+perl_run_body(va_list args)
+{
+ dTHR;
+ I32 oldscope = va_arg(args, I32);
+
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
my_exit(0);
}
if (PERLDB_SINGLE && PL_DBsingle)
- sv_setiv(PL_DBsingle, 1);
+ sv_setiv(PL_DBsingle, 1);
if (PL_initav)
call_list(oldscope, PL_initav);
}
CALLRUNOPS();
}
- my_exit(0);
- /* NOTREACHED */
- return 0;
+ return NULL;
}
SV*
I32 retval;
I32 oldscope;
bool oldcatch = CATCH_GET;
- dJMPENV;
int ret;
OP* oldop = PL_op;
&& !(flags & G_NODEBUG))
PL_op->op_private |= OPpENTERSUB_DB;
- if (flags & G_EVAL) {
+ if (!(flags & G_EVAL)) {
+ CATCH_SET(TRUE);
+ perl_call_xbody((OP*)&myop, FALSE);
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ CATCH_SET(FALSE);
+ }
+ else {
cLOGOP->op_other = PL_op;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
}
PL_markstack_ptr++;
- JMPENV_PUSH(ret);
+ redo_body:
+ CALLPROTECT(&ret, perl_call_body, (OP*)&myop, FALSE);
switch (ret) {
case 0:
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if (!(flags & G_KEEPERR))
+ sv_setpv(ERRSV,"");
break;
case 1:
STATUS_ALL_FAILURE;
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
- JMPENV_POP;
if (PL_statusvalue)
croak("Callback called exit");
my_exit_jump();
if (PL_restartop) {
PL_op = PL_restartop;
PL_restartop = 0;
- break;
+ goto redo_body;
}
PL_stack_sp = PL_stack_base + oldmark;
if (flags & G_ARRAY)
retval = 1;
*++PL_stack_sp = &PL_sv_undef;
}
- goto cleanup;
+ break;
}
- }
- else
- CATCH_SET(TRUE);
- if (PL_op == (OP*)&myop)
- PL_op = pp_entersub(ARGS);
- if (PL_op)
- CALLRUNOPS();
- retval = PL_stack_sp - (PL_stack_base + oldmark);
- if ((flags & G_EVAL) && !(flags & G_KEEPERR))
- sv_setpv(ERRSV,"");
-
- cleanup:
- if (flags & G_EVAL) {
if (PL_scopestack_ix > oldscope) {
SV **newsp;
PMOP *newpm;
PL_curpm = newpm;
LEAVE;
}
- JMPENV_POP;
}
- else
- CATCH_SET(oldcatch);
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
return retval;
}
+STATIC void *
+perl_call_body(va_list args)
+{
+ OP *myop = va_arg(args, OP*);
+ int is_eval = va_arg(args, int);
+
+ perl_call_xbody(myop, is_eval);
+ return NULL;
+}
+
+STATIC void
+perl_call_xbody(OP *myop, int is_eval)
+{
+ dTHR;
+
+ if (PL_op == myop) {
+ if (is_eval)
+ PL_op = pp_entereval(ARGS);
+ else
+ PL_op = pp_entersub(ARGS);
+ }
+ if (PL_op)
+ CALLRUNOPS();
+}
+
/* Eval a string. The G_EVAL flag is always assumed. */
I32
I32 oldmark = SP - PL_stack_base;
I32 retval;
I32 oldscope;
- dJMPENV;
int ret;
OP* oldop = PL_op;
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
- JMPENV_PUSH(ret);
+ redo_body:
+ CALLPROTECT(&ret, perl_call_body, (OP*)&myop, TRUE);
switch (ret) {
case 0:
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if (!(flags & G_KEEPERR))
+ sv_setpv(ERRSV,"");
break;
case 1:
STATUS_ALL_FAILURE;
/* my_exit() was called */
PL_curstash = PL_defstash;
FREETMPS;
- JMPENV_POP;
if (PL_statusvalue)
croak("Callback called exit");
my_exit_jump();
if (PL_restartop) {
PL_op = PL_restartop;
PL_restartop = 0;
- break;
+ goto redo_body;
}
PL_stack_sp = PL_stack_base + oldmark;
if (flags & G_ARRAY)
retval = 1;
*++PL_stack_sp = &PL_sv_undef;
}
- goto cleanup;
+ break;
}
- if (PL_op == (OP*)&myop)
- PL_op = pp_entereval(ARGS);
- if (PL_op)
- CALLRUNOPS();
- retval = PL_stack_sp - (PL_stack_base + oldmark);
- if (!(flags & G_KEEPERR))
- sv_setpv(ERRSV,"");
-
- cleanup:
- JMPENV_POP;
if (flags & G_DISCARD) {
PL_stack_sp = PL_stack_base + oldmark;
retval = 0;
call_list(I32 oldscope, AV *paramList)
{
dTHR;
+ SV *atsv = ERRSV;
line_t oldline = PL_curcop->cop_line;
+ CV *cv;
STRLEN len;
- dJMPENV;
int ret;
while (AvFILL(paramList) >= 0) {
- CV *cv = (CV*)av_shift(paramList);
-
+ cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
-
- JMPENV_PUSH(ret);
+ CALLPROTECT(&ret, call_list_body, cv);
switch (ret) {
- case 0: {
- SV* atsv = ERRSV;
- PUSHMARK(PL_stack_sp);
- perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
- (void)SvPV(atsv, len);
- if (len) {
- JMPENV_POP;
- PL_curcop = &PL_compiling;
- PL_curcop->cop_line = oldline;
- if (paramList == PL_beginav)
- sv_catpv(atsv, "BEGIN failed--compilation aborted");
- else
- sv_catpv(atsv, "END failed--cleanup aborted");
- while (PL_scopestack_ix > oldscope)
- LEAVE;
- croak("%s", SvPVX(atsv));
- }
+ case 0:
+ (void)SvPV(atsv, len);
+ if (len) {
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ if (paramList == PL_beginav)
+ sv_catpv(atsv, "BEGIN failed--compilation aborted");
+ else
+ sv_catpv(atsv, "END failed--cleanup aborted");
+ while (PL_scopestack_ix > oldscope)
+ LEAVE;
+ croak("%s", SvPVX(atsv));
}
break;
case 1:
PL_curstash = PL_defstash;
if (PL_endav)
call_list(oldscope, PL_endav);
- JMPENV_POP;
PL_curcop = &PL_compiling;
PL_curcop->cop_line = oldline;
if (PL_statusvalue) {
my_exit_jump();
/* NOTREACHED */
case 3:
- if (!PL_restartop) {
- PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
- FREETMPS;
- break;
+ if (PL_restartop) {
+ PL_curcop = &PL_compiling;
+ PL_curcop->cop_line = oldline;
+ JMPENV_JUMP(3);
}
- JMPENV_POP;
- PL_curcop = &PL_compiling;
- PL_curcop->cop_line = oldline;
- JMPENV_JUMP(3);
+ PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+ FREETMPS;
+ break;
}
- JMPENV_POP;
}
}
+STATIC void *
+call_list_body(va_list args)
+{
+ dTHR;
+ CV *cv = va_arg(args, CV*);
+
+ PUSHMARK(PL_stack_sp);
+ perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
+ return NULL;
+}
+
void
my_exit(U32 status)
{
#define PERL_OBJECT_THIS this
#define _PERL_OBJECT_THIS ,this
#define PERL_OBJECT_THIS_ this,
-#define CALLRUNOPS (this->*PL_runops)
-#define CALLREGCOMP (this->*PL_regcompp)
-#define CALLREGEXEC (this->*PL_regexecp)
+#define CALL_FPTR(fptr) (this->*fptr)
#else /* !PERL_OBJECT */
#define PERL_OBJECT_THIS
#define _PERL_OBJECT_THIS
#define PERL_OBJECT_THIS_
-#define CALLRUNOPS (*PL_runops)
-#define CALLREGCOMP (*PL_regcompp)
-#define CALLREGEXEC (*PL_regexecp)
+#define CALL_FPTR(fptr) (*fptr)
#endif /* PERL_OBJECT */
+#define CALLRUNOPS CALL_FPTR(PL_runops)
+#define CALLREGCOMP CALL_FPTR(PL_regcompp)
+#define CALLREGEXEC CALL_FPTR(PL_regexecp)
+#define CALLPROTECT CALL_FPTR(PL_protect)
+
#define VOIDUSED 1
#include "config.h"
#define CALLOP this->*PL_op
#else
#define CALLOP *PL_op
+static void *docatch_body _((void *o));
static OP *docatch _((OP *o));
static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
static void doparseform _((SV *sv));
}
}
+STATIC void *
+docatch_body(va_list args)
+{
+ CALLRUNOPS();
+ return NULL;
+}
+
STATIC OP *
docatch(OP *o)
{
dTHR;
int ret;
OP *oldop = PL_op;
- dJMPENV;
- PL_op = o;
#ifdef DEBUGGING
assert(CATCH_GET == TRUE);
- DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env));
#endif
- JMPENV_PUSH(ret);
+ PL_op = o;
+ redo_body:
+ CALLPROTECT(&ret, docatch_body);
switch (ret) {
- default: /* topmost level handles it */
-pass_the_buck:
- JMPENV_POP;
+ case 0:
+ break;
+ case 3:
+ if (PL_restartop) {
+ PL_op = PL_restartop;
+ PL_restartop = 0;
+ goto redo_body;
+ }
+ /* FALL THROUGH */
+ default:
PL_op = oldop;
JMPENV_JUMP(ret);
/* NOTREACHED */
- case 3:
- if (!PL_restartop)
- goto pass_the_buck;
- PL_op = PL_restartop;
- PL_restartop = 0;
- /* FALL THROUGH */
- case 0:
- CALLRUNOPS();
- break;
}
- JMPENV_POP;
PL_op = oldop;
return Nullop;
}
SV* refto _((SV* sv));
U32 seed _((void));
OP *docatch _((OP *o));
+void *docatch_body _((va_list args));
+void *perl_parse_body _((va_list args));
+void *perl_run_body _((va_list args));
+void *perl_call_body _((va_list args));
+void perl_call_xbody _((OP *myop, int is_eval));
+void *call_list_body _((va_list args));
OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit));
void doparseform _((SV *sv));
I32 dopoptoeval _((I32 startingblock));
VIRTUAL void do_pmop_dump _((I32 level, PerlIO *file, PMOP *pm));
VIRTUAL void do_sv_dump _((I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bool dumpops, STRLEN pvlim));
VIRTUAL void magic_dump _((MAGIC *mg));
+VIRTUAL void* default_protect _((int *except, protect_body_t, ...));
VIRTUAL void reginitcolors _((void));
VIRTUAL char* sv_2pv_nolen _((SV* sv));
VIRTUAL char* sv_pv _((SV *sv));
#include "EXTERN.h"
#include "perl.h"
+void *
+default_protect(int *except, protect_body_t body, ...)
+{
+ dTHR;
+ dJMPENV;
+ va_list args;
+ int ex;
+ void *ret;
+
+ DEBUG_l(deb("Setting up local jumplevel %p, was %p\n",
+ &cur_env, PL_top_env));
+ JMPENV_PUSH(ex);
+ if (ex)
+ ret = NULL;
+ else {
+ va_start(args, body);
+ ret = body(args);
+ va_end(args);
+ }
+ *except = ex;
+ JMPENV_POP;
+ return ret;
+}
+
SV**
stack_grow(SV **sp, SV **p, int n)
{
struct jmpenv {
struct jmpenv * je_prev;
- Sigjmp_buf je_buf;
- int je_ret; /* return value of last setjmp() */
- bool je_mustcatch; /* longjmp()s must be caught locally */
+ Sigjmp_buf je_buf; /* only for use if !je_throw */
+ int je_ret; /* last exception thrown */
+ bool je_mustcatch; /* need to call longjmp()? */
+ void (*je_throw)(int v); /* last for bincompat */
};
typedef struct jmpenv JMPENV;
+/*
+ * Function that catches/throws, and its callback for the
+ * body of protected processing.
+ */
+typedef void *(CPERLscope(*protect_body_t)) _((va_list args));
+typedef void *(CPERLscope(*protect_proc_t))
+ _((int *except, protect_body_t, ...));
+
+/*
+ * How to build the first jmpenv.
+ *
+ * top_env needs to be non-zero. It points to an area
+ * in which longjmp() stuff is stored, as C callstack
+ * info there at least is thread specific this has to
+ * be per-thread. Otherwise a 'die' in a thread gives
+ * that thread the C stack of last thread to do an eval {}!
+ */
+
+#define JMPENV_BOOTSTRAP \
+ STMT_START { \
+ PL_start_env.je_prev = NULL; \
+ PL_start_env.je_throw = NULL; \
+ PL_start_env.je_ret = -1; \
+ PL_start_env.je_mustcatch = TRUE; \
+ PL_top_env = &PL_start_env; \
+ } STMT_END
+
#ifdef OP_IN_REGISTER
#define OP_REG_TO_MEM PL_opsave = op
#define OP_MEM_TO_REG op = PL_opsave
#define OP_MEM_TO_REG NOOP
#endif
+/*
+ * These exception-handling macros are split up to
+ * ease integration with C++ exceptions.
+ *
+ * To use C++ try+catch to catch Perl exceptions, an extension author
+ * needs to first write an extern "C" function to throw an appropriate
+ * exception object; typically it will be or contain an integer,
+ * because Perl's internals use integers to track exception types:
+ * extern "C" { static void thrower(int i) { throw i; } }
+ *
+ * Then (as shown below) the author needs to use, not the simple
+ * JMPENV_PUSH, but several of its constitutent macros, to arrange for
+ * the Perl internals to call thrower() rather than longjmp() to
+ * report exceptions:
+ *
+ * dJMPENV;
+ * JMPENV_PUSH_INIT(thrower);
+ * try {
+ * ... stuff that may throw exceptions ...
+ * }
+ * catch (int why) { // or whatever matches thrower()
+ * JMPENV_POST_CATCH;
+ * EXCEPT_SET(why);
+ * switch (why) {
+ * ... // handle various Perl exception codes
+ * }
+ * }
+ * JMPENV_POP; // don't forget this!
+ */
+
#define dJMPENV JMPENV cur_env
-#define JMPENV_PUSH(v) \
+
+#define JMPENV_PUSH_INIT(THROWFUNC) \
STMT_START { \
+ cur_env.je_throw = (THROWFUNC); \
+ cur_env.je_ret = -1; \
+ cur_env.je_mustcatch = FALSE; \
cur_env.je_prev = PL_top_env; \
+ PL_top_env = &cur_env; \
OP_REG_TO_MEM; \
- cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1); \
+ } STMT_END
+#define JMPENV_POST_CATCH \
+ STMT_START { \
OP_MEM_TO_REG; \
PL_top_env = &cur_env; \
- cur_env.je_mustcatch = FALSE; \
- (v) = cur_env.je_ret; \
} STMT_END
+
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ JMPENV_PUSH_INIT(NULL); \
+ EXCEPT_SET(PerlProc_setjmp(cur_env.je_buf, 1)); \
+ JMPENV_POST_CATCH; \
+ (v) = EXCEPT_GET; \
+ } STMT_END
+
#define JMPENV_POP \
STMT_START { PL_top_env = cur_env.je_prev; } STMT_END
+
#define JMPENV_JUMP(v) \
STMT_START { \
OP_REG_TO_MEM; \
- if (PL_top_env->je_prev) \
- PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ if (PL_top_env->je_prev) { \
+ if (PL_top_env->je_throw) \
+ PL_top_env->je_throw(v); \
+ else \
+ PerlProc_longjmp(PL_top_env->je_buf, (v)); \
+ } \
if ((v) == 2) \
- PerlProc_exit(STATUS_NATIVE_EXPORT); \
+ PerlProc_exit(STATUS_NATIVE_EXPORT); \
PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
- PerlProc_exit(1); \
+ PerlProc_exit(1); \
} STMT_END
-
+
+#define EXCEPT_GET (cur_env.je_ret)
+#define EXCEPT_SET(v) (cur_env.je_ret = (v))
+
#define CATCH_GET (PL_top_env->je_mustcatch)
#define CATCH_SET(v) (PL_top_env->je_mustcatch = (v))
PERLVAR(Tcurstack, AV *) /* THE STACK */
PERLVAR(Tcurstackinfo, PERL_SI *) /* current stack + context */
PERLVAR(Tmainstack, AV *) /* the stack when nothing funny is happening */
+
PERLVAR(Ttop_env, JMPENV *) /* ptr. to current sigjmp() environment */
PERLVAR(Tstart_env, JMPENV) /* empty startup sigjmp() environment */
+PERLVARI(Tprotect, protect_proc_t, FUNC_NAME_TO_PTR(default_protect))
/* statics "owned" by various functions */
PERLVAR(Tav_fetch_sv, SV *) /* owned by av_fetch() */
Zero(thr, 1, struct perl_thread);
#endif
+ PL_protect = FUNC_NAME_TO_PTR(default_protect);
+
thr->oursv = sv;
init_stacks(ARGS);
/* parent thread's data needs to be locked while we make copy */
MUTEX_LOCK(&t->mutex);
+ PL_protect = t->Tprotect;
+
PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */
PL_defstash = t->Tdefstash; /* XXX maybe these should */
PL_curstash = t->Tcurstash; /* always be set to main? */
projects / p5sagit/p5-mst-13.2.git / commitdiff