/* perl.c
*
- * Copyright (c) 1987-1998 Larry Wall
+ * Copyright (c) 1987-1999 Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
#include "EXTERN.h"
+#define PERL_IN_PERL_C
#include "perl.h"
-#include "patchlevel.h"
+#include "patchlevel.h" /* for local_patches */
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
#endif
#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE)
-char *getenv _((char *)); /* Usually in <stdlib.h> */
+char *getenv (char *); /* Usually in <stdlib.h> */
#endif
+static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
+
#ifdef I_FCNTL
#include <fcntl.h>
#endif
#include <sys/file.h>
#endif
-dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
-
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
#endif
#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));
-static void init_main_stash _((void));
-#ifdef USE_THREADS
-static struct perl_thread * init_main_thread _((void));
-#endif /* USE_THREADS */
-static void init_perllib _((void));
-static void init_postdump_symbols _((int, char **, char **));
-static void init_predump_symbols _((void));
-static void my_exit_jump _((void)) __attribute__((noreturn));
-static void nuke_stacks _((void));
-static void open_script _((char *, bool, SV *, int *fd));
-static void usage _((char *));
-static void validate_suid _((char *, char*, int));
-static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
-#endif
-
-#ifdef PERL_OBJECT
CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
- IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
{
CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
if(pPerl != NULL)
PerlInterpreter *
perl_alloc(void)
{
- PerlInterpreter *sv_interp;
+ PerlInterpreter *my_perl;
- PL_curinterp = 0;
- New(53, sv_interp, 1, PerlInterpreter);
- return sv_interp;
+ /* New() needs interpreter, so call malloc() instead */
+ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
+ PERL_SET_INTERP(my_perl);
+ return my_perl;
}
#endif /* PERL_OBJECT */
void
-#ifdef PERL_OBJECT
-CPerlObj::perl_construct(void)
-#else
-perl_construct(register PerlInterpreter *sv_interp)
-#endif
+perl_construct(pTHXx)
{
#ifdef USE_THREADS
int i;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
-#ifndef PERL_OBJECT
- if (!(PL_curinterp = sv_interp))
- return;
+#ifdef MULTIPLICITY
+ Zero(my_perl, 1, PerlInterpreter);
#endif
#ifdef MULTIPLICITY
- ++ninterps;
- Zero(sv_interp, 1, PerlInterpreter);
+ init_interp();
+ PL_perl_destruct_level = 1;
+#else
+ if (PL_perl_destruct_level > 0)
+ init_interp();
#endif
/* Init the real globals (and main thread)? */
#ifdef ALLOC_THREAD_KEY
ALLOC_THREAD_KEY;
#else
- if (pthread_key_create(&thr_key, 0))
- croak("panic: pthread_key_create");
+ if (pthread_key_create(&PL_thr_key, 0))
+ Perl_croak(aTHX_ "panic: pthread_key_create");
#endif
- MUTEX_INIT(&sv_mutex);
+ MUTEX_INIT(&PL_sv_mutex);
/*
* Safe to use basic SV functions from now on (though
* not things like mortals or tainting yet).
*/
- MUTEX_INIT(&eval_mutex);
- COND_INIT(&eval_cond);
- MUTEX_INIT(&threads_mutex);
- COND_INIT(&nthreads_cond);
+ MUTEX_INIT(&PL_eval_mutex);
+ COND_INIT(&PL_eval_cond);
+ MUTEX_INIT(&PL_threads_mutex);
+ COND_INIT(&PL_nthreads_cond);
#ifdef EMULATE_ATOMIC_REFCOUNTS
- MUTEX_INIT(&svref_mutex);
+ MUTEX_INIT(&PL_svref_mutex);
#endif /* EMULATE_ATOMIC_REFCOUNTS */
+ MUTEX_INIT(&PL_cred_mutex);
+
thr = init_main_thread();
#endif /* USE_THREADS */
+ PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
+
+ PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
+
PL_linestr = NEWSV(65,79);
sv_upgrade(PL_linestr,SVt_PVIV);
#ifdef PERL_OBJECT
/* TODO: */
- /* sighandlerp = sighandler; */
+ /* PL_sighandlerp = sighandler; */
#else
- PL_sighandlerp = sighandler;
+ PL_sighandlerp = Perl_sighandler;
#endif
PL_pidstatus = newHV();
#endif
}
- PL_nrs = newSVpv("\n", 1);
+ PL_nrs = newSVpvn("\n", 1);
PL_rs = SvREFCNT_inc(PL_nrs);
- init_stacks(ARGS);
-#ifdef MULTIPLICITY
- init_interp();
- perl_destruct_level = 1;
-#else
- if (PL_perl_destruct_level > 0)
- init_interp();
-#endif
+ init_stacks();
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;
+ init_i18nl10n(1);
SET_NUMERIC_STANDARD();
-#if defined(SUBVERSION) && SUBVERSION > 0
- sprintf(PL_patchlevel, "%7.5f", (double) 5
- + ((double) PATCHLEVEL / (double) 1000)
- + ((double) SUBVERSION / (double) 100000));
+#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
+ sprintf(PL_patchlevel, "%7.5f", (double) PERL_REVISION
+ + ((double) PERL_VERSION / (double) 1000)
+ + ((double) PERL_SUBVERSION / (double) 100000));
#else
- sprintf(patchlevel, "%5.3f", (double) 5 +
- ((double) PATCHLEVEL / (double) 1000));
+ sprintf(PL_patchlevel, "%5.3f", (double) PERL_REVISION +
+ ((double) PERL_VERSION / (double) 1000));
#endif
#if defined(LOCAL_PATCH_COUNT)
}
void
-#ifdef PERL_OBJECT
-CPerlObj::perl_destruct(void)
-#else
-perl_destruct(register PerlInterpreter *sv_interp)
-#endif
+perl_destruct(pTHXx)
{
dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
#ifdef USE_THREADS
Thread t;
+ dTHX;
#endif /* USE_THREADS */
-#ifndef PERL_OBJECT
- if (!(PL_curinterp = sv_interp))
- return;
-#endif
-
#ifdef USE_THREADS
#ifndef FAKE_THREADS
/* Pass 1 on any remaining threads: detach joinables, join zombies */
retry_cleanup:
- MUTEX_LOCK(&threads_mutex);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ MUTEX_LOCK(&PL_threads_mutex);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: waiting for %d threads...\n",
- nthreads - 1));
+ PL_nthreads - 1));
for (t = thr->next; t != thr; t = t->next) {
MUTEX_LOCK(&t->mutex);
switch (ThrSTATE(t)) {
AV *av;
case THRf_ZOMBIE:
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joining zombie %p\n", t));
ThrSETSTATE(t, THRf_DEAD);
MUTEX_UNLOCK(&t->mutex);
- nthreads--;
+ PL_nthreads--;
/*
* The SvREFCNT_dec below may take a long time (e.g. av
* may contain an object scalar whose destructor gets
* called) so we have to unlock threads_mutex and start
* all over again.
*/
- MUTEX_UNLOCK(&threads_mutex);
+ MUTEX_UNLOCK(&PL_threads_mutex);
JOIN(t, &av);
SvREFCNT_dec((SV*)av);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joined zombie %p OK\n", t));
goto retry_cleanup;
case THRf_R_JOINABLE:
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: detaching thread %p\n", t));
ThrSETSTATE(t, THRf_R_DETACHED);
/*
* deadlock if it panics. It's only a breach of good style
* not a bug since they are unlocks not locks.
*/
- MUTEX_UNLOCK(&threads_mutex);
+ MUTEX_UNLOCK(&PL_threads_mutex);
DETACH(t);
MUTEX_UNLOCK(&t->mutex);
goto retry_cleanup;
default:
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: ignoring %p (state %u)\n",
t, ThrSTATE(t)));
MUTEX_UNLOCK(&t->mutex);
/* We leave the above "Pass 1" loop with threads_mutex still locked */
/* Pass 2 on remaining threads: wait for the thread count to drop to one */
- while (nthreads > 1)
+ while (PL_nthreads > 1)
{
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: final wait for %d threads\n",
- nthreads - 1));
- COND_WAIT(&nthreads_cond, &threads_mutex);
+ PL_nthreads - 1));
+ COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
}
/* At this point, we're the last thread */
- MUTEX_UNLOCK(&threads_mutex);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
- MUTEX_DESTROY(&threads_mutex);
- COND_DESTROY(&nthreads_cond);
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ MUTEX_DESTROY(&PL_threads_mutex);
+ COND_DESTROY(&PL_nthreads_cond);
#endif /* !defined(FAKE_THREADS) */
#endif /* USE_THREADS */
LEAVE;
FREETMPS;
-#ifdef MULTIPLICITY
- --ninterps;
-#endif
-
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = Nullcv;
+ PL_dirty = TRUE;
if (PL_sv_objcount) {
/*
* destructors and destructees still exist. Some sv's might remain.
* Non-referenced objects are on their own.
*/
-
- PL_dirty = TRUE;
sv_clean_objs();
}
/* call exit list functions */
while (PL_exitlistlen-- > 0)
- PL_exitlist[PL_exitlistlen].fn(PERL_OBJECT_THIS_ PL_exitlist[PL_exitlistlen].ptr);
+ PL_exitlist[PL_exitlistlen].fn(aTHXo_ PL_exitlist[PL_exitlistlen].ptr);
Safefree(PL_exitlist);
PL_minus_a = FALSE;
PL_minus_F = FALSE;
PL_doswitches = FALSE;
- PL_dowarn = FALSE;
+ PL_dowarn = G_WARN_OFF;
PL_doextract = FALSE;
PL_sawampersand = FALSE; /* must save all match strings */
PL_sawstudy = FALSE; /* do fbm_instr on all strings */
SvREFCNT_dec(hv);
FREETMPS;
- if (destruct_level >= 2) {
+ if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
- warn("Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
(long)PL_scopestack_ix);
if (PL_savestack_ix != 0)
- warn("Unbalanced saves: %ld more saves than restores\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Unbalanced saves: %ld more saves than restores\n",
(long)PL_savestack_ix);
if (PL_tmps_floor != -1)
- warn("Unbalanced tmps: %ld more allocs than frees\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
(long)PL_tmps_floor + 1);
if (cxstack_ix != -1)
- warn("Unbalanced context: %ld more PUSHes than POPs\n",
+ Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
(long)cxstack_ix + 1);
}
array = HvARRAY(PL_strtab);
hent = array[0];
for (;;) {
- if (hent) {
- warn("Unbalanced string table refcount: (%d) for \"%s\"",
+ if (hent && ckWARN_d(WARN_INTERNAL)) {
+ Perl_warner(aTHX_ WARN_INTERNAL,
+ "Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
HeVAL(hent) = Nullsv;
hent = HeNEXT(hent);
}
SvREFCNT_dec(PL_strtab);
- if (PL_sv_count != 0)
- warn("Scalars leaked: %ld\n", (long)PL_sv_count);
+ if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
sv_free_arenas();
Safefree(PL_origfilename);
Safefree(PL_archpat_auto);
Safefree(PL_reg_start_tmp);
+ if (PL_reg_curpm)
+ Safefree(PL_reg_curpm);
+ Safefree(PL_reg_poscache);
Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
Safefree(PL_op_mask);
nuke_stacks();
DEBUG_P(debprofdump());
#ifdef USE_THREADS
- MUTEX_DESTROY(&sv_mutex);
- MUTEX_DESTROY(&eval_mutex);
- COND_DESTROY(&eval_cond);
+ MUTEX_DESTROY(&PL_strtab_mutex);
+ MUTEX_DESTROY(&PL_sv_mutex);
+ MUTEX_DESTROY(&PL_eval_mutex);
+ MUTEX_DESTROY(&PL_cred_mutex);
+ COND_DESTROY(&PL_eval_cond);
+#ifdef EMULATE_ATOMIC_REFCOUNTS
+ MUTEX_DESTROY(&PL_svref_mutex);
+#endif /* EMULATE_ATOMIC_REFCOUNTS */
/* As the penultimate thing, free the non-arena SV for thrsv */
- Safefree(SvPVX(thrsv));
- Safefree(SvANY(thrsv));
- Safefree(thrsv);
- thrsv = Nullsv;
+ Safefree(SvPVX(PL_thrsv));
+ Safefree(SvANY(PL_thrsv));
+ Safefree(PL_thrsv);
+ PL_thrsv = Nullsv;
#endif /* USE_THREADS */
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
+ /* it could have accumulated taint magic */
+ if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
+ MAGIC* mg;
+ MAGIC* moremagic;
+ for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+ if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0)
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
+ }
+ }
/* we know that type >= SVt_PV */
SvOOK_off(PL_mess_sv);
Safefree(SvPVX(PL_mess_sv));
}
void
-#ifdef PERL_OBJECT
-CPerlObj::perl_free(void)
-#else
-perl_free(PerlInterpreter *sv_interp)
-#endif
+perl_free(pTHXx)
{
-#ifdef PERL_OBJECT
- Safefree(this);
+#if defined(PERL_OBJECT)
+ PerlMem_free(this);
#else
- if (!(PL_curinterp = sv_interp))
- return;
- Safefree(sv_interp);
+ PerlMem_free(aTHXx);
#endif
}
void
-#ifdef PERL_OBJECT
-CPerlObj::perl_atexit(void (*fn) (CPerlObj*,void *), void *ptr)
-#else
-perl_atexit(void (*fn) (void *), void *ptr)
-#endif
+Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
Renew(PL_exitlist, PL_exitlistlen+1, PerlExitListEntry);
PL_exitlist[PL_exitlistlen].fn = fn;
}
int
-#ifdef PERL_OBJECT
-CPerlObj::perl_parse(void (*xsinit) (CPerlObj*), int argc, char **argv, char **env)
-#else
-perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
-#endif
+perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
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 USE_THREADS
+ dTHX;
+#endif
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
- croak("suidperl is no longer needed since the kernel can now execute\n\
+ Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
setuid perl scripts securely.\n");
#endif
#endif
-#ifndef PERL_OBJECT
- if (!(PL_curinterp = sv_interp))
- return 255;
-#endif
-
-#if defined(NeXT) && defined(__DYNAMIC__)
+#if defined(__DYNAMIC__) && (defined(NeXT) || defined(__NeXT__))
_dyld_lookup_and_bind
("__environ", (unsigned long *) &environ_pointer, NULL);
#endif /* environ */
time(&PL_basetime);
oldscope = PL_scopestack_ix;
+ PL_dowarn = G_WARN_OFF;
- JMPENV_PUSH(ret);
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_parse_body), env, xsinit);
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;
}
+ return 0;
+}
+
+STATIC void *
+S_parse_body(pTHX_ 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;
+
+ XSINIT_t xsinit = va_arg(args, XSINIT_t);
sv_setpvn(PL_linestr,"",0);
- sv = newSVpv("",0); /* first used for -I flags */
+ sv = newSVpvn("",0); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
s = argv[0]+1;
reswitch:
switch (*s) {
+#ifndef PERL_STRICT_CR
+ case '\r':
+#endif
case ' ':
case '0':
case 'F':
case 'u':
case 'U':
case 'v':
+ case 'W':
+ case 'X':
case 'w':
if (s = moreswitches(s))
goto reswitch;
case 'e':
if (PL_euid != PL_uid || PL_egid != PL_gid)
- croak("No -e allowed in setuid scripts");
+ Perl_croak(aTHX_ "No -e allowed in setuid scripts");
if (!PL_e_script) {
- PL_e_script = newSVpv("",0);
+ PL_e_script = newSVpvn("",0);
filter_add(read_e_script, NULL);
}
if (*++s)
argc--,argv++;
}
else
- croak("No code specified for -e");
+ Perl_croak(aTHX_ "No code specified for -e");
sv_catpv(PL_e_script, "\n");
break;
if (*++s != ':') {
PL_Sv = newSVpv("print myconfig();",0);
#ifdef VMS
- sv_catpv(Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+ sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
#else
sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
-#if defined(DEBUGGING) || defined(NO_EMBED) || defined(MULTIPLICITY)
+#if defined(DEBUGGING) || defined(MULTIPLICITY)
sv_catpv(PL_Sv,"\" Compile-time options:");
# ifdef DEBUGGING
sv_catpv(PL_Sv," DEBUGGING");
# endif
-# ifdef NO_EMBED
- sv_catpv(Sv," NO_EMBED");
-# endif
# ifdef MULTIPLICITY
- sv_catpv(Sv," MULTIPLICITY");
+ sv_catpv(PL_Sv," MULTIPLICITY");
# endif
sv_catpv(PL_Sv,"\\n\",");
#endif
sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
if (PL_localpatches[i])
- sv_catpvf(PL_Sv,"\" \\t%s\\n\",",PL_localpatches[i]);
+ Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
}
}
#endif
- sv_catpvf(PL_Sv,"\" Built under %s\\n\"",OSNAME);
+ Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
#ifdef __DATE__
# ifdef __TIME__
- sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
+ Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
# else
- sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
+ Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
# endif
#endif
sv_catpv(PL_Sv, "; \
s--;
/* FALL THROUGH */
default:
- croak("Unrecognized switch: -%s (-h will show valid options)",s);
+ Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s);
}
}
switch_end:
- if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
- while (s && *s) {
- while (isSPACE(*s))
- s++;
- if (*s == '-') {
- s++;
- if (isSPACE(*s))
- continue;
+ if (
+#ifndef SECURE_INTERNAL_GETENV
+ !PL_tainting &&
+#endif
+ (s = PerlEnv_getenv("PERL5OPT"))) {
+ while (isSPACE(*s))
+ s++;
+ if (*s == '-' && *(s+1) == 'T')
+ PL_tainting = TRUE;
+ else {
+ while (s && *s) {
+ while (isSPACE(*s))
+ s++;
+ if (*s == '-') {
+ s++;
+ if (isSPACE(*s))
+ continue;
+ }
+ if (!*s)
+ break;
+ if (!strchr("DIMUdmw", *s))
+ Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
+ s = moreswitches(s);
}
- if (!*s)
- break;
- if (!strchr("DIMUdmw", *s))
- croak("Illegal switch in PERL5OPT: -%c", *s);
- s = moreswitches(s);
}
}
PL_min_intro_pending = 0;
PL_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));
+ av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
+ PL_curpad[0] = (SV*)newAV();
+ SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
+ CvOWNER(PL_compcv) = 0;
+ New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+ MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_THREADS */
comppadlist = newAV();
CvPADLIST(PL_compcv) = comppadlist;
boot_core_UNIVERSAL();
+ boot_core_xsutils();
if (xsinit)
- (*xsinit)(PERL_OBJECT_THIS); /* in case linked C routines want magical variables */
+ (*xsinit)(aTHXo); /* in case linked C routines want magical variables */
#if defined(VMS) || defined(WIN32) || defined(DJGPP)
init_os_extras();
#endif
+#ifdef USE_SOCKS
+ SOCKSinit(argv[0]);
+#endif
+
init_predump_symbols();
/* init_postdump_symbols not currently designed to be called */
/* more than once (ENV isn't cleared first, for example) */
PL_error_count = 0;
if (yyparse() || PL_error_count) {
if (PL_minus_c)
- croak("%s had compilation errors.\n", PL_origfilename);
+ Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
else {
- croak("Execution of %s aborted due to compilation errors.\n",
- PL_origfilename);
+ Perl_croak(aTHX_ "Execution of %s aborted due to compilation errors.\n",
+ PL_origfilename);
}
}
PL_curcop->cop_line = 0;
/* now that script is parsed, we can modify record separator */
SvREFCNT_dec(PL_rs);
PL_rs = SvREFCNT_inc(PL_nrs);
- sv_setsv(perl_get_sv("/", TRUE), PL_rs);
+ sv_setsv(get_sv("/", TRUE), PL_rs);
if (PL_do_undump)
my_unexec();
- if (PL_dowarn)
+ if (isWARN_ONCE)
gv_check(PL_defstash);
LEAVE;
ENTER;
PL_restartop = 0;
- JMPENV_POP;
- return 0;
+ return NULL;
}
int
-#ifdef PERL_OBJECT
-CPerlObj::perl_run(void)
-#else
-perl_run(PerlInterpreter *sv_interp)
-#endif
+perl_run(pTHXx)
{
- dSP;
+ dTHR;
I32 oldscope;
- dJMPENV;
int ret;
-
-#ifndef PERL_OBJECT
- if (!(PL_curinterp = sv_interp))
- return 255;
+#ifdef USE_THREADS
+ dTHX;
#endif
oldscope = PL_scopestack_ix;
- JMPENV_PUSH(ret);
+ redo_body:
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_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 *
+S_run_body(pTHX_ va_list args)
+{
+ dTHR;
+ I32 oldscope = va_arg(args, I32);
+
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
PL_sawampersand ? "Enabling" : "Omitting"));
if (!PL_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",
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%lx\n",
(unsigned long) thr));
-#endif /* USE_THREADS */
if (PL_minus_c) {
PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
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);
}
/* do it */
if (PL_restartop) {
- op = PL_restartop;
+ PL_op = PL_restartop;
PL_restartop = 0;
- CALLRUNOPS();
+ CALLRUNOPS(aTHX);
}
else if (PL_main_start) {
CvDEPTH(PL_main_cv) = 1;
- op = PL_main_start;
- CALLRUNOPS();
+ PL_op = PL_main_start;
+ CALLRUNOPS(aTHX);
}
my_exit(0);
/* NOTREACHED */
- return 0;
+ return NULL;
}
SV*
-perl_get_sv(char *name, I32 create)
+Perl_get_sv(pTHX_ const char *name, I32 create)
{
GV *gv;
#ifdef USE_THREADS
}
AV*
-perl_get_av(char *name, I32 create)
+Perl_get_av(pTHX_ const char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVAV);
if (create)
}
HV*
-perl_get_hv(char *name, I32 create)
+Perl_get_hv(pTHX_ const char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVHV);
if (create)
}
CV*
-perl_get_cv(char *name, I32 create)
+Perl_get_cv(pTHX_ const char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+ /* XXX unsafe for threads if eval_owner isn't held */
+ /* XXX this is probably not what they think they're getting.
+ * It has the same effect as "sub name;", i.e. just a forward
+ * declaration! */
if (create && !GvCVu(gv))
return newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, newSVpv(name,0)),
/* Be sure to refetch the stack pointer after calling these routines. */
I32
-perl_call_argv(char *sub_name, I32 flags, register char **argv)
+Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv)
/* See G_* flags in cop.h */
/* null terminated arg list */
}
PUTBACK;
}
- return perl_call_pv(sub_name, flags);
+ return call_pv(sub_name, flags);
}
I32
-perl_call_pv(char *sub_name, I32 flags)
+Perl_call_pv(pTHX_ const char *sub_name, I32 flags)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
- return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
+ return call_sv((SV*)get_cv(sub_name, TRUE), flags);
}
I32
-perl_call_method(char *methname, I32 flags)
+Perl_call_method(pTHX_ const char *methname, I32 flags)
/* name of the subroutine */
/* See G_* flags in cop.h */
{
dSP;
OP myop;
- if (!op)
- op = &myop;
+ if (!PL_op)
+ PL_op = &myop;
XPUSHs(sv_2mortal(newSVpv(methname,0)));
PUTBACK;
- pp_method(ARGS);
- if(op == &myop)
- op = Nullop;
- return perl_call_sv(*PL_stack_sp--, flags);
+ pp_method();
+ if(PL_op == &myop)
+ PL_op = Nullop;
+ return call_sv(*PL_stack_sp--, flags);
}
/* May be called with any of a CV, a GV, or an SV containing the name. */
I32
-perl_call_sv(SV *sv, I32 flags)
+Perl_call_sv(pTHX_ SV *sv, I32 flags)
/* See G_* flags in cop.h */
{
I32 retval;
I32 oldscope;
bool oldcatch = CATCH_GET;
- dJMPENV;
int ret;
- OP* oldop = op;
+ OP* oldop = PL_op;
if (flags & G_DISCARD) {
ENTER;
(flags & G_ARRAY) ? OPf_WANT_LIST :
OPf_WANT_SCALAR);
SAVEOP();
- op = (OP*)&myop;
+ PL_op = (OP*)&myop;
EXTEND(PL_stack_sp, 1);
*++PL_stack_sp = sv;
* curstash may be meaningless. */
&& (SvTYPE(sv) != SVt_PVCV || CvSTASH((CV*)sv) != PL_debstash)
&& !(flags & G_NODEBUG))
- op->op_private |= OPpENTERSUB_DB;
+ PL_op->op_private |= OPpENTERSUB_DB;
- if (flags & G_EVAL) {
- cLOGOP->op_other = op;
+ if (!(flags & G_EVAL)) {
+ /* G_NOCATCH is a hack for perl_vdie using this path to call
+ a __DIE__ handler */
+ if (!(flags & G_NOCATCH)) {
+ CATCH_SET(TRUE);
+ }
+ call_xbody((OP*)&myop, FALSE);
+ retval = PL_stack_sp - (PL_stack_base + oldmark);
+ if (!(flags & G_NOCATCH)) {
+ CATCH_SET(FALSE);
+ }
+ }
+ else {
+ cLOGOP->op_other = PL_op;
PL_markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
ENTER;
SAVETMPS;
- push_return(op->op_next);
+ push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_EVAL, PL_stack_sp);
PUSHEVAL(cx, 0, 0);
- PL_eval_root = op; /* Only needed so that goto works right. */
+ PL_eval_root = PL_op; /* Only needed so that goto works right. */
- PL_in_eval = 1;
+ PL_in_eval = EVAL_INEVAL;
if (flags & G_KEEPERR)
- PL_in_eval |= 4;
+ PL_in_eval |= EVAL_KEEPERR;
else
sv_setpv(ERRSV,"");
}
PL_markstack_ptr++;
- JMPENV_PUSH(ret);
+ redo_body:
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_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");
+ Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
/* NOTREACHED */
case 3:
if (PL_restartop) {
- op = 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 (op == (OP*)&myop)
- op = pp_entersub(ARGS);
- if (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;
FREETMPS;
LEAVE;
}
- op = oldop;
+ PL_op = oldop;
return retval;
}
+STATIC void *
+S_call_body(pTHX_ va_list args)
+{
+ OP *myop = va_arg(args, OP*);
+ int is_eval = va_arg(args, int);
+
+ call_xbody(myop, is_eval);
+ return NULL;
+}
+
+STATIC void
+S_call_xbody(pTHX_ OP *myop, int is_eval)
+{
+ dTHR;
+
+ if (PL_op == myop) {
+ if (is_eval)
+ PL_op = Perl_pp_entereval(aTHX);
+ else
+ PL_op = Perl_pp_entersub(aTHX);
+ }
+ if (PL_op)
+ CALLRUNOPS(aTHX);
+}
+
/* Eval a string. The G_EVAL flag is always assumed. */
I32
-perl_eval_sv(SV *sv, I32 flags)
+Perl_eval_sv(pTHX_ SV *sv, I32 flags)
/* See G_* flags in cop.h */
{
I32 oldmark = SP - PL_stack_base;
I32 retval;
I32 oldscope;
- dJMPENV;
int ret;
- OP* oldop = op;
+ OP* oldop = PL_op;
if (flags & G_DISCARD) {
ENTER;
}
SAVEOP();
- op = (OP*)&myop;
- Zero(op, 1, UNOP);
+ PL_op = (OP*)&myop;
+ Zero(PL_op, 1, UNOP);
EXTEND(PL_stack_sp, 1);
*++PL_stack_sp = sv;
oldscope = PL_scopestack_ix;
if (flags & G_KEEPERR)
myop.op_flags |= OPf_SPECIAL;
- JMPENV_PUSH(ret);
+ redo_body:
+ CALLPROTECT(aTHX_ &ret, MEMBER_TO_FPTR(S_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");
+ Perl_croak(aTHX_ "Callback called exit");
my_exit_jump();
/* NOTREACHED */
case 3:
if (PL_restartop) {
- op = 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 (op == (OP*)&myop)
- op = pp_entereval(ARGS);
- if (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;
FREETMPS;
LEAVE;
}
- op = oldop;
+ PL_op = oldop;
return retval;
}
SV*
-perl_eval_pv(char *p, I32 croak_on_error)
+Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error)
{
dSP;
SV* sv = newSVpv(p, 0);
PUSHMARK(SP);
- perl_eval_sv(sv, G_SCALAR);
+ eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
SPAGAIN;
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(ERRSV))
- croak(SvPVx(ERRSV, PL_na));
+ if (croak_on_error && SvTRUE(ERRSV)) {
+ STRLEN n_a;
+ Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
+ }
return sv;
}
/* Require a module. */
void
-perl_require_pv(char *pv)
+Perl_require_pv(pTHX_ const char *pv)
{
SV* sv;
dSP;
sv_setpv(sv, "require '");
sv_catpv(sv, pv);
sv_catpv(sv, "'");
- perl_eval_sv(sv, G_DISCARD);
+ eval_sv(sv, G_DISCARD);
SPAGAIN;
POPSTACK;
}
void
-magicname(char *sym, char *name, I32 namlen)
+Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
{
register GV *gv;
}
STATIC void
-usage(char *name) /* XXX move this out into a module ? */
-
+S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
{
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that opton. Others? */
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
"-c check syntax only (runs BEGIN and END blocks)",
-"-d[:debugger] run scripts under debugger",
-"-D[number/list] set debugging flags (argument is a bit mask or flags)",
-"-e 'command' one line of script. Several -e's allowed. Omit [programfile].",
-"-F/pattern/ split() pattern for autosplit (-a). The //'s are optional.",
-"-i[extension] edit <> files in place (make backup if extension supplied)",
-"-Idirectory specify @INC/#include directory (may be used more than once)",
+"-d[:debugger] run program under debugger",
+"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
+"-e 'command' one line of program (several -e's allowed, omit programfile)",
+"-F/pattern/ split() pattern for -a switch (//'s are optional)",
+"-i[extension] edit <> files in place (makes backup if extension supplied)",
+"-Idirectory specify @INC/#include directory (several -I's allowed)",
"-l[octal] enable line ending processing, specifies line terminator",
-"-[mM][-]module.. executes `use/no module...' before executing your script.",
-"-n assume 'while (<>) { ... }' loop around your script",
-"-p assume loop like -n but print line also like sed",
-"-P run script through C preprocessor before compilation",
-"-s enable some switch parsing for switches after script name",
-"-S look for the script using PATH environment variable",
-"-T turn on tainting checks",
-"-u dump core after parsing script",
+"-[mM][-]module execute `use/no module...' before executing program",
+"-n assume 'while (<>) { ... }' loop around program",
+"-p assume loop like -n but print line also, like sed",
+"-P run program through C preprocessor before compilation",
+"-s enable rudimentary parsing for switches after programfile",
+"-S look for programfile using PATH environment variable",
+"-T enable tainting checks",
+"-u dump core after parsing program",
"-U allow unsafe operations",
-"-v print version number, patchlevel plus VERY IMPORTANT perl info",
-"-V[:variable] print perl configuration information",
-"-w TURN WARNINGS ON FOR COMPILATION OF YOUR SCRIPT. Recommended.",
+"-v print version, subversion (includes VERY IMPORTANT perl info)",
+"-V[:variable] print configuration summary (or a single Config.pm variable)",
+"-w enable many useful warnings (RECOMMENDED)",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
"\n",
NULL
/* This routine handles any switches that can be given during run */
char *
-moreswitches(char *s)
+Perl_moreswitches(pTHX_ char *s)
{
I32 numlen;
U32 rschar;
if (rschar & ~((U8)~0))
PL_nrs = &PL_sv_undef;
else if (!rschar && numlen >= 2)
- PL_nrs = newSVpv("", 0);
+ PL_nrs = newSVpvn("", 0);
else {
char ch = rschar;
- PL_nrs = newSVpv(&ch, 1);
+ PL_nrs = newSVpvn(&ch, 1);
}
return s + numlen;
}
forbid_setid("-d");
s++;
if (*s == ':' || *s == '=') {
- my_setenv("PERL5DB", form("use Devel::%s;", ++s));
+ my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s));
s += strlen(s);
}
if (!PL_perldb) {
}
return s;
case 'D':
+ {
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
- static char debopts[] = "psltocPmfrxuLHXD";
+ static char debopts[] = "psltocPmfrxuLHXDS";
char *d;
for (s++; *s && (d = strchr(debopts,*s)); s++)
}
PL_debug |= 0x80000000;
#else
- warn("Recompile perl with -DDEBUGGING to use -D switch\n");
+ dTHR;
+ if (ckWARN_d(WARN_DEBUGGING))
+ Perl_warner(aTHX_ WARN_DEBUGGING,
+ "Recompile perl with -DDEBUGGING to use -D switch\n");
for (s++; isALNUM(*s); s++) ;
#endif
/*SUPPRESS 530*/
return s;
+ }
case 'h':
usage(PL_origargv[0]);
PerlProc_exit(0);
s = e;
}
else
- croak("No space allowed after -I");
+ Perl_croak(aTHX_ "No space allowed after -I");
return s;
case 'l':
PL_minus_l = TRUE;
sv_catpv(sv, start);
if (*(start-1) == 'm') {
if (*s != '\0')
- croak("Can't use '%c' after -mname", *s);
+ Perl_croak(aTHX_ "Can't use '%c' after -mname", *s);
sv_catpv( sv, " ()");
}
} else {
av_push(PL_preambleav, sv);
}
else
- croak("No space allowed after -%c", *(s-1));
+ Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
return s;
case 'n':
PL_minus_n = TRUE;
return s;
case 'T':
if (!PL_tainting)
- croak("Too late for \"-T\" option");
+ Perl_croak(aTHX_ "Too late for \"-T\" option");
s++;
return s;
case 'u':
s++;
return s;
case 'v':
-#if defined(SUBVERSION) && SUBVERSION > 0
- printf("\nThis is perl, version 5.%03d_%02d built for %s",
- PATCHLEVEL, SUBVERSION, ARCHNAME);
+#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
+ printf("\nThis is perl, version %d.%03d_%02d built for %s",
+ PERL_REVISION, PERL_VERSION, PERL_SUBVERSION, ARCHNAME);
#else
printf("\nThis is perl, version %s built for %s",
- patchlevel, ARCHNAME);
+ PL_patchlevel, ARCHNAME);
#endif
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
#endif
- printf("\n\nCopyright 1987-1998, Larry Wall\n");
+ printf("\n\nCopyright 1987-1999, Larry Wall\n");
#ifdef MSDOS
printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
#endif
#ifdef DJGPP
printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
- printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1998\n");
+ printf("djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n");
#endif
#ifdef OS2
printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
- "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
+ "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
printf("atariST series port, ++jrb bammi@cadence.com\n");
#endif
#ifdef __BEOS__
- printf("BeOS port Copyright Tom Spindler, 1997-1998\n");
+ printf("BeOS port Copyright Tom Spindler, 1997-1999\n");
#endif
#ifdef MPE
- printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
+ printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n");
+#endif
+#ifdef OEMVS
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1999\n");
+#endif
+#ifdef __VOS__
+ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+#endif
+#ifdef __OPEN_VM
+ printf("VM/ESA port by Neale Ferguson, 1998-1999\n");
+#endif
+#ifdef POSIX_BC
+ printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n");
+#endif
+#ifdef __MINT__
+ printf("MiNT port by Guido Flohr, 1997-1999\n");
#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
PerlProc_exit(0);
case 'w':
- PL_dowarn = TRUE;
+ if (! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+ s++;
+ return s;
+ case 'W':
+ PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ PL_compiling.cop_warnings = WARN_ALL ;
+ s++;
+ return s;
+ case 'X':
+ PL_dowarn = G_WARN_ALL_OFF;
+ PL_compiling.cop_warnings = WARN_NONE ;
s++;
return s;
case '*':
break;
case '-':
case 0:
-#ifdef WIN32
+#if defined(WIN32) || !defined(PERL_STRICT_CR)
case '\r':
#endif
case '\n':
return s+1;
/* FALL THROUGH */
default:
- croak("Can't emulate -%.1s on #! line",s);
+ Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s);
}
return Nullch;
}
/* Known to work with -DUNEXEC and using unexelf.c from GNU emacs-20.2 */
void
-my_unexec(void)
+Perl_my_unexec(pTHX)
{
#ifdef UNEXEC
SV* prog;
prog = newSVpv(BIN_EXP, 0);
sv_catpv(prog, "/perl");
- file = newSVpv(origfilename, 0);
+ file = newSVpv(PL_origfilename, 0);
sv_catpv(file, ".perldump");
unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0);
/* initialize curinterp */
STATIC void
-init_interp(void)
+S_init_interp(pTHX)
{
#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_START { \
+ PL_chopset = " \n-"; \
+ PL_copline = NOLINE; \
+ PL_curcop = &PL_compiling;\
+ PL_curcopdb = NULL; \
+ PL_dbargs = 0; \
+ PL_dlmax = 128; \
+ PL_dumpindent = 4; \
+ PL_laststatval = -1; \
+ PL_laststype = OP_STAT; \
+ PL_maxscream = -1; \
+ PL_maxsysfd = MAXSYSFD; \
+ PL_statname = Nullsv; \
+ PL_tmps_floor = -1; \
+ PL_tmps_ix = -1; \
+ PL_op_mask = NULL; \
+ PL_dlmax = 128; \
+ PL_laststatval = -1; \
+ PL_laststype = OP_STAT; \
+ PL_mess_sv = Nullsv; \
+ PL_splitstr = " "; \
+ PL_generation = 100; \
+ PL_exitlist = NULL; \
+ PL_exitlistlen = 0; \
+ PL_regindent = 0; \
+ PL_in_clean_objs = FALSE; \
+ PL_in_clean_all = FALSE; \
+ PL_profiledata = NULL; \
+ PL_rsfp = Nullfp; \
+ PL_rsfp_filters = Nullav; \
+ PL_dirty = FALSE; \
} 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;
+# define PERLVARA(var,n,type)
+# if defined(PERL_IMPLICIT_CONTEXT)
+# if defined(USE_THREADS)
+# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# else /* !USE_THREADS */
+# define PERLVARI(var,type,init) aTHX->var = init;
+# define PERLVARIC(var,type,init) aTHX->var = init;
+# endif /* USE_THREADS */
+# else
+# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# endif
# include "intrpvar.h"
# ifndef USE_THREADS
# include "thrdvar.h"
# endif
# undef PERLVAR
+# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
-# else
+# else
# define PERLVAR(var,type)
-# define PERLVARI(var,type,init) var = init;
-# define PERLVARIC(var,type,init) var = init;
+# define PERLVARA(var,n,type)
+# define PERLVARI(var,type,init) PL_##var = init;
+# define PERLVARIC(var,type,init) PL_##var = init;
# include "intrpvar.h"
# ifndef USE_THREADS
# include "thrdvar.h"
# endif
# undef PERLVAR
+# undef PERLVARA
# undef PERLVARI
# undef PERLVARIC
# endif
}
STATIC void
-init_main_stash(void)
+S_init_main_stash(pTHX)
{
dTHR;
GV *gv;
about not iterating on it, and not adding tie magic to it.
It is properly deallocated in perl_destruct() */
PL_strtab = newHV();
+#ifdef USE_THREADS
+ MUTEX_INIT(&PL_strtab_mutex);
+#endif
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
PL_curstash = PL_defstash = newHV();
- PL_curstname = newSVpv("main",4);
+ PL_curstname = newSVpvn("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
GvMULTI_on(PL_errgv);
PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
- (void)form("%240s",""); /* Preallocate temp - for immediate signals. */
+ (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
sv_setpvn(ERRSV, "", 0);
PL_curstash = PL_defstash;
PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
PL_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);
+ sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
STATIC void
-open_script(char *scriptname, bool dosearch, SV *sv, int *fdscript)
+S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
{
dTHR;
register char *s;
}
else if (PL_preprocess) {
char *cpp_cfg = CPPSTDIN;
- SV *cpp = newSVpv("",0);
+ SV *cpp = newSVpvn("",0);
SV *cmd = NEWSV(0,0);
if (strEQ(cpp_cfg, "cppstdin"))
- sv_catpvf(cpp, "%s/", BIN_EXP);
+ Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
sv_catpv(cpp, cpp_cfg);
sv_catpv(sv,"-I");
sv_catpv(sv,PRIVLIB_EXP);
#ifdef MSDOS
- sv_setpvf(cmd, "\
+ Perl_sv_setpvf(aTHX_ cmd, "\
sed %s -e \"/^[^#]/b\" \
-e \"/^#[ ]*include[ ]/b\" \
-e \"/^#[ ]*define[ ]/b\" \
-e \"/^#[ ]*endif/b\" \
-e \"s/^#.*//\" \
%s | %_ -C %_ %s",
- (doextract ? "-e \"1,/^#/d\n\"" : ""),
+ (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
- sv_setpvf(cmd, "\
+# ifdef __OPEN_VM
+ Perl_sv_setpvf(aTHX_ cmd, "\
+%s %s -e '/^[^#]/b' \
+ -e '/^#[ ]*include[ ]/b' \
+ -e '/^#[ ]*define[ ]/b' \
+ -e '/^#[ ]*if[ ]/b' \
+ -e '/^#[ ]*ifdef[ ]/b' \
+ -e '/^#[ ]*ifndef[ ]/b' \
+ -e '/^#[ ]*else/b' \
+ -e '/^#[ ]*elif[ ]/b' \
+ -e '/^#[ ]*undef[ ]/b' \
+ -e '/^#[ ]*endif/b' \
+ -e 's/^[ ]*#.*//' \
+ %s | %_ %_ %s",
+# else
+ Perl_sv_setpvf(aTHX_ cmd, "\
%s %s -e '/^[^#]/b' \
-e '/^#[ ]*include[ ]/b' \
-e '/^#[ ]*define[ ]/b' \
-e '/^#[ ]*endif/b' \
-e 's/^[ ]*#.*//' \
%s | %_ -C %_ %s",
+# endif
#ifdef LOC_SED
LOC_SED,
#else
scriptname, cpp, sv, CPPMINUS);
PL_doextract = FALSE;
#ifdef IAMSUID /* actually, this is caught earlier */
- if (euid != uid && !euid) { /* if running suidperl */
+ if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
#ifdef HAS_SETEUID
- (void)seteuid(uid); /* musn't stay setuid root */
+ (void)seteuid(PL_uid); /* musn't stay setuid root */
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1, uid);
+ (void)setreuid((Uid_t)-1, PL_uid);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
+ (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
#else
- PerlProc_setuid(uid);
+ PerlProc_setuid(PL_uid);
#endif
#endif
#endif
- if (PerlProc_geteuid() != uid)
- croak("Can't do seteuid!\n");
+ if (PerlProc_geteuid() != PL_uid)
+ Perl_croak(aTHX_ "Can't do seteuid!\n");
}
#endif /* IAMSUID */
PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
if (!PL_rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
- statbuf.st_mode & (S_ISUID|S_ISGID)) {
+ if (PL_euid &&
+ PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&PL_statbuf) >= 0 &&
+ PL_statbuf.st_mode & (S_ISUID|S_ISGID))
+ {
/* try again */
- PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
- croak("Can't do setuid\n");
+ PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
+ Perl_croak(aTHX_ "Can't do setuid\n");
}
#endif
#endif
- croak("Can't open perl script \"%s\": %s\n",
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
SvPVX(GvSV(PL_curcop->cop_filegv)), Strerror(errno));
}
}
+/* Mention
+ * I_SYSSTATVFS HAS_FSTATVFS
+ * I_SYSMOUNT
+ * I_STATFS HAS_FSTATFS
+ * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
+ * here so that metaconfig picks them up. */
+
+#ifdef IAMSUID
+STATIC int
+S_fd_on_nosuid_fs(pTHX_ int fd)
+{
+ int on_nosuid = 0;
+ int check_okay = 0;
+/*
+ * Preferred order: fstatvfs(), fstatfs(), getmntent().
+ * fstatvfs() is UNIX98.
+ * fstatfs() is BSD.
+ * getmntent() is O(number-of-mounted-filesystems) and can hang.
+ */
+
+# ifdef HAS_FSTATVFS
+ struct statvfs stfs;
+ check_okay = fstatvfs(fd, &stfs) == 0;
+ on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
+# else
+# if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
+ struct statfs stfs;
+ check_okay = fstatfs(fd, &stfs) == 0;
+# undef PERL_MOUNT_NOSUID
+# if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
+# define PERL_MOUNT_NOSUID MNT_NOSUID
+# endif
+# if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
+# define PERL_MOUNT_NOSUID MS_NOSUID
+# endif
+# if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
+# define PERL_MOUNT_NOSUID M_NOSUID
+# endif
+# ifdef PERL_MOUNT_NOSUID
+ on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
+# endif
+# else
+# if defined(HAS_GETMNTENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
+ FILE *mtab = fopen("/etc/mtab", "r");
+ struct mntent *entry;
+ struct stat stb, fsb;
+
+ if (mtab && (fstat(fd, &stb) == 0)) {
+ while (entry = getmntent(mtab)) {
+ if (stat(entry->mnt_dir, &fsb) == 0
+ && fsb.st_dev == stb.st_dev)
+ {
+ /* found the filesystem */
+ check_okay = 1;
+ if (hasmntopt(entry, MNTOPT_NOSUID))
+ on_nosuid = 1;
+ break;
+ } /* A single fs may well fail its stat(). */
+ }
+ }
+ if (mtab)
+ fclose(mtab);
+# endif /* mntent */
+# endif /* statfs */
+# endif /* statvfs */
+ if (!check_okay)
+ Perl_croak(aTHX_ "Can't check filesystem of script \"%s\"", PL_origfilename);
+ return on_nosuid;
+}
+#endif /* IAMSUID */
+
STATIC void
-validate_suid(char *validarg, char *scriptname, int fdscript)
+S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
{
int which;
dTHR;
char *s, *s2;
- if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
- croak("Can't stat script \"%s\"",origfilename);
- if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
+ if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
+ Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
+ if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
+ STRLEN n_a;
#ifdef IAMSUID
#ifndef HAS_SETREUID
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
- croak("Permission denied");
+ if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
+ Perl_croak(aTHX_ "Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
* with a simple stat of the file, and then compare device and
if (
#ifdef HAS_SETREUID
- setreuid(euid,uid) < 0
+ setreuid(PL_euid,PL_uid) < 0
#else
# if HAS_SETRESUID
- setresuid(euid,uid,(Uid_t)-1) < 0
+ setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
# endif
#endif
- || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
- croak("Can't swap uid and euid"); /* really paranoid */
- if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
- croak("Permission denied"); /* testing full pathname here */
- if (tmpstatbuf.st_dev != statbuf.st_dev ||
- tmpstatbuf.st_ino != statbuf.st_ino) {
- (void)PerlIO_close(rsfp);
- if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
- PerlIO_printf(rsfp,
+ || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
+ Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
+ if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
+ Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
+#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
+ if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
+ Perl_croak(aTHX_ "Permission denied");
+#endif
+ if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
+ tmpstatbuf.st_ino != PL_statbuf.st_ino) {
+ (void)PerlIO_close(PL_rsfp);
+ if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
+ PerlIO_printf(PL_rsfp,
"User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
(Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
- (long)uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
- (long)statbuf.st_dev, (long)statbuf.st_ino,
- SvPVX(GvSV(curcop->cop_filegv)),
- (long)statbuf.st_uid, (long)statbuf.st_gid);
- (void)PerlProc_pclose(rsfp);
+ (long)PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino,
+ (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino,
+ SvPVX(GvSV(PL_curcop->cop_filegv)),
+ (long)PL_statbuf.st_uid, (long)PL_statbuf.st_gid);
+ (void)PerlProc_pclose(PL_rsfp);
}
- croak("Permission denied\n");
+ Perl_croak(aTHX_ "Permission denied\n");
}
if (
#ifdef HAS_SETREUID
- setreuid(uid,euid) < 0
+ setreuid(PL_uid,PL_euid) < 0
#else
# if defined(HAS_SETRESUID)
- setresuid(uid,euid,(Uid_t)-1) < 0
+ setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
# endif
#endif
- || PerlProc_getuid() != uid || PerlProc_geteuid() != euid)
- croak("Can't reswap uid and euid");
- if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
- croak("Permission denied\n");
+ || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
+ Perl_croak(aTHX_ "Can't reswap uid and euid");
+ if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
+ Perl_croak(aTHX_ "Permission denied\n");
}
#endif /* HAS_SETREUID */
#endif /* IAMSUID */
- if (!S_ISREG(statbuf.st_mode))
- croak("Permission denied");
- if (statbuf.st_mode & S_IWOTH)
- croak("Setuid/gid script is writable by world");
- doswitches = FALSE; /* -s is insecure in suid */
- curcop->cop_line++;
- if (sv_gets(linestr, rsfp, 0) == Nullch ||
- strnNE(SvPV(linestr,na),"#!",2) ) /* required even on Sys V */
- croak("No #! line");
- s = SvPV(linestr,na)+2;
+ if (!S_ISREG(PL_statbuf.st_mode))
+ Perl_croak(aTHX_ "Permission denied");
+ if (PL_statbuf.st_mode & S_IWOTH)
+ Perl_croak(aTHX_ "Setuid/gid script is writable by world");
+ PL_doswitches = FALSE; /* -s is insecure in suid */
+ PL_curcop->cop_line++;
+ if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
+ strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
+ Perl_croak(aTHX_ "No #! line");
+ s = SvPV(PL_linestr,n_a)+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
- for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
+ for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
(isDIGIT(s2[-1]) || strchr("._-", s2[-1]))); s2--) ;
if (strnNE(s2-4,"perl",4) && strnNE(s-9,"perl",4)) /* sanity check */
- croak("Not a perl script");
+ Perl_croak(aTHX_ "Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
* #! arg must be what we saw above. They can invoke it by
len = strlen(validarg);
if (strEQ(validarg," PHOOEY ") ||
strnNE(s,validarg,len) || !isSPACE(s[len]))
- croak("Args must match #! line");
+ Perl_croak(aTHX_ "Args must match #! line");
#ifndef IAMSUID
- if (euid != uid && (statbuf.st_mode & S_ISUID) &&
- euid == statbuf.st_uid)
- if (!do_undump)
- croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+ if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
+ PL_euid == PL_statbuf.st_uid)
+ if (!PL_do_undump)
+ Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* IAMSUID */
- if (euid) { /* oops, we're not the setuid root perl */
- (void)PerlIO_close(rsfp);
+ if (PL_euid) { /* oops, we're not the setuid root perl */
+ (void)PerlIO_close(PL_rsfp);
#ifndef IAMSUID
/* try again */
- PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(Perl_form(aTHX_ "%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
#endif
- croak("Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid\n");
}
- if (statbuf.st_mode & S_ISGID && statbuf.st_gid != egid) {
+ if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
#ifdef HAS_SETEGID
- (void)setegid(statbuf.st_gid);
+ (void)setegid(PL_statbuf.st_gid);
#else
#ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1,statbuf.st_gid);
+ (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
#else
#ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
+ (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
#else
- PerlProc_setgid(statbuf.st_gid);
+ PerlProc_setgid(PL_statbuf.st_gid);
#endif
#endif
#endif
- if (PerlProc_getegid() != statbuf.st_gid)
- croak("Can't do setegid!\n");
+ if (PerlProc_getegid() != PL_statbuf.st_gid)
+ Perl_croak(aTHX_ "Can't do setegid!\n");
}
- if (statbuf.st_mode & S_ISUID) {
- if (statbuf.st_uid != euid)
+ if (PL_statbuf.st_mode & S_ISUID) {
+ if (PL_statbuf.st_uid != PL_euid)
#ifdef HAS_SETEUID
- (void)seteuid(statbuf.st_uid); /* all that for this */
+ (void)seteuid(PL_statbuf.st_uid); /* all that for this */
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1,statbuf.st_uid);
+ (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
+ (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
#else
- PerlProc_setuid(statbuf.st_uid);
+ PerlProc_setuid(PL_statbuf.st_uid);
#endif
#endif
#endif
- if (PerlProc_geteuid() != statbuf.st_uid)
- croak("Can't do seteuid!\n");
+ if (PerlProc_geteuid() != PL_statbuf.st_uid)
+ Perl_croak(aTHX_ "Can't do seteuid!\n");
}
- else if (uid) { /* oops, mustn't run as root */
+ else if (PL_uid) { /* oops, mustn't run as root */
#ifdef HAS_SETEUID
- (void)seteuid((Uid_t)uid);
+ (void)seteuid((Uid_t)PL_uid);
#else
#ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1,(Uid_t)uid);
+ (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
#else
#ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
+ (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
#else
- PerlProc_setuid((Uid_t)uid);
+ PerlProc_setuid((Uid_t)PL_uid);
#endif
#endif
#endif
- if (PerlProc_geteuid() != uid)
- croak("Can't do seteuid!\n");
+ if (PerlProc_geteuid() != PL_uid)
+ Perl_croak(aTHX_ "Can't do seteuid!\n");
}
init_ids();
- if (!cando(S_IXUSR,TRUE,&statbuf))
- croak("Permission denied\n"); /* they can't do this */
+ if (!cando(S_IXUSR,TRUE,&PL_statbuf))
+ Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
}
#ifdef IAMSUID
- else if (preprocess)
- croak("-P not allowed for setuid/setgid script\n");
+ else if (PL_preprocess)
+ Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
else if (fdscript >= 0)
- croak("fd script not allowed in suidperl\n");
+ Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
else
- croak("Script is not setuid/setgid in suidperl\n");
+ Perl_croak(aTHX_ "Script is not setuid/setgid in suidperl\n");
/* We absolutely must clear out any saved ids here, so we */
/* exec the real perl, substituting fd script for scriptname. */
/* (We pass script name as "subdir" of fd, which perl will grok.) */
- PerlIO_rewind(rsfp);
- PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
- for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
- if (!origargv[which])
- croak("Permission denied");
- origargv[which] = savepv(form("/dev/fd/%d/%s",
- PerlIO_fileno(rsfp), origargv[which]));
+ PerlIO_rewind(PL_rsfp);
+ PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
+ if (!PL_origargv[which])
+ Perl_croak(aTHX_ "Permission denied");
+ PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
+ PerlIO_fileno(PL_rsfp), PL_origargv[which]));
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
+ fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
- PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
- croak("Can't do setuid\n");
+ PerlProc_execv(Perl_form(aTHX_ "%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
+ Perl_croak(aTHX_ "Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
dTHR;
- PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
- if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
+ PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */
+ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
||
- (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
+ (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
)
- if (!do_undump)
- croak("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
+ if (!PL_do_undump)
+ Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* not set-id, must be wrapped */
}
STATIC void
-find_beginning(void)
+S_find_beginning(pTHX)
{
register char *s, *s2;
forbid_setid("-x");
while (PL_doextract) {
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch)
- croak("No Perl script found in input\n");
+ Perl_croak(aTHX_ "No Perl script found in input\n");
if (*s == '#' && s[1] == '!' && (s = instr(s,"perl"))) {
PerlIO_ungetc(PL_rsfp, '\n'); /* to keep line count right */
PL_doextract = FALSE;
while (s = moreswitches(s)) ;
}
if (PL_cddir && PerlDir_chdir(PL_cddir) < 0)
- croak("Can't chdir to %s",PL_cddir);
+ Perl_croak(aTHX_ "Can't chdir to %s",PL_cddir);
}
}
}
STATIC void
-init_ids(void)
+S_init_ids(pTHX)
{
- PL_uid = (int)PerlProc_getuid();
- PL_euid = (int)PerlProc_geteuid();
- PL_gid = (int)PerlProc_getgid();
- PL_egid = (int)PerlProc_getegid();
+ PL_uid = PerlProc_getuid();
+ PL_euid = PerlProc_geteuid();
+ PL_gid = PerlProc_getgid();
+ PL_egid = PerlProc_getegid();
#ifdef VMS
- uid |= gid << 16;
- euid |= egid << 16;
+ PL_uid |= PL_gid << 16;
+ PL_euid |= PL_egid << 16;
#endif
PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
}
STATIC void
-forbid_setid(char *s)
+S_forbid_setid(pTHX_ char *s)
{
if (PL_euid != PL_uid)
- croak("No %s allowed while running setuid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setuid", s);
if (PL_egid != PL_gid)
- croak("No %s allowed while running setgid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setgid", s);
}
-STATIC void
-init_debugger(void)
+void
+Perl_init_debugger(pTHX)
{
dTHR;
+ HV *ostash = PL_curstash;
+
PL_curstash = PL_debstash;
PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(PL_dbargs);
PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
PL_DBsingle = GvSV((gv_fetchpv("single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_curstash = PL_defstash;
+ PL_curstash = ostash;
}
#ifndef STRESS_REALLOC
#endif
void
-init_stacks(ARGSproto)
+Perl_init_stacks(pTHX)
{
/* start with 128-item stack and 8K cxstack */
PL_curstackinfo = new_stackinfo(REASONABLE(128),
#undef REASONABLE
STATIC void
-nuke_stacks(void)
+S_nuke_stacks(pTHX)
{
dTHR;
while (PL_curstackinfo->si_next)
#endif
STATIC void
-init_lexer(void)
+S_init_lexer(pTHX)
{
#ifdef PERL_OBJECT
PerlIO *tmpfp;
PL_rsfp = Nullfp;
lex_start(PL_linestr);
PL_rsfp = tmpfp;
- PL_subname = newSVpv("main",4);
+ PL_subname = newSVpvn("main",4);
}
STATIC void
-init_predump_symbols(void)
+S_init_predump_symbols(pTHX)
{
dTHR;
GV *tmpgv;
GV *othergv;
+ IO *io;
- sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
+ sv_setpvn(get_sv("\"", TRUE), " ", 1);
PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(PL_stdingv);
- IoIFP(GvIOp(PL_stdingv)) = PerlIO_stdin();
+ io = GvIOp(PL_stdingv);
+ IoIFP(io) = PerlIO_stdin();
tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_stdingv));
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO);
GvMULTI_on(tmpgv);
- IoOFP(GvIOp(tmpgv)) = IoIFP(GvIOp(tmpgv)) = PerlIO_stdout();
+ io = GvIOp(tmpgv);
+ IoOFP(io) = IoIFP(io) = PerlIO_stdout();
setdefout(tmpgv);
tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(PL_defoutgv));
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
GvMULTI_on(othergv);
- IoOFP(GvIOp(othergv)) = IoIFP(GvIOp(othergv)) = PerlIO_stderr();
+ io = GvIOp(othergv);
+ IoOFP(io) = IoIFP(io) = PerlIO_stderr();
tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
GvMULTI_on(tmpgv);
- GvIOp(tmpgv) = (IO*)SvREFCNT_inc(GvIOp(othergv));
+ GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
PL_statname = NEWSV(66,0); /* last filename we did stat on */
}
STATIC void
-init_postdump_symbols(register int argc, register char **argv, register char **env)
+S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
dTHR;
char *s;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, PL_envgv, 'E');
-#ifndef VMS /* VMS doesn't have environ array */
+#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */
/* Note that if the supplied env parameter is actually a copy
of the global environ then it may now point to free'd memory
if the environment has been modified since. To avoid this
}
STATIC void
-init_perllib(void)
+S_init_perllib(pTHX)
{
char *s;
if (!PL_tainting) {
incpush(SITELIB_EXP, FALSE);
#endif
#endif
+#if defined(PERL_VENDORLIB_EXP)
+#if defined(WIN32)
+ incpush(PERL_VENDORLIB_EXP, TRUE);
+#else
+ incpush(PERL_VENDORLIB_EXP, FALSE);
+#endif
+#endif
if (!PL_tainting)
incpush(".", FALSE);
}
#endif
STATIC void
-incpush(char *p, int addsubdirs)
+S_incpush(pTHX_ char *p, int addsubdirs)
{
SV *subdir = Nullsv;
sprintf(PL_archpat_auto, "/%s/%s/auto", ARCHNAME, PL_patchlevel);
#ifdef VMS
for (len = sizeof(ARCHNAME) + 2;
- archpat_auto[len] != '\0' && archpat_auto[len] != '/'; len++)
- if (archpat_auto[len] == '.') archpat_auto[len] = '_';
+ PL_archpat_auto[len] != '\0' && PL_archpat_auto[len] != '/'; len++)
+ if (PL_archpat_auto[len] == '.') PL_archpat_auto[len] = '_';
#endif
}
}
/* skip any consecutive separators */
while ( *p == PERLLIB_SEP ) {
/* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(incgv), newSVpv(".", 1)); */
+ /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
p++;
}
char *unix;
STRLEN len;
- if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
+ if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
len = strlen(unix);
while (unix[len-1] == '/') len--; /* Cosmetic */
sv_usepvn(libdir,unix,len);
else
PerlIO_printf(PerlIO_stderr(),
"Failed to unixify @INC element \"%s\"\n",
- SvPV(libdir,na));
+ SvPV(libdir,len));
#endif
/* .../archname/version if -d .../archname/version/auto */
sv_setsv(subdir, libdir);
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv),
- newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
/* .../archname if -d .../archname/auto */
sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(PL_incgv),
- newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
+ newSVpvn(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
}
/* finally push this lib directory on the end of @INC */
#ifdef USE_THREADS
STATIC struct perl_thread *
-init_main_thread()
+S_init_main_thread(pTHX)
{
+#if !defined(PERL_IMPLICIT_CONTEXT)
struct perl_thread *thr;
+#endif
XPV *xpv;
Newz(53, thr, 1, struct perl_thread);
- curcop = &compiling;
+ PL_curcop = &PL_compiling;
+ thr->interp = PERL_GET_INTERP;
thr->cvcache = newHV();
thr->threadsv = newAV();
/* thr->threadsvp is set when find_threadsv is called */
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
/* Handcraft thrsv similarly to mess_sv */
- New(53, thrsv, 1, SV);
+ New(53, PL_thrsv, 1, SV);
Newz(53, xpv, 1, XPV);
- SvFLAGS(thrsv) = SVt_PV;
- SvANY(thrsv) = (void*)xpv;
- SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
- SvPVX(thrsv) = (char*)thr;
- SvCUR_set(thrsv, sizeof(thr));
- SvLEN_set(thrsv, sizeof(thr));
- *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
- thr->oursv = thrsv;
- chopset = " \n-";
-
- MUTEX_LOCK(&threads_mutex);
- nthreads++;
+ SvFLAGS(PL_thrsv) = SVt_PV;
+ SvANY(PL_thrsv) = (void*)xpv;
+ SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
+ SvPVX(PL_thrsv) = (char*)thr;
+ SvCUR_set(PL_thrsv, sizeof(thr));
+ SvLEN_set(PL_thrsv, sizeof(thr));
+ *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
+ thr->oursv = PL_thrsv;
+ PL_chopset = " \n-";
+ PL_dumpindent = 4;
+
+ MUTEX_LOCK(&PL_threads_mutex);
+ PL_nthreads++;
thr->tid = 0;
thr->next = thr;
thr->prev = thr;
- MUTEX_UNLOCK(&threads_mutex);
+ MUTEX_UNLOCK(&PL_threads_mutex);
#ifdef HAVE_THREAD_INTERN
- init_thread_intern(thr);
+ Perl_init_thread_intern(thr);
#endif
#ifdef SET_THREAD_SELF
* These must come after the SET_THR because sv_setpvn does
* SvTAINT and the taint fields require dTHR.
*/
- toptarget = NEWSV(0,0);
- sv_upgrade(toptarget, SVt_PVFM);
- sv_setpvn(toptarget, "", 0);
- bodytarget = NEWSV(0,0);
- sv_upgrade(bodytarget, SVt_PVFM);
- sv_setpvn(bodytarget, "", 0);
- formtarget = bodytarget;
- thr->errsv = newSVpv("", 0);
+ PL_toptarget = NEWSV(0,0);
+ sv_upgrade(PL_toptarget, SVt_PVFM);
+ sv_setpvn(PL_toptarget, "", 0);
+ PL_bodytarget = NEWSV(0,0);
+ sv_upgrade(PL_bodytarget, SVt_PVFM);
+ sv_setpvn(PL_bodytarget, "", 0);
+ PL_formtarget = PL_bodytarget;
+ thr->errsv = newSVpvn("", 0);
(void) find_threadsv("@"); /* Ensure $@ is initialised early */
- maxscream = -1;
- regcompp = FUNC_NAME_TO_PTR(pregcomp);
- regexecp = FUNC_NAME_TO_PTR(regexec_flags);
- regindent = 0;
- reginterp_cnt = 0;
+ PL_maxscream = -1;
+ PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
+ PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
+ PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
+ PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
+ PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
+ PL_regindent = 0;
+ PL_reginterp_cnt = 0;
return thr;
}
#endif /* USE_THREADS */
void
-call_list(I32 oldscope, AV *paramList)
+Perl_call_list(pTHX_ 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(aTHX_ &ret, MEMBER_TO_FPTR(S_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;
+ Perl_croak(aTHX_ "%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) {
if (paramList == PL_beginav)
- croak("BEGIN failed--compilation aborted");
+ Perl_croak(aTHX_ "BEGIN failed--compilation aborted");
else
- croak("END failed--cleanup aborted");
+ Perl_croak(aTHX_ "END failed--cleanup aborted");
}
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 *
+S_call_list_body(pTHX_ va_list args)
+{
+ dTHR;
+ CV *cv = va_arg(args, CV*);
+
+ PUSHMARK(PL_stack_sp);
+ call_sv((SV*)cv, G_EVAL|G_DISCARD);
+ return NULL;
+}
+
void
-my_exit(U32 status)
+Perl_my_exit(pTHX_ U32 status)
{
dTHR;
-#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+ DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
thr, (unsigned long) status));
-#endif /* USE_THREADS */
switch (status) {
case 0:
STATUS_ALL_SUCCESS;
}
void
-my_failure_exit(void)
+Perl_my_failure_exit(pTHX)
{
#ifdef VMS
if (vaxc$errno & 1) {
}
STATIC void
-my_exit_jump(void)
+S_my_exit_jump(pTHX)
{
- dSP;
+ dTHR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
JMPENV_JUMP(2);
}
-
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
#include "XSUB.h"
+#endif
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(pTHXo_ int idx, SV *buf_sv, int maxlen)
{
char *p, *nl;
p = SvPVX(PL_e_script);
nl = strchr(p, '\n');
nl = (nl) ? nl+1 : SvEND(PL_e_script);
- if (nl-p == 0)
+ if (nl-p == 0) {
+ filter_del(read_e_script);
return 0;
+ }
sv_catpvn(buf_sv, p, nl-p);
sv_chop(PL_e_script, nl);
return 1;
https://perl5.git.perl.org / perl5.git / blobdiff