init_ids();
lex_state = LEX_NOTPARSING;
- start_env.je_prev = NULL;
- start_env.je_ret = -1;
- start_env.je_mustcatch = TRUE;
- top_env = &start_env;
+ install_tryblock_method(0); /* default to set/longjmp style tryblock */
+ JMPENV_TOPINIT(start_env);
STATUS_ALL_SUCCESS;
SET_NUMERIC_STANDARD();
++exitlistlen;
}
+struct try_parse_locals {
+ void (*xsinit)();
+ int argc;
+ char **argv;
+ char **env;
+ I32 oldscope;
+ int ret;
+};
+typedef struct try_parse_locals TRY_PARSE_LOCALS;
+static TRYVTBL PerlParseVtbl;
+
int
#ifdef PERL_OBJECT
CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
#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;
+ TRY_PARSE_LOCALS locals;
+ locals.xsinit = xsinit;
+ locals.argc = argc;
+ locals.argv = argv;
+ locals.env = env;
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
main_cv = Nullcv;
time(&basetime);
- oldscope = scopestack_ix;
+ locals.oldscope = scopestack_ix;
- JMPENV_PUSH(ret);
- switch (ret) {
- case 1:
- STATUS_ALL_FAILURE;
- /* FALL THROUGH */
- case 2:
- /* my_exit() was called */
- while (scopestack_ix > oldscope)
- LEAVE;
- FREETMPS;
- curstash = defstash;
- if (endav)
- call_list(oldscope, endav);
- JMPENV_POP;
- return STATUS_NATIVE_EXPORT;
- case 3:
- JMPENV_POP;
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
- return 1;
- }
+ TRYBLOCK(PerlParseVtbl, locals);
+ return locals.ret;
+}
- sv_setpvn(linestr,"",0);
- sv = newSVpv("",0); /* first used for -I flags */
- SAVEFREESV(sv);
- init_main_stash();
+struct try_run_locals {
+ I32 oldscope;
+ int ret;
+};
+typedef struct try_run_locals TRY_RUN_LOCALS;
+static TRYVTBL PerlRunVtbl;
- for (argc--,argv++; argc > 0; argc--,argv++) {
- if (argv[0][0] != '-' || !argv[0][1])
- break;
-#ifdef DOSUID
- if (*validarg)
- validarg = " PHOOEY ";
- else
- validarg = argv[0];
+int
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
#endif
- s = argv[0]+1;
- reswitch:
- switch (*s) {
- case ' ':
- case '0':
- case 'F':
- case 'a':
- case 'c':
- case 'd':
- case 'D':
- case 'h':
- case 'i':
- case 'l':
- case 'M':
- case 'm':
- case 'n':
- case 'p':
- case 's':
- case 'u':
- case 'U':
- case 'v':
- case 'w':
- if (s = moreswitches(s))
- goto reswitch;
- break;
+{
+ dTHR;
+ TRY_RUN_LOCALS locals;
- case 'T':
- tainting = TRUE;
- s++;
- goto reswitch;
+#ifndef PERL_OBJECT
+ if (!(curinterp = sv_interp))
+ return 255;
+#endif
- case 'e':
- if (euid != uid || egid != gid)
- croak("No -e allowed in setuid scripts");
- if (!e_script) {
- e_script = newSVpv("",0);
- filter_add(read_e_script, NULL);
- }
- if (*++s)
- sv_catpv(e_script, s);
- else if (argv[1]) {
- sv_catpv(e_script, argv[1]);
- argc--,argv++;
- }
- else
- croak("No code specified for -e");
- sv_catpv(e_script, "\n");
- break;
+ locals.oldscope = scopestack_ix;
+ TRYBLOCK(PerlRunVtbl, locals);
+ return locals.ret;
+}
- case 'I': /* -I handled both here and in moreswitches() */
- forbid_setid("-I");
- if (!*++s && (s=argv[1]) != Nullch) {
- argc--,argv++;
- }
- while (s && isSPACE(*s))
- ++s;
- if (s && *s) {
- char *e, *p;
- for (e = s; *e && !isSPACE(*e); e++) ;
- p = savepvn(s, e-s);
- incpush(p, TRUE);
- sv_catpv(sv,"-I");
- sv_catpv(sv,p);
- sv_catpv(sv," ");
- Safefree(p);
- } /* XXX else croak? */
- break;
- case 'P':
- forbid_setid("-P");
- preprocess = TRUE;
- s++;
- goto reswitch;
- case 'S':
- forbid_setid("-S");
- dosearch = TRUE;
- s++;
- goto reswitch;
- case 'V':
- if (!preambleav)
- preambleav = newAV();
- av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
- if (*++s != ':') {
- Sv = newSVpv("print myconfig();",0);
-#ifdef VMS
- sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
-#else
- sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
-#endif
-#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
- sv_catpv(Sv,"\" Compile-time options:");
-# ifdef DEBUGGING
- sv_catpv(Sv," DEBUGGING");
-# endif
-# ifdef NO_EMBED
- sv_catpv(Sv," NO_EMBED");
-# endif
-# ifdef MULTIPLICITY
- sv_catpv(Sv," MULTIPLICITY");
-# endif
- sv_catpv(Sv,"\\n\",");
-#endif
-#if defined(LOCAL_PATCH_COUNT)
- if (LOCAL_PATCH_COUNT > 0) {
- int i;
- sv_catpv(Sv,"\" Locally applied patches:\\n\",");
- for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
- if (localpatches[i])
- sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
- }
- }
-#endif
- sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
-#ifdef __DATE__
-# ifdef __TIME__
- sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
-# else
- sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
-# endif
-#endif
- sv_catpv(Sv, "; \
-$\"=\"\\n \"; \
-@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
-print \" \\%ENV:\\n @env\\n\" if @env; \
-print \" \\@INC:\\n @INC\\n\";");
- }
- else {
- Sv = newSVpv("config_vars(qw(",0);
- sv_catpv(Sv, ++s);
- sv_catpv(Sv, "))");
- s += strlen(s);
- }
- av_push(preambleav, Sv);
- scriptname = BIT_BUCKET; /* don't look for script or read stdin */
- goto reswitch;
- case 'x':
- doextract = TRUE;
- s++;
- if (*s)
- cddir = savepv(s);
- break;
- case 0:
- break;
- case '-':
- if (!*++s || isSPACE(*s)) {
- argc--,argv++;
- goto switch_end;
- }
- /* catch use of gnu style long options */
- if (strEQ(s, "version")) {
- s = "v";
- goto reswitch;
- }
- if (strEQ(s, "help")) {
- s = "h";
- goto reswitch;
- }
- s--;
- /* FALL THROUGH */
- default:
- croak("Unrecognized switch: -%s (-h will show valid options)",s);
+SV*
+perl_get_sv(char *name, I32 create)
+{
+ GV *gv;
+#ifdef USE_THREADS
+ if (name[1] == '\0' && !isALPHA(name[0])) {
+ PADOFFSET tmp = find_threadsv(name);
+ if (tmp != NOT_IN_PAD) {
+ dTHR;
+ return THREADSV(tmp);
}
}
- switch_end:
+#endif /* USE_THREADS */
+ gv = gv_fetchpv(name, create, SVt_PV);
+ if (gv)
+ return GvSV(gv);
+ return Nullsv;
+}
- if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
- while (s && *s) {
- while (isSPACE(*s))
- s++;
- if (*s == '-') {
- s++;
- if (isSPACE(*s))
- continue;
- }
- if (!*s)
- break;
- if (!strchr("DIMUdmw", *s))
- croak("Illegal switch in PERL5OPT: -%c", *s);
- s = moreswitches(s);
- }
- }
-
- if (!scriptname)
- scriptname = argv[0];
- if (e_script) {
- argc++,argv--;
- scriptname = BIT_BUCKET; /* don't look for script or read stdin */
- }
- else if (scriptname == Nullch) {
-#ifdef MSDOS
- if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
- moreswitches("h");
-#endif
- scriptname = "-";
- }
-
- init_perllib();
-
- open_script(scriptname,dosearch,sv,&fdscript);
-
- validate_suid(validarg, scriptname,fdscript);
-
- if (doextract)
- find_beginning();
-
- main_cv = compcv = (CV*)NEWSV(1104,0);
- sv_upgrade((SV *)compcv, SVt_PVCV);
- CvUNIQUE_on(compcv);
-
- comppad = newAV();
- av_push(comppad, Nullsv);
- curpad = AvARRAY(comppad);
- comppad_name = newAV();
- comppad_name_fill = 0;
- min_intro_pending = 0;
- padix = 0;
-#ifdef USE_THREADS
- av_store(comppad_name, 0, newSVpv("@_", 2));
- curpad[0] = (SV*)newAV();
- SvPADMY_on(curpad[0]); /* XXX Needed? */
- CvOWNER(compcv) = 0;
- New(666, CvMUTEXP(compcv), 1, perl_mutex);
- MUTEX_INIT(CvMUTEXP(compcv));
-#endif /* USE_THREADS */
-
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)comppad_name);
- av_store(comppadlist, 1, (SV*)comppad);
- CvPADLIST(compcv) = comppadlist;
-
- boot_core_UNIVERSAL();
-
- if (xsinit)
- (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32) || defined(DJGPP)
- init_os_extras();
-#endif
-
- init_predump_symbols();
- /* init_postdump_symbols not currently designed to be called */
- /* more than once (ENV isn't cleared first, for example) */
- /* But running with -u leaves %ENV & @ARGV undefined! XXX */
- if (!do_undump)
- init_postdump_symbols(argc,argv,env);
-
- init_lexer();
-
- /* now parse the script */
-
- SETERRNO(0,SS$_NORMAL);
- error_count = 0;
- if (yyparse() || error_count) {
- if (minus_c)
- croak("%s had compilation errors.\n", origfilename);
- else {
- croak("Execution of %s aborted due to compilation errors.\n",
- origfilename);
- }
- }
- curcop->cop_line = 0;
- curstash = defstash;
- preprocess = FALSE;
- if (e_script) {
- SvREFCNT_dec(e_script);
- e_script = Nullsv;
- }
-
- /* now that script is parsed, we can modify record separator */
- SvREFCNT_dec(rs);
- rs = SvREFCNT_inc(nrs);
- sv_setsv(perl_get_sv("/", TRUE), rs);
- if (do_undump)
- my_unexec();
-
- if (dowarn)
- gv_check(defstash);
-
- LEAVE;
- FREETMPS;
-
-#ifdef MYMALLOC
- if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
- dump_mstats("after compilation:");
-#endif
-
- ENTER;
- restartop = 0;
- JMPENV_POP;
- return 0;
-}
-
-int
-#ifdef PERL_OBJECT
-CPerlObj::perl_run(void)
-#else
-perl_run(PerlInterpreter *sv_interp)
-#endif
-{
- dSP;
- I32 oldscope;
- dJMPENV;
- int ret;
-
-#ifndef PERL_OBJECT
- if (!(curinterp = sv_interp))
- return 255;
-#endif
-
- oldscope = scopestack_ix;
-
- JMPENV_PUSH(ret);
- switch (ret) {
- case 1:
- cxstack_ix = -1; /* start context stack again */
- break;
- case 2:
- /* my_exit() was called */
- while (scopestack_ix > oldscope)
- LEAVE;
- FREETMPS;
- curstash = defstash;
- if (endav)
- call_list(oldscope, endav);
-#ifdef MYMALLOC
- if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
- dump_mstats("after execution: ");
-#endif
- JMPENV_POP;
- return STATUS_NATIVE_EXPORT;
- case 3:
- if (!restartop) {
- PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
- FREETMPS;
- JMPENV_POP;
- return 1;
- }
- POPSTACK_TO(mainstack);
- break;
- }
-
- DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
- sawampersand ? "Enabling" : "Omitting"));
-
- if (!restartop) {
- DEBUG_x(dump_all());
- DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
- (unsigned long) thr));
-#endif /* USE_THREADS */
-
- if (minus_c) {
- PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
- my_exit(0);
- }
- if (PERLDB_SINGLE && DBsingle)
- sv_setiv(DBsingle, 1);
- if (initav)
- call_list(oldscope, initav);
- }
-
- /* do it */
-
- if (restartop) {
- op = restartop;
- restartop = 0;
- CALLRUNOPS();
- }
- else if (main_start) {
- CvDEPTH(main_cv) = 1;
- op = main_start;
- CALLRUNOPS();
- }
-
- my_exit(0);
- /* NOTREACHED */
- return 0;
-}
-
-SV*
-perl_get_sv(char *name, I32 create)
-{
- GV *gv;
-#ifdef USE_THREADS
- if (name[1] == '\0' && !isALPHA(name[0])) {
- PADOFFSET tmp = find_threadsv(name);
- if (tmp != NOT_IN_PAD) {
- dTHR;
- return THREADSV(tmp);
- }
- }
-#endif /* USE_THREADS */
- gv = gv_fetchpv(name, create, SVt_PV);
- if (gv)
- return GvSV(gv);
- return Nullsv;
-}
-
-AV*
-perl_get_av(char *name, I32 create)
-{
- GV* gv = gv_fetchpv(name, create, SVt_PVAV);
- if (create)
- return GvAVn(gv);
- if (gv)
- return GvAV(gv);
- return Nullav;
-}
+AV*
+perl_get_av(char *name, I32 create)
+{
+ GV* gv = gv_fetchpv(name, create, SVt_PVAV);
+ if (create)
+ return GvAVn(gv);
+ if (gv)
+ return GvAV(gv);
+ return Nullav;
+}
HV*
perl_get_hv(char *name, I32 create)
I32 oldscope;
bool oldcatch = CATCH_GET;
dJMPENV;
- int ret;
+ int jmpstat;
OP* oldop = op;
if (flags & G_DISCARD) {
}
markstack_ptr++;
- JMPENV_PUSH(ret);
- switch (ret) {
- case 0:
+ JMPENV_PUSH(jmpstat);
+ switch (jmpstat) {
+ case JMP_NORMAL:
break;
- case 1:
+ case JMP_ABNORMAL:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
- case 2:
+ case JMP_MYEXIT:
/* my_exit() was called */
curstash = defstash;
FREETMPS;
croak("Callback called exit");
my_exit_jump();
/* NOTREACHED */
- case 3:
+ case JMP_EXCEPTION:
if (restartop) {
op = restartop;
restartop = 0;
I32 retval;
I32 oldscope;
dJMPENV;
- int ret;
+ int jmpstat;
OP* oldop = op;
if (flags & G_DISCARD) {
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
- JMPENV_PUSH(ret);
- switch (ret) {
- case 0:
+ JMPENV_PUSH(jmpstat);
+ switch (jmpstat) {
+ case JMP_NORMAL:
break;
- case 1:
+ case JMP_ABNORMAL:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
- case 2:
+ case JMP_MYEXIT:
/* my_exit() was called */
curstash = defstash;
FREETMPS;
croak("Callback called exit");
my_exit_jump();
/* NOTREACHED */
- case 3:
+ case JMP_EXCEPTION:
if (restartop) {
op = restartop;
restartop = 0;
line_t oldline = curcop->cop_line;
STRLEN len;
dJMPENV;
- int ret;
+ int jmpstat;
while (AvFILL(paramList) >= 0) {
CV *cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- JMPENV_PUSH(ret);
- switch (ret) {
- case 0: {
+ JMPENV_PUSH(jmpstat);
+ switch (jmpstat) {
+ case JMP_NORMAL: {
SV* atsv = ERRSV;
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
}
}
break;
- case 1:
+ case JMP_ABNORMAL:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
- case 2:
+ case JMP_MYEXIT:
/* my_exit() was called */
while (scopestack_ix > oldscope)
LEAVE;
}
my_exit_jump();
/* NOTREACHED */
- case 3:
+ case JMP_EXCEPTION:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
- JMPENV_JUMP(3);
+ JMPENV_JUMP(JMP_EXCEPTION);
}
JMPENV_POP;
}
LEAVE;
}
- JMPENV_JUMP(2);
+ JMPENV_JUMP(JMP_MYEXIT);
}
#include "XSUB.h"
static I32
-#ifdef PERL_OBJECT
-read_e_script(CPerlObj *pPerl, int idx, SV *buf_sv, int maxlen)
-#else
-read_e_script(int idx, SV *buf_sv, int maxlen)
-#endif
+read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
{
char *p, *nl;
p = SvPVX(e_script);
return 1;
}
+/******************************************* perl_parse TRYBLOCK branches */
+
+#define TRY_LOCAL(name) ((TRY_PARSE_LOCALS*)locals)->name
+
+static void
+try_parse_normal0(CPERLarg_ void *locals)
+{
+ dTHR;
+ register SV *sv;
+ register char *s;
+ char *scriptname = NULL;
+ VOL bool dosearch = FALSE;
+ char *validarg = "";
+ AV* comppadlist;
+ int fdscript = -1;
+
+ void (*xsinit)() = TRY_LOCAL(xsinit);
+ int argc = TRY_LOCAL(argc);
+ char **argv = TRY_LOCAL(argv);
+ char **env = TRY_LOCAL(env);
+
+ sv_setpvn(linestr,"",0);
+ sv = newSVpv("",0); /* first used for -I flags */
+ SAVEFREESV(sv);
+ init_main_stash();
+ for (argc--,argv++; argc > 0; argc--,argv++) {
+ if (argv[0][0] != '-' || !argv[0][1])
+ break;
+#ifdef DOSUID
+ if (*validarg)
+ validarg = " PHOOEY ";
+ else
+ validarg = argv[0];
+#endif
+ s = argv[0]+1;
+ reswitch:
+ switch (*s) {
+ case ' ':
+ case '0':
+ case 'F':
+ case 'a':
+ case 'c':
+ case 'd':
+ case 'D':
+ case 'h':
+ case 'i':
+ case 'l':
+ case 'M':
+ case 'm':
+ case 'n':
+ case 'p':
+ case 's':
+ case 'u':
+ case 'U':
+ case 'v':
+ case 'w':
+ if (s = moreswitches(s))
+ goto reswitch;
+ break;
+
+ case 'T':
+ tainting = TRUE;
+ s++;
+ goto reswitch;
+
+ case 'e':
+ if (euid != uid || egid != gid)
+ croak("No -e allowed in setuid scripts");
+ if (!e_script) {
+ e_script = newSVpv("",0);
+ filter_add(read_e_script, NULL);
+ }
+ if (*++s)
+ sv_catpv(e_script, s);
+ else if (argv[1]) {
+ sv_catpv(e_script, argv[1]);
+ argc--,argv++;
+ }
+ else
+ croak("No code specified for -e");
+ sv_catpv(e_script, "\n");
+ break;
+
+ case 'I': /* -I handled both here and in moreswitches() */
+ forbid_setid("-I");
+ if (!*++s && (s=argv[1]) != Nullch) {
+ argc--,argv++;
+ }
+ while (s && isSPACE(*s))
+ ++s;
+ if (s && *s) {
+ char *e, *p;
+ for (e = s; *e && !isSPACE(*e); e++) ;
+ p = savepvn(s, e-s);
+ incpush(p, TRUE);
+ sv_catpv(sv,"-I");
+ sv_catpv(sv,p);
+ sv_catpv(sv," ");
+ Safefree(p);
+ } /* XXX else croak? */
+ break;
+ case 'P':
+ forbid_setid("-P");
+ preprocess = TRUE;
+ s++;
+ goto reswitch;
+ case 'S':
+ forbid_setid("-S");
+ dosearch = TRUE;
+ s++;
+ goto reswitch;
+ case 'V':
+ if (!preambleav)
+ preambleav = newAV();
+ av_push(preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
+ if (*++s != ':') {
+ Sv = newSVpv("print myconfig();",0);
+#ifdef VMS
+ sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+#else
+ sv_catpv(Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
+#endif
+#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+ sv_catpv(Sv,"\" Compile-time options:");
+# ifdef DEBUGGING
+ sv_catpv(Sv," DEBUGGING");
+# endif
+# ifdef NO_EMBED
+ sv_catpv(Sv," NO_EMBED");
+# endif
+# ifdef MULTIPLICITY
+ sv_catpv(Sv," MULTIPLICITY");
+# endif
+ sv_catpv(Sv,"\\n\",");
+#endif
+#if defined(LOCAL_PATCH_COUNT)
+ if (LOCAL_PATCH_COUNT > 0) {
+ int i;
+ sv_catpv(Sv,"\" Locally applied patches:\\n\",");
+ for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
+ if (localpatches[i])
+ sv_catpvf(Sv,"\" \\t%s\\n\",",localpatches[i]);
+ }
+ }
+#endif
+ sv_catpvf(Sv,"\" Built under %s\\n\"",OSNAME);
+#ifdef __DATE__
+# ifdef __TIME__
+ sv_catpvf(Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
+# else
+ sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
+# endif
+#endif
+ sv_catpv(Sv, "; \
+$\"=\"\\n \"; \
+@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; \
+print \" \\%ENV:\\n @env\\n\" if @env; \
+print \" \\@INC:\\n @INC\\n\";");
+ }
+ else {
+ Sv = newSVpv("config_vars(qw(",0);
+ sv_catpv(Sv, ++s);
+ sv_catpv(Sv, "))");
+ s += strlen(s);
+ }
+ av_push(preambleav, Sv);
+ scriptname = BIT_BUCKET; /* don't look for script or read stdin */
+ goto reswitch;
+ case 'x':
+ doextract = TRUE;
+ s++;
+ if (*s)
+ cddir = savepv(s);
+ break;
+ case 0:
+ break;
+ case '-':
+ if (!*++s || isSPACE(*s)) {
+ argc--,argv++;
+ goto switch_end;
+ }
+ /* catch use of gnu style long options */
+ if (strEQ(s, "version")) {
+ s = "v";
+ goto reswitch;
+ }
+ if (strEQ(s, "help")) {
+ s = "h";
+ goto reswitch;
+ }
+ s--;
+ /* FALL THROUGH */
+ default:
+ croak("Unrecognized switch: -%s (-h will show valid options)",s);
+ }
+ }
+ switch_end:
+
+ if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
+ while (s && *s) {
+ while (isSPACE(*s))
+ s++;
+ if (*s == '-') {
+ s++;
+ if (isSPACE(*s))
+ continue;
+ }
+ if (!*s)
+ break;
+ if (!strchr("DIMUdmw", *s))
+ croak("Illegal switch in PERL5OPT: -%c", *s);
+ s = moreswitches(s);
+ }
+ }
+
+ if (!scriptname)
+ scriptname = argv[0];
+ if (e_script) {
+ argc++,argv--;
+ scriptname = BIT_BUCKET; /* don't look for script or read stdin */
+ }
+ else if (scriptname == Nullch) {
+#ifdef MSDOS
+ if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
+ moreswitches("h");
+#endif
+ scriptname = "-";
+ }
+
+ init_perllib();
+
+ open_script(scriptname,dosearch,sv,&fdscript);
+
+ validate_suid(validarg, scriptname,fdscript);
+
+ if (doextract)
+ find_beginning();
+
+ main_cv = compcv = (CV*)NEWSV(1104,0);
+ sv_upgrade((SV *)compcv, SVt_PVCV);
+ CvUNIQUE_on(compcv);
+
+ comppad = newAV();
+ av_push(comppad, Nullsv);
+ curpad = AvARRAY(comppad);
+ comppad_name = newAV();
+ comppad_name_fill = 0;
+ min_intro_pending = 0;
+ padix = 0;
+#ifdef USE_THREADS
+ av_store(comppad_name, 0, newSVpv("@_", 2));
+ curpad[0] = (SV*)newAV();
+ SvPADMY_on(curpad[0]); /* XXX Needed? */
+ CvOWNER(compcv) = 0;
+ New(666, CvMUTEXP(compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(compcv));
+#endif /* USE_THREADS */
+
+ comppadlist = newAV();
+ AvREAL_off(comppadlist);
+ av_store(comppadlist, 0, (SV*)comppad_name);
+ av_store(comppadlist, 1, (SV*)comppad);
+ CvPADLIST(compcv) = comppadlist;
+
+ boot_core_UNIVERSAL();
+
+ if (xsinit)
+ (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
+ init_os_extras();
+#endif
+
+ init_predump_symbols();
+ /* init_postdump_symbols not currently designed to be called */
+ /* more than once (ENV isn't cleared first, for example) */
+ /* But running with -u leaves %ENV & @ARGV undefined! XXX */
+ if (!do_undump)
+ init_postdump_symbols(argc,argv,env);
+
+ init_lexer();
+
+ /* now parse the script */
+
+ SETERRNO(0,SS$_NORMAL);
+ error_count = 0;
+ if (yyparse() || error_count) {
+ if (minus_c)
+ croak("%s had compilation errors.\n", origfilename);
+ else {
+ croak("Execution of %s aborted due to compilation errors.\n",
+ origfilename);
+ }
+ }
+ curcop->cop_line = 0;
+ curstash = defstash;
+ preprocess = FALSE;
+ if (e_script) {
+ SvREFCNT_dec(e_script);
+ e_script = Nullsv;
+ }
+
+ /* now that script is parsed, we can modify record separator */
+ SvREFCNT_dec(rs);
+ rs = SvREFCNT_inc(nrs);
+ sv_setsv(perl_get_sv("/", TRUE), rs);
+ if (do_undump)
+ my_unexec();
+
+ if (dowarn)
+ gv_check(defstash);
+
+ LEAVE;
+ FREETMPS;
+
+#ifdef MYMALLOC
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ dump_mstats("after compilation:");
+#endif
+
+ ENTER;
+ restartop = 0;
+ TRY_LOCAL(ret) = 0;
+}
+
+static void
+try_parse_exception1(CPERLarg_ void *locals)
+{
+ PerlIO_printf(PerlIO_stderr(), no_top_env);
+ TRY_LOCAL(ret) = 1;
+}
+
+static void
+try_parse_myexit0(CPERLarg_ void *locals)
+{
+ dTHR;
+ I32 oldscope = TRY_LOCAL(oldscope);
+ while (scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ curstash = defstash;
+ if (endav)
+ call_list(oldscope, endav);
+ TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
+}
+
+static void
+try_parse_abnormal0(CPERLarg_ void *locals)
+{
+ STATUS_ALL_FAILURE;
+ try_parse_myexit0(locals);
+}
+
+#undef TRY_LOCAL
+static TRYVTBL PerlParseVtbl = {
+ "perl_parse",
+ try_parse_normal0, 0,
+ try_parse_abnormal0, 0,
+ 0, try_parse_exception1,
+ try_parse_myexit0, 0,
+};
+
+/******************************************* perl_run TRYBLOCK branches */
+
+#define TRY_LOCAL(name) ((TRY_RUN_LOCALS*)locals)->name
+
+static void
+try_run_normal0(CPERLarg_ void *locals)
+{
+ dTHR;
+ I32 oldscope = TRY_LOCAL(oldscope);
+
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
+ sawampersand ? "Enabling" : "Omitting"));
+
+ if (!restartop) {
+ DEBUG_x(dump_all());
+ DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
+ (unsigned long) thr));
+#endif /* USE_THREADS */
+
+ if (minus_c) {
+ PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", origfilename);
+ my_exit(0);
+ }
+ if (PERLDB_SINGLE && DBsingle)
+ sv_setiv(DBsingle, 1);
+ if (initav)
+ call_list(oldscope, initav);
+ }
+
+ /* do it */
+
+ if (restartop) {
+ op = restartop;
+ restartop = 0;
+ CALLRUNOPS();
+ }
+ else if (main_start) {
+ CvDEPTH(main_cv) = 1;
+ op = main_start;
+ CALLRUNOPS();
+ }
+
+ my_exit(0);
+}
+
+static void
+try_run_abnormal0(CPERLarg_ void *locals)
+{
+ dTHR;
+ cxstack_ix = -1; /* start context stack again */
+ try_run_normal0(locals);
+}
+
+static void
+try_run_exception0(CPERLarg_ void *locals)
+{
+ dSP;
+ if (!restartop) {
+ PerlIO_printf(PerlIO_stderr(), no_restartop);
+ FREETMPS;
+ TRY_LOCAL(ret) = 1;
+ } else {
+ POPSTACK_TO(mainstack);
+ try_run_normal0(locals);
+ }
+}
+
+static void
+try_run_myexit0(CPERLarg_ void *locals)
+{
+ dTHR;
+ I32 oldscope = TRY_LOCAL(oldscope);
+
+ while (scopestack_ix > oldscope)
+ LEAVE;
+ FREETMPS;
+ curstash = defstash;
+ if (endav)
+ call_list(oldscope, endav);
+#ifdef MYMALLOC
+ if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
+ dump_mstats("after execution: ");
+#endif
+ TRY_LOCAL(ret) = STATUS_NATIVE_EXPORT;
+}
+
+#undef TRY_LOCAL
+static TRYVTBL PerlRunVtbl = {
+ "perl_run",
+ try_run_normal0, 0,
+ try_run_abnormal0, 0,
+ try_run_exception0, 0,
+ try_run_myexit0, 0
+};
* points to this initially, so top_env should always be non-null.
*
* Existence of a non-null top_env->je_prev implies it is valid to call
- * longjmp() at that runlevel (we make sure start_env.je_prev is always
- * null to ensure this).
+ * (*je_jump)() at that runlevel. Always use the macros below! They
+ * manage most of the complexity for you.
*
* je_mustcatch, when set at any runlevel to TRUE, means eval ops must
* establish a local jmpenv to handle exception traps. Care must be taken
* to restore the previous value of je_mustcatch before exiting the
* stack frame iff JMPENV_PUSH was not called in that stack frame.
- * GSAR 97-03-27
+ *
+ * The support for C++ try/throw causes a small loss of flexibility.
+ * No longer is it possible to place the body of exception-protected
+ * code in the same C function as JMPENV_PUSH &etc. Older code that
+ * does this will continue to work with set/longjmp, but cannot use
+ * C++ exceptions.
+ *
+ * GSAR 19970327
+ * JPRIT 19980613 (C++ update)
*/
+#define JMP_NORMAL 0
+#define JMP_ABNORMAL 1 /* shouldn't happen */
+#define JMP_MYEXIT 2 /* exit */
+#define JMP_EXCEPTION 3 /* die */
+
+/* None of the JMPENV fields should be accessed directly.
+ Please use the macros below! */
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 */
+ int je_stat; /* JMP_* reason for setjmp() */
+ bool je_mustcatch; /* will need a new TRYBLOCK? */
+ void (*je_jump) _((CPERLproto));
};
-
typedef struct jmpenv JMPENV;
+struct tryvtbl {
+ /* [0] executed before JMPENV_POP
+ [1] executed after JMPENV_POP
+ (NULL pointers are OK) */
+ char *try_context;
+ void (*try_normal [2]) _((CPERLproto_ void*));
+ void (*try_abnormal [2]) _((CPERLproto_ void*));
+ void (*try_exception [2]) _((CPERLproto_ void*));
+ void (*try_myexit [2]) _((CPERLproto_ void*));
+};
+typedef struct tryvtbl TRYVTBL;
+
+typedef void (*tryblock_f) _((CPERLproto_ TRYVTBL *vtbl, void *locals));
+#define TRYBLOCK(mytry,vars) \
+ (*tryblock_function)(PERL_OBJECT_THIS_ &mytry, &vars)
+
#ifdef OP_IN_REGISTER
#define OP_REG_TO_MEM opsave = op
#define OP_MEM_TO_REG op = opsave
#define OP_MEM_TO_REG NOOP
#endif
-#define dJMPENV JMPENV cur_env
-#define JMPENV_PUSH(v) \
- STMT_START { \
- cur_env.je_prev = top_env; \
- OP_REG_TO_MEM; \
- cur_env.je_ret = PerlProc_setjmp(cur_env.je_buf, 1); \
- OP_MEM_TO_REG; \
- top_env = &cur_env; \
- cur_env.je_mustcatch = FALSE; \
- (v) = cur_env.je_ret; \
- } STMT_END
-#define JMPENV_POP \
- STMT_START { top_env = cur_env.je_prev; } STMT_END
+#define JMPENV_TOPINIT(top) \
+STMT_START { \
+ top.je_prev = NULL; \
+ top.je_stat = JMP_ABNORMAL; \
+ top.je_mustcatch = TRUE; \
+ top_env = ⊤ \
+} STMT_END
+
+#define JMPENV_INIT(env, jmp) \
+STMT_START { \
+ ((JMPENV*)&env)->je_prev = top_env; \
+ ((JMPENV*)&env)->je_stat = JMP_NORMAL; \
+ ((JMPENV*)&env)->je_jump = jmp; \
+ OP_REG_TO_MEM; \
+} STMT_END
+
+#define JMPENV_TRY(env) \
+STMT_START { \
+ OP_MEM_TO_REG; \
+ ((JMPENV*)&env)->je_mustcatch = FALSE; \
+ top_env = (JMPENV*)&env; \
+} STMT_END
+
+#define JMPENV_POP_JE(env) \
+STMT_START { \
+ assert(top_env == (JMPENV*)&env); \
+ top_env = ((JMPENV*)&env)->je_prev; \
+} STMT_END
+
+#define JMPENV_STAT(env) ((JMPENV*)&env)->je_stat
+
#define JMPENV_JUMP(v) \
STMT_START { \
+ assert((v) != JMP_NORMAL); \
OP_REG_TO_MEM; \
- if (top_env->je_prev) \
- PerlProc_longjmp(top_env->je_buf, (v)); \
- if ((v) == 2) \
- PerlProc_exit(STATUS_NATIVE_EXPORT); \
- PerlIO_printf(PerlIO_stderr(), "panic: top_env\n"); \
- PerlProc_exit(1); \
+ if (top_env->je_prev) { \
+ top_env->je_stat = (v); \
+ (*top_env->je_jump)(PERL_OBJECT_THIS); \
+ } \
+ if ((v) == JMP_MYEXIT) \
+ PerlProc_exit(STATUS_NATIVE_EXPORT); \
+ PerlIO_printf(PerlIO_stderr(), no_top_env); \
+ PerlProc_exit(1); \
} STMT_END
#define CATCH_GET (top_env->je_mustcatch)
#define CATCH_SET(v) (top_env->je_mustcatch = (v))
-
+
+
+
+/*******************************************************************
+ * JMPENV_PUSH is the old depreciated API. See perl.c for examples
+ * of the new API.
+ */
+
+struct setjmpenv {
+ /* move to scope.c once JMPENV_PUSH is no longer needed XXX */
+ JMPENV je0;
+ Sigjmp_buf je_buf;
+};
+typedef struct setjmpenv SETJMPENV;
+
+#define dJMPENV SETJMPENV cur_env
+
+extern void setjmp_jump();
+
+#define JMPENV_PUSH(v) \
+ STMT_START { \
+ JMPENV_INIT(cur_env, setjmp_jump); \
+ PerlProc_setjmp(cur_env.je_buf, 1); \
+ JMPENV_TRY(cur_env); \
+ (v) = JMPENV_STAT(cur_env); \
+ } STMT_END
+
+#define JMPENV_POP \
+STMT_START { \
+ assert(top_env == (JMPENV*) &cur_env); \
+ top_env = cur_env.je0.je_prev; \
+} STMT_END
+
projects / p5sagit/p5-mst-13.2.git / commitdiff