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
catch_sigsegv(int signo, struct sigcontext_struct sc)
{
- signal(SIGSEGV, SIG_DFL);
+ PerlProc_signal(SIGSEGV, SIG_DFL);
fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
"return_address = 0x%lx, eip = 0x%lx\n",
sc.cr2, __builtin_return_address(0), sc.eip);
#endif
PerlInterpreter *
-perl_alloc()
+perl_alloc(void)
{
PerlInterpreter *sv_interp;
}
void
-perl_construct( sv_interp )
-register PerlInterpreter *sv_interp;
+perl_construct(register PerlInterpreter *sv_interp)
{
-#if defined(USE_THREADS) && !defined(FAKE_THREADS)
- struct thread *thr;
-#endif
+#ifdef USE_THREADS
+ int i;
+#ifndef FAKE_THREADS
+ struct perl_thread *thr;
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
if (!(curinterp = sv_interp))
return;
/* Init the real globals (and main thread)? */
if (!linestr) {
#ifdef USE_THREADS
- XPV *xpv;
INIT_THREADS;
- New(53, thr, 1, struct thread);
- MUTEX_INIT(&malloc_mutex);
+#ifdef ALLOC_THREAD_KEY
+ ALLOC_THREAD_KEY;
+#else
+ if (pthread_key_create(&thr_key, 0))
+ croak("panic: pthread_key_create");
+#endif
MUTEX_INIT(&sv_mutex);
- /* Safe to use SVs from now on */
+ /*
+ * 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);
- nthreads = 1;
- cvcache = newHV();
- curcop = &compiling;
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- thr->next = thr;
- thr->prev = thr;
- thr->tid = 0;
-
- /* Handcraft thrsv similarly to mess_sv */
- New(53, 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 */
- oursv = thrsv;
-#ifdef HAVE_THREAD_INTERN
- init_thread_intern(thr);
-#else
- self = pthread_self();
- if (pthread_key_create(&thr_key, 0))
- croak("panic: pthread_key_create");
- if (pthread_setspecific(thr_key, (void *) thr))
- croak("panic: pthread_setspecific");
-#endif /* FAKE_THREADS */
+
+ thr = init_main_thread();
#endif /* USE_THREADS */
linestr = NEWSV(65,80);
}
void
-perl_destruct(sv_interp)
-register PerlInterpreter *sv_interp;
+perl_destruct(register PerlInterpreter *sv_interp)
{
dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
* all over again.
*/
MUTEX_UNLOCK(&threads_mutex);
- if (pthread_join(t->Tself, (void**)&av))
- croak("panic: pthread_join failed during global destruction");
+ JOIN(t, &av);
SvREFCNT_dec((SV*)av);
DEBUG_L(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: joined zombie %p OK\n", t));
#ifdef DEBUGGING
{
char *s;
- if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+ if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
/* defgv, aka *_ should be taken care of elsewhere */
-#if 0 /* just about all regexp stuff, seems to be ok */
-
- /* shortcuts to regexp stuff */
- leftgv = Nullgv;
- ampergv = Nullgv;
-
- SAVEFREEOP(curpm);
- SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
-
- regprecomp = NULL; /* uncompiled string. */
- regparse = NULL; /* Input-scan pointer. */
- regxend = NULL; /* End of input for compile */
- regnpar = 0; /* () count. */
- regcode = NULL; /* Code-emit pointer; ®dummy = don't. */
- regsize = 0; /* Code size. */
- regnaughty = 0; /* How bad is this pattern? */
- regsawback = 0; /* Did we see \1, ...? */
-
- reginput = NULL; /* String-input pointer. */
- regbol = NULL; /* Beginning of input, for ^ check. */
- regeol = NULL; /* End of input, for $ check. */
- regstartp = (char **)NULL; /* Pointer to startp array. */
- regendp = (char **)NULL; /* Ditto for endp. */
- reglastparen = 0; /* Similarly for lastparen. */
- regtill = NULL; /* How far we are required to go. */
- regflags = 0; /* are we folding, multilining? */
- regprev = (char)NULL; /* char before regbol, \n if none */
-
-#endif /* if 0 */
-
/* clean up after study() */
SvREFCNT_dec(lastscream);
lastscream = Nullsv;
DEBUG_P(debprofdump());
#ifdef USE_THREADS
MUTEX_DESTROY(&sv_mutex);
- MUTEX_DESTROY(&malloc_mutex);
MUTEX_DESTROY(&eval_mutex);
COND_DESTROY(&eval_cond);
}
void
-perl_free(sv_interp)
-PerlInterpreter *sv_interp;
+perl_free(PerlInterpreter *sv_interp)
{
if (!(curinterp = sv_interp))
return;
}
int
-perl_parse(sv_interp, xsinit, argc, argv, env)
-PerlInterpreter *sv_interp;
-void (*xsinit)_((void));
-int argc;
-char **argv;
-char **env;
+perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
{
dTHR;
register SV *sv;
croak("No -e allowed in setuid scripts");
if (!e_fp) {
e_tmpname = savepv(TMPPATH);
- (void)mktemp(e_tmpname);
+ (void)PerlLIO_mktemp(e_tmpname);
if (!*e_tmpname)
croak("Can't mktemp()");
e_fp = PerlIO_open(e_tmpname,"w");
}
switch_end:
- if (!tainting && (s = getenv("PERL5OPT"))) {
+ if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
while (s && *s) {
while (isSPACE(*s))
s++;
}
else if (scriptname == Nullch) {
#ifdef MSDOS
- if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+ if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
moreswitches("h");
#endif
scriptname = "-";
boot_core_UNIVERSAL();
if (xsinit)
(*xsinit)(); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
init_os_extras();
#endif
#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
- DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
+ DEBUG_L(PerlProc_signal(SIGSEGV, (void(*)(int))catch_sigsegv););
#endif
init_predump_symbols();
/* now parse the script */
+ SETERRNO(0,SS$_NORMAL);
error_count = 0;
if (yyparse() || error_count) {
if (minus_c)
/* now that script is parsed, we can modify record separator */
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
+#ifdef USE_THREADS
+ sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
+#else
sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
-
+#endif /* USE_THREADS */
if (do_undump)
my_unexec();
FREETMPS;
#ifdef MYMALLOC
- if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+ if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
dump_mstats("after compilation:");
#endif
}
int
-perl_run(sv_interp)
-PerlInterpreter *sv_interp;
+perl_run(PerlInterpreter *sv_interp)
{
dTHR;
I32 oldscope;
if (endav)
call_list(oldscope, endav);
#ifdef MYMALLOC
- if (getenv("PERL_DEBUG_MSTATS"))
+ if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
JMPENV_POP;
}
SV*
-perl_get_sv(name, create)
-char* name;
-I32 create;
+perl_get_sv(char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PV);
+ GV *gv;
+#ifdef USE_THREADS
+ if (name[1] == '\0' && !isALPHA(name[0])) {
+ PADOFFSET tmp = find_threadsv(name);
+ if (tmp != NOT_IN_PAD) {
+ dTHR;
+ return *av_fetch(thr->threadsv, tmp, FALSE);
+ }
+ }
+#endif /* USE_THREADS */
+ gv = gv_fetchpv(name, create, SVt_PV);
if (gv)
return GvSV(gv);
return Nullsv;
}
AV*
-perl_get_av(name, create)
-char* name;
-I32 create;
+perl_get_av(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVAV);
if (create)
}
HV*
-perl_get_hv(name, create)
-char* name;
-I32 create;
+perl_get_hv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVHV);
if (create)
}
CV*
-perl_get_cv(name, create)
-char* name;
-I32 create;
+perl_get_cv(char *name, I32 create)
{
GV* gv = gv_fetchpv(name, create, SVt_PVCV);
if (create && !GvCVu(gv))
/* Be sure to refetch the stack pointer after calling these routines. */
I32
-perl_call_argv(subname, flags, argv)
-char *subname;
-I32 flags; /* See G_* flags in cop.h */
-register char **argv; /* null terminated arg list */
+perl_call_argv(char *sub_name, I32 flags, register char **argv)
+
+ /* See G_* flags in cop.h */
+ /* null terminated arg list */
{
- dTHR;
dSP;
PUSHMARK(sp);
}
PUTBACK;
}
- return perl_call_pv(subname, flags);
+ return perl_call_pv(sub_name, flags);
}
I32
-perl_call_pv(subname, flags)
-char *subname; /* name of the subroutine */
-I32 flags; /* See G_* flags in cop.h */
+perl_call_pv(char *sub_name, I32 flags)
+ /* name of the subroutine */
+ /* See G_* flags in cop.h */
{
- return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
+ return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
}
I32
-perl_call_method(methname, flags)
-char *methname; /* name of the subroutine */
-I32 flags; /* See G_* flags in cop.h */
+perl_call_method(char *methname, I32 flags)
+ /* name of the subroutine */
+ /* See G_* flags in cop.h */
{
- dTHR;
dSP;
OP myop;
if (!op)
/* May be called with any of a CV, a GV, or an SV containing the name. */
I32
-perl_call_sv(sv, flags)
-SV* sv;
-I32 flags; /* See G_* flags in cop.h */
+perl_call_sv(SV *sv, I32 flags)
+
+ /* See G_* flags in cop.h */
{
dTHR;
LOGOP myop; /* fake syntax tree node */
markstack_ptr--;
/* we're trying to emulate pp_entertry() here */
{
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
ENTER;
if (flags & G_KEEPERR)
in_eval |= 4;
else
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
}
markstack_ptr++;
runops();
retval = stack_sp - (stack_base + oldmark);
if ((flags & G_EVAL) && !(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
cleanup:
if (flags & G_EVAL) {
SV **newsp;
PMOP *newpm;
I32 gimme;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 optype;
POPBLOCK(cx,newpm);
/* Eval a string. The G_EVAL flag is always assumed. */
I32
-perl_eval_sv(sv, flags)
-SV* sv;
-I32 flags; /* See G_* flags in cop.h */
+perl_eval_sv(SV *sv, I32 flags)
+
+ /* See G_* flags in cop.h */
{
dTHR;
UNOP myop; /* fake syntax tree node */
runops();
retval = stack_sp - (stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(ERRSV,"");
cleanup:
JMPENV_POP;
}
SV*
-perl_eval_pv(p, croak_on_error)
-char* p;
-I32 croak_on_error;
+perl_eval_pv(char *p, I32 croak_on_error)
{
- dTHR;
dSP;
SV* sv = newSVpv(p, 0);
sv = POPs;
PUTBACK;
- if (croak_on_error && SvTRUE(GvSV(errgv)))
- croak(SvPVx(GvSV(errgv), na));
+ if (croak_on_error && SvTRUE(ERRSV))
+ croak(SvPVx(ERRSV, na));
return sv;
}
/* Require a module. */
void
-perl_require_pv(pv)
-char* pv;
+perl_require_pv(char *pv)
{
SV* sv = sv_newmortal();
sv_setpv(sv, "require '");
}
void
-magicname(sym,name,namlen)
-char *sym;
-char *name;
-I32 namlen;
+magicname(char *sym, char *name, I32 namlen)
{
register GV *gv;
}
static void
-usage(name) /* XXX move this out into a module ? */
-char *name;
+usage(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? */
/* This routine handles any switches that can be given during run */
char *
-moreswitches(s)
-char *s;
+moreswitches(char *s)
{
I32 numlen;
U32 rschar;
switch (*s) {
case '0':
+ {
+ dTHR;
rschar = scan_oct(s, 4, &numlen);
SvREFCNT_dec(nrs);
if (rschar & ~((U8)~0))
nrs = newSVpv(&ch, 1);
}
return s + numlen;
+ }
case 'F':
minus_F = TRUE;
splitstr = savepv(s + 1);
return s;
case 'h':
usage(origargv[0]);
- exit(0);
+ PerlProc_exit(0);
case 'i':
if (inplace)
Safefree(inplace);
s += numlen;
}
else {
+ dTHR;
if (RsPARA(nrs)) {
ors = "\n\n";
orslen = 2;
#endif
#ifdef DJGPP
printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
+ printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
#endif
#ifdef OS2
printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
printf("\n\
Perl may be copied only under the terms of either the Artistic License or the\n\
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
- exit(0);
+ PerlProc_exit(0);
case 'w':
dowarn = TRUE;
s++;
break;
case '-':
case 0:
+#ifdef WIN32
+ case '\r':
+#endif
case '\n':
case '\t':
break;
/* unexec() can be found in the Gnu emacs distribution */
void
-my_unexec()
+my_unexec(void)
{
#ifdef UNEXEC
SV* prog;
if (status)
PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
SvPVX(prog), SvPVX(file));
- exit(status);
+ PerlProc_exit(status);
#else
# ifdef VMS
# include <lib$routines.h>
}
static void
-init_main_stash()
+init_main_stash(void)
{
dTHR;
GV *gv;
errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
GvMULTI_on(errgv);
(void)form("%240s",""); /* Preallocate temp - for immediate signals. */
- sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */
- sv_setpvn(GvSV(errgv), "", 0);
+ 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);
}
*
* Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
* proceeds as follows:
- * If DOSISH:
+ * If DOSISH or VMSISH:
* + look for ./scriptname{,.foo,.bar}
* + search the PATH for scriptname{,.foo,.bar}
*
*/
#ifdef VMS
+# ifdef ALWAYS_DEFTYPES
+ len = strlen(scriptname);
+ if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
+ int hasdir, idx = 0, deftypes = 1;
+ bool seen_dot = 1;
+
+ hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+# else
if (dosearch) {
int hasdir, idx = 0, deftypes = 1;
bool seen_dot = 1;
hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+# endif
/* The first time through, just add SEARCH_EXTS to whatever we
* already have, so we can check for default file types. */
while (deftypes ||
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
- && (s = getenv("PATH"))) {
+ && (s = PerlEnv_getenv("PATH"))) {
bool seen_dot = 0;
bufend = s + strlen(s);
if (strEQ(origfilename,"-"))
scriptname = "";
if (fdscript >= 0) {
- rsfp = PerlIO_fdopen(fdscript,"r");
+ rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
- rsfp = my_popen(SvPVX(cmd), "r");
+ rsfp = PerlProc_popen(SvPVX(cmd), "r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
rsfp = PerlIO_stdin();
}
else {
- rsfp = PerlIO_open(scriptname,"r");
+ rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (rsfp)
fcntl(PerlIO_fileno(rsfp),F_SETFD,1); /* ensure close-on-exec */
if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
statbuf.st_mode & (S_ISUID|S_ISGID)) {
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
croak("Can't do setuid\n");
}
#endif
}
static void
-validate_suid(validarg, scriptname)
-char *validarg;
-char *scriptname;
+validate_suid(char *validarg, char *scriptname)
{
int which;
*/
#ifdef DOSUID
+ dTHR;
char *s, *s2;
- if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
+ 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)) {
I32 len;
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
*/
- if (access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
+ if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1)) /*double check*/
croak("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
if (tmpstatbuf.st_dev != statbuf.st_dev ||
tmpstatbuf.st_ino != statbuf.st_ino) {
(void)PerlIO_close(rsfp);
- if (rsfp = my_popen("/bin/mail root","w")) { /* heh, heh */
+ if (rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */
PerlIO_printf(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)statbuf.st_dev, (long)statbuf.st_ino,
SvPVX(GvSV(curcop->cop_filegv)),
(long)statbuf.st_uid, (long)statbuf.st_gid);
- (void)my_pclose(rsfp);
+ (void)PerlProc_pclose(rsfp);
}
croak("Permission denied\n");
}
(void)PerlIO_close(rsfp);
#ifndef IAMSUID
/* try again */
- execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
#endif
croak("Can't do setuid\n");
}
/* exec the real perl, substituting fd script for scriptname. */
/* (We pass script name as "subdir" of fd, which perl will grok.) */
PerlIO_rewind(rsfp);
- lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ 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");
#if defined(HAS_FCNTL) && defined(F_SETFD)
fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
- execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv); /* try again */
croak("Can't do setuid\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
dTHR;
- Fstat(PerlIO_fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
+ 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)
||
(egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
}
static void
-find_beginning()
+find_beginning(void)
{
register char *s, *s2;
/*SUPPRESS 530*/
while (s = moreswitches(s)) ;
}
- if (cddir && chdir(cddir) < 0)
+ if (cddir && PerlDir_chdir(cddir) < 0)
croak("Can't chdir to %s",cddir);
}
}
}
static void
-init_ids()
+init_ids(void)
{
uid = (int)getuid();
euid = (int)geteuid();
}
static void
-forbid_setid(s)
-char *s;
+forbid_setid(char *s)
{
if (euid != uid)
croak("No %s allowed while running setuid", s);
}
static void
-init_debugger()
+init_debugger(void)
{
dTHR;
curstash = debstash;
}
void
-init_stacks(ARGS)
-dARGS
+init_stacks(ARGSproto)
{
curstack = newAV();
mainstack = curstack; /* remember in case we switch stacks */
stack_sp = stack_base;
stack_max = stack_base + 127;
- cxstack_max = 8192 / sizeof(CONTEXT) - 2; /* Use most of 8K. */
- New(50,cxstack,cxstack_max + 1,CONTEXT);
+ cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2; /* Use most of 8K. */
+ New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
cxstack_ix = -1;
New(50,tmps_stack,128,SV*);
}
static void
-nuke_stacks()
+nuke_stacks(void)
{
dTHR;
Safefree(cxstack);
static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
static void
-init_lexer()
+init_lexer(void)
{
tmpfp = rsfp;
rsfp = Nullfp;
}
static void
-init_predump_symbols()
+init_predump_symbols(void)
{
dTHR;
GV *tmpgv;
GV *othergv;
+#ifdef USE_THREADS
+ sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
+#else
sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
+#endif /* USE_THREADS */
stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(stdingv);
}
static void
-init_postdump_symbols(argc,argv,env)
-register int argc;
-register char **argv;
-register char **env;
+init_postdump_symbols(register int argc, register char **argv, register char **env)
{
+ dTHR;
char *s;
SV *sv;
GV* tmpgv;
if (!(s = strchr(*env,'=')))
continue;
*s++ = '\0';
-#ifdef WIN32
+#if defined(WIN32) || defined(MSDOS)
(void)strupr(*env);
#endif
sv = newSVpv(s--,0);
*s = '=';
#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
/* Sins of the RTL. See note in my_setenv(). */
- (void)putenv(savepv(*env));
+ (void)PerlEnv_putenv(savepv(*env));
#endif
}
#endif
}
static void
-init_perllib()
+init_perllib(void)
{
char *s;
if (!tainting) {
#ifndef VMS
- s = getenv("PERL5LIB");
+ s = PerlEnv_getenv("PERL5LIB");
if (s)
incpush(s, TRUE);
else
- incpush(getenv("PERLLIB"), FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
#endif
static void
-incpush(p, addsubdirs)
-char *p;
-int addsubdirs;
+incpush(char *p, int addsubdirs)
{
SV *subdir = Nullsv;
static char *archpat_auto;
SvREFCNT_dec(subdir);
}
+#ifdef USE_THREADS
+static struct perl_thread *
+init_main_thread()
+{
+ struct perl_thread *thr;
+ XPV *xpv;
+
+ Newz(53, thr, 1, struct perl_thread);
+ curcop = &compiling;
+ thr->cvcache = newHV();
+ thr->threadsv = newAV();
+ thr->specific = newAV();
+ thr->errhv = newHV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ /* Handcraft thrsv similarly to mess_sv */
+ New(53, 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;
+ curcop = &compiling;
+ chopset = " \n-";
+
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = 0;
+ thr->next = thr;
+ thr->prev = thr;
+ MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#endif
+
+#ifdef SET_THREAD_SELF
+ SET_THREAD_SELF(thr);
+#else
+ thr->self = pthread_self();
+#endif /* SET_THREAD_SELF */
+ SET_THR(thr);
+
+ /*
+ * 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);
+ return thr;
+}
+#endif /* USE_THREADS */
+
void
-call_list(oldscope, list)
-I32 oldscope;
-AV* list;
+call_list(I32 oldscope, AV *list)
{
dTHR;
line_t oldline = curcop->cop_line;
dJMPENV;
int ret;
- while (AvFILL(list) >= 0) {
+ while (AvFILL(list) >= 0) {
CV *cv = (CV*)av_shift(list);
SAVEFREESV(cv);
JMPENV_PUSH(ret);
switch (ret) {
case 0: {
- SV* atsv = GvSV(errgv);
+ SV* atsv = ERRSV;
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
}
void
-my_exit(status)
-U32 status;
+my_exit(U32 status)
{
dTHR;
#ifdef USE_THREADS
- DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
- (unsigned long) thr, (unsigned long) status));
+ DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+ thr, (unsigned long) status));
#endif /* USE_THREADS */
switch (status) {
case 0:
}
void
-my_failure_exit()
+my_failure_exit(void)
{
#ifdef VMS
if (vaxc$errno & 1) {
}
static void
-my_exit_jump()
+my_exit_jump(void)
{
dTHR;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
JMPENV_JUMP(2);
}
+
+
+
https://perl5.git.perl.org / perl5.git / blobdiff