#endif
#endif
-#define I_REINIT \
- STMT_START { \
- chopset = " \n-"; \
- copline = NOLINE; \
- curcop = &compiling; \
- curcopdb = NULL; \
- cxstack_ix = -1; \
- cxstack_max = 128; \
- dbargs = 0; \
- dlmax = 128; \
- laststatval = -1; \
- laststype = OP_STAT; \
- maxscream = -1; \
- maxsysfd = MAXSYSFD; \
- statname = Nullsv; \
- tmps_floor = -1; \
- tmps_ix = -1; \
- op_mask = NULL; \
- dlmax = 128; \
- laststatval = -1; \
- laststype = OP_STAT; \
- mess_sv = Nullsv; \
- } STMT_END
-
#ifdef PERL_OBJECT
static I32 read_e_script _((CPerlObj* pPerl, int idx, SV *buf_sv, int maxlen));
#else
static void find_beginning _((void));
static void forbid_setid _((char *));
static void incpush _((char *, int));
+static void init_interp _((void));
static void init_ids _((void));
static void init_debugger _((void));
static void init_lexer _((void));
#endif
#ifdef MULTIPLICITY
+ ++ninterps;
Zero(sv_interp, 1, PerlInterpreter);
#endif
thr = init_main_thread();
#endif /* USE_THREADS */
- linestr = NEWSV(65,80);
+ linestr = NEWSV(65,79);
sv_upgrade(linestr,SVt_PVIV);
if (!SvREADONLY(&sv_undef)) {
init_stacks(ARGS);
#ifdef MULTIPLICITY
- I_REINIT;
+ init_interp();
perl_destruct_level = 1;
#else
- if(perl_destruct_level > 0)
- I_REINIT;
+ if (perl_destruct_level > 0)
+ init_interp();
#endif
init_ids();
lex_state = LEX_NOTPARSING;
- install_tryblock_method(0); /* default to set/longjmp style tryblock */
- JMPENV_TOPINIT(start_env);
+ start_env.je_prev = NULL;
+ start_env.je_ret = -1;
+ start_env.je_mustcatch = TRUE;
+ top_env = &start_env;
STATUS_ALL_SUCCESS;
SET_NUMERIC_STANDARD();
LEAVE;
FREETMPS;
+#ifdef MULTIPLICITY
+ --ninterps;
+#endif
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
/* No SVs have survived, need to clean out */
linestr = NULL;
pidstatus = Nullhv;
- if (origfilename)
- Safefree(origfilename);
+ Safefree(origfilename);
+ Safefree(archpat_auto);
+ Safefree(reg_start_tmp);
+ Safefree(HeKEY_hek(&hv_fetch_ent_mh));
+ Safefree(op_mask);
nuke_stacks();
hints = 0; /* Reset hints. Should hints be per-interpreter ? */
++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;
- TRY_PARSE_LOCALS locals;
- locals.xsinit = xsinit;
- locals.argc = argc;
- locals.argv = argv;
- locals.env = env;
+ 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
main_cv = Nullcv;
time(&basetime);
- locals.oldscope = scopestack_ix;
+ oldscope = scopestack_ix;
- TRYBLOCK(PerlParseVtbl, locals);
- return locals.ret;
-}
+ 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;
+ }
-struct try_run_locals {
- I32 oldscope;
- int ret;
-};
-typedef struct try_run_locals TRY_RUN_LOCALS;
-static TRYVTBL PerlRunVtbl;
+ sv_setpvn(linestr,"",0);
+ sv = newSVpv("",0); /* first used for -I flags */
+ SAVEFREESV(sv);
+ init_main_stash();
-int
-#ifdef PERL_OBJECT
-CPerlObj::perl_run(void)
-#else
-perl_run(PerlInterpreter *sv_interp)
+ 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
-{
- dTHR;
- TRY_RUN_LOCALS locals;
+ 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;
-#ifndef PERL_OBJECT
- if (!(curinterp = sv_interp))
- return 255;
-#endif
+ case 'T':
+ tainting = TRUE;
+ s++;
+ goto reswitch;
- locals.oldscope = scopestack_ix;
- TRYBLOCK(PerlRunVtbl, locals);
- return locals.ret;
-}
+ 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;
-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);
+ 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);
}
}
-#endif /* USE_THREADS */
- gv = gv_fetchpv(name, create, SVt_PV);
- if (gv)
- return GvSV(gv);
- return Nullsv;
-}
+ switch_end:
-AV*
-perl_get_av(char *name, I32 create)
-{
+ 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);
I32 oldscope;
bool oldcatch = CATCH_GET;
dJMPENV;
- int jmpstat;
+ int ret;
OP* oldop = op;
if (flags & G_DISCARD) {
}
markstack_ptr++;
- JMPENV_PUSH(jmpstat);
- switch (jmpstat) {
- case JMP_NORMAL:
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
break;
- case JMP_ABNORMAL:
+ case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
- case JMP_MYEXIT:
+ case 2:
/* my_exit() was called */
curstash = defstash;
FREETMPS;
croak("Callback called exit");
my_exit_jump();
/* NOTREACHED */
- case JMP_EXCEPTION:
+ case 3:
if (restartop) {
op = restartop;
restartop = 0;
I32 retval;
I32 oldscope;
dJMPENV;
- int jmpstat;
+ int ret;
OP* oldop = op;
if (flags & G_DISCARD) {
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
- JMPENV_PUSH(jmpstat);
- switch (jmpstat) {
- case JMP_NORMAL:
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0:
break;
- case JMP_ABNORMAL:
+ case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
- case JMP_MYEXIT:
+ case 2:
/* my_exit() was called */
curstash = defstash;
FREETMPS;
croak("Callback called exit");
my_exit_jump();
/* NOTREACHED */
- case JMP_EXCEPTION:
+ case 3:
if (restartop) {
op = restartop;
restartop = 0;
#endif
}
+/* initialize curinterp */
STATIC void
-init_main_stash(void)
+init_interp(void)
{
- dTHR;
- GV *gv;
- /* Note that strtab is a rather special HV. Assumptions are made
- about not iterating on it, and not adding tie magic to it.
- It is properly deallocated in perl_destruct() */
- strtab = newHV();
- HvSHAREKEYS_off(strtab); /* mandatory */
- Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
- sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
-
- curstash = defstash = newHV();
- curstname = newSVpv("main",4);
- gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
- SvREFCNT_dec(GvHV(gv));
- GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
- SvREADONLY_on(gv);
- HvNAME(defstash) = savepv("main");
- incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
- GvMULTI_on(incgv);
- defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
- errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
- GvMULTI_on(errgv);
- replgv = gv_HVadd(gv_fetchpv("\022", TRUE, SVt_PV)); /* ^R */
- GvMULTI_on(replgv);
- (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
- sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
- sv_setpvn(ERRSV, "", 0);
- curstash = defstash;
- compiling.cop_stash = defstash;
- debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
- globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
+#ifdef PERL_OBJECT /* XXX kludge */
+#define I_REINIT \
+ STMT_START { \
+ chopset = " \n-"; \
+ copline = NOLINE; \
+ curcop = &compiling; \
+ curcopdb = NULL; \
+ dbargs = 0; \
+ dlmax = 128; \
+ laststatval = -1; \
+ laststype = OP_STAT; \
+ maxscream = -1; \
+ maxsysfd = MAXSYSFD; \
+ statname = Nullsv; \
+ tmps_floor = -1; \
+ tmps_ix = -1; \
+ op_mask = NULL; \
+ dlmax = 128; \
+ laststatval = -1; \
+ laststype = OP_STAT; \
+ mess_sv = Nullsv; \
+ splitstr = " "; \
+ generation = 100; \
+ exitlist = NULL; \
+ exitlistlen = 0; \
+ regindent = 0; \
+ in_clean_objs = FALSE; \
+ in_clean_all= FALSE; \
+ profiledata = NULL; \
+ rsfp = Nullfp; \
+ rsfp_filters= Nullav; \
+ } STMT_END
+ I_REINIT;
+#else
+# ifdef MULTIPLICITY
+# define PERLVAR(var,type)
+# define PERLVARI(var,type,init) curinterp->var = init;
+# define PERLVARIC(var,type,init) curinterp->var = init;
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARI
+# undef PERLVARIC
+# else
+# define PERLVAR(var,type)
+# define PERLVARI(var,type,init) var = init;
+# define PERLVARIC(var,type,init) var = init;
+# include "intrpvar.h"
+# ifndef USE_THREADS
+# include "thrdvar.h"
+# endif
+# undef PERLVAR
+# undef PERLVARI
+# undef PERLVARIC
+# endif
+#endif
+
+}
+
+STATIC void
+init_main_stash(void)
+{
+ dTHR;
+ GV *gv;
+
+ /* Note that strtab is a rather special HV. Assumptions are made
+ about not iterating on it, and not adding tie magic to it.
+ It is properly deallocated in perl_destruct() */
+ strtab = newHV();
+ HvSHAREKEYS_off(strtab); /* mandatory */
+ Newz(506,((XPVHV*)SvANY(strtab))->xhv_array,
+ sizeof(HE*) * (((XPVHV*)SvANY(strtab))->xhv_max + 1), char);
+
+ curstash = defstash = newHV();
+ curstname = newSVpv("main",4);
+ gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
+ SvREFCNT_dec(GvHV(gv));
+ GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
+ SvREADONLY_on(gv);
+ HvNAME(defstash) = savepv("main");
+ incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
+ GvMULTI_on(incgv);
+ defgv = gv_fetchpv("_",TRUE, SVt_PVAV);
+ errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
+ GvMULTI_on(errgv);
+ replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
+ GvMULTI_on(replgv);
+ (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
+ sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
+ sv_setpvn(ERRSV, "", 0);
+ curstash = defstash;
+ compiling.cop_stash = defstash;
+ debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
+ globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
}
dTHR;
register char *s;
- scriptname = find_script(scriptname, dosearch, NULL, 0);
+ /* scriptname will be non-NULL if find_script() returns */
+ scriptname = find_script(scriptname, dosearch, NULL, 1);
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
char *s = scriptname + 8;
}
else
*fdscript = -1;
- origfilename = savepv(e_script ? "-e" : scriptname);
+ origfilename = (e_script ? savepv("-e") : scriptname);
curcop->cop_filegv = gv_fetchfile(origfilename);
if (strEQ(origfilename,"-"))
scriptname = "";
}
else if (preprocess) {
char *cpp_cfg = CPPSTDIN;
- SV *cpp = NEWSV(0,0);
+ SV *cpp = newSVpv("",0);
SV *cmd = NEWSV(0,0);
if (strEQ(cpp_cfg, "cppstdin"))
tmps_ix = -1;
tmps_max = REASONABLE(128);
- /*
- * The following stacks almost certainly should be per-interpreter,
- * but for now they're not. XXX
- */
-
- if (markstack) {
- markstack_ptr = markstack;
- } else {
- New(54,markstack,REASONABLE(32),I32);
- markstack_ptr = markstack;
- markstack_max = markstack + REASONABLE(32);
- }
+ New(54,markstack,REASONABLE(32),I32);
+ markstack_ptr = markstack;
+ markstack_max = markstack + REASONABLE(32);
SET_MARKBASE;
- if (scopestack) {
- scopestack_ix = 0;
- } else {
- New(54,scopestack,REASONABLE(32),I32);
- scopestack_ix = 0;
- scopestack_max = REASONABLE(32);
- }
+ New(54,scopestack,REASONABLE(32),I32);
+ scopestack_ix = 0;
+ scopestack_max = REASONABLE(32);
- if (savestack) {
- savestack_ix = 0;
- } else {
- New(54,savestack,REASONABLE(128),ANY);
- savestack_ix = 0;
- savestack_max = REASONABLE(128);
- }
+ New(54,savestack,REASONABLE(128),ANY);
+ savestack_ix = 0;
+ savestack_max = REASONABLE(128);
- if (retstack) {
- retstack_ix = 0;
- } else {
- New(54,retstack,REASONABLE(16),OP*);
- retstack_ix = 0;
- retstack_max = REASONABLE(16);
- }
+ New(54,retstack,REASONABLE(16),OP*);
+ retstack_ix = 0;
+ retstack_max = REASONABLE(16);
}
#undef REASONABLE
curstackinfo = p;
}
Safefree(tmps_stack);
+ Safefree(markstack);
+ Safefree(scopestack);
+ Safefree(savestack);
+ Safefree(retstack);
DEBUG( {
Safefree(debname);
Safefree(debdelim);
return;
if (addsubdirs) {
- subdir = NEWSV(55,0);
+ subdir = sv_newmortal();
if (!archpat_auto) {
STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
+ sizeof("//auto"));
/* finally push this lib directory on the end of @INC */
av_push(GvAVn(incgv), libdir);
}
-
- SvREFCNT_dec(subdir);
}
#ifdef USE_THREADS
line_t oldline = curcop->cop_line;
STRLEN len;
dJMPENV;
- int jmpstat;
+ int ret;
while (AvFILL(paramList) >= 0) {
CV *cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
- JMPENV_PUSH(jmpstat);
- switch (jmpstat) {
- case JMP_NORMAL: {
+ JMPENV_PUSH(ret);
+ switch (ret) {
+ case 0: {
SV* atsv = ERRSV;
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
}
}
break;
- case JMP_ABNORMAL:
+ case 1:
STATUS_ALL_FAILURE;
/* FALL THROUGH */
- case JMP_MYEXIT:
+ case 2:
/* my_exit() was called */
while (scopestack_ix > oldscope)
LEAVE;
}
my_exit_jump();
/* NOTREACHED */
- case JMP_EXCEPTION:
+ case 3:
if (!restartop) {
PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
FREETMPS;
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
- JMPENV_JUMP(JMP_EXCEPTION);
+ JMPENV_JUMP(3);
}
JMPENV_POP;
}
LEAVE;
}
- JMPENV_JUMP(JMP_MYEXIT);
+ JMPENV_JUMP(2);
}
#include "XSUB.h"
static I32
-read_e_script(CPERLarg_ int idx, SV *buf_sv, int maxlen)
+#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
{
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
-};
https://perl5.git.perl.org / perl5.git / blobdiff