mess_sv = Nullsv; \
} STMT_END
+#ifndef PERL_OBJECT
static void find_beginning _((void));
static void forbid_setid _((char *));
static void incpush _((char *, int));
static void init_lexer _((void));
static void init_main_stash _((void));
#ifdef USE_THREADS
-static struct thread * init_main_thread _((void));
+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 open_script _((char *, bool, SV *));
static void usage _((char *));
static void validate_suid _((char *, char*));
+#endif
static int fdscript = -1;
#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
#include <asm/sigcontext.h>
-static 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
+#ifdef PERL_OBJECT
+CPerlObj* perl_alloc(IPerlMem* ipM, IPerlEnv* ipE, IPerlStdIO* ipStd,
+ IPerlLIO* ipLIO, IPerlDir* ipD, IPerlSock* ipS, IPerlProc* ipP)
+{
+ CPerlObj* pPerl = new(ipM) CPerlObj(ipM, ipE, ipStd, ipLIO, ipD, ipS, ipP);
+ if(pPerl != NULL)
+ pPerl->Init();
+
+ return pPerl;
+}
+#else
PerlInterpreter *
-perl_alloc()
+perl_alloc(void)
{
PerlInterpreter *sv_interp;
New(53, sv_interp, 1, PerlInterpreter);
return sv_interp;
}
+#endif
void
-perl_construct( sv_interp )
-register PerlInterpreter *sv_interp;
+#ifdef PERL_OBJECT
+CPerlObj::perl_construct(void)
+#else
+perl_construct(register PerlInterpreter *sv_interp)
+#endif
{
#ifdef USE_THREADS
int i;
#ifndef FAKE_THREADS
- struct thread *thr;
+ struct perl_thread *thr;
#endif /* FAKE_THREADS */
#endif /* USE_THREADS */
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return;
+#endif
#ifdef MULTIPLICITY
Zero(sv_interp, 1, PerlInterpreter);
#ifdef USE_THREADS
INIT_THREADS;
+#ifdef ALLOC_THREAD_KEY
+ ALLOC_THREAD_KEY;
+#else
if (pthread_key_create(&thr_key, 0))
croak("panic: pthread_key_create");
- MUTEX_INIT(&malloc_mutex);
+#endif
MUTEX_INIT(&sv_mutex);
/*
* Safe to use basic SV functions from now on (though
COND_INIT(&eval_cond);
MUTEX_INIT(&threads_mutex);
COND_INIT(&nthreads_cond);
-
+
thr = init_main_thread();
#endif /* USE_THREADS */
nrs = newSVpv("\n", 1);
rs = SvREFCNT_inc(nrs);
+#ifdef PERL_OBJECT
+ /* TODO: */
+ /* sighandlerp = sighandler; */
+#else
sighandlerp = sighandler;
+#endif
pidstatus = newHV();
#ifdef MSDOS
}
void
-perl_destruct(sv_interp)
-register PerlInterpreter *sv_interp;
+#ifdef PERL_OBJECT
+CPerlObj::perl_destruct(void)
+#else
+perl_destruct(register PerlInterpreter *sv_interp)
+#endif
{
dTHR;
int destruct_level; /* 0=none, 1=full, 2=full with checks */
Thread t;
#endif /* USE_THREADS */
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return;
+#endif
#ifdef USE_THREADS
#ifndef FAKE_THREADS
#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;
+#ifdef PERL_OBJECT
+CPerlObj::perl_free(void)
+#else
+perl_free(PerlInterpreter *sv_interp)
+#endif
{
+#ifdef PERL_OBJECT
+ Safefree(this);
+#else
if (!(curinterp = sv_interp))
return;
Safefree(sv_interp);
+#endif
}
int
-perl_parse(sv_interp, xsinit, argc, argv, env)
-PerlInterpreter *sv_interp;
-void (*xsinit)_((void));
-int argc;
-char **argv;
-char **env;
+#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
{
dTHR;
register SV *sv;
#endif
#endif
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return 255;
+#endif
#if defined(NeXT) && defined(__DYNAMIC__)
_dyld_lookup_and_bind
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 = "-";
CvPADLIST(compcv) = comppadlist;
boot_core_UNIVERSAL();
+#if defined(WIN32) && defined(PERL_OBJECT)
+ BootDynaLoader();
+#endif
if (xsinit)
- (*xsinit)(); /* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32)
+ (*xsinit)(THIS); /* in case linked C routines want magical variables */
+#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)
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
#ifdef USE_THREADS
- sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs);
+ sv_setsv(*av_fetch(thr->threadsv, find_threadsv("/"), FALSE), rs);
#else
sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
#endif /* USE_THREADS */
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;
+#ifdef PERL_OBJECT
+CPerlObj::perl_run(void)
+#else
+perl_run(PerlInterpreter *sv_interp)
+#endif
{
dTHR;
I32 oldscope;
dJMPENV;
int ret;
+#ifndef PERL_OBJECT
if (!(curinterp = sv_interp))
return 255;
+#endif
oldscope = scopestack_ix;
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;
if (restartop) {
op = restartop;
restartop = 0;
- runops();
+ CALLRUNOPS();
}
else if (main_start) {
CvDEPTH(main_cv) = 1;
op = main_start;
- runops();
+ CALLRUNOPS();
}
my_exit(0);
}
SV*
-perl_get_sv(name, create)
-char* name;
-I32 create;
+perl_get_sv(char *name, I32 create)
{
+ GV *gv;
#ifdef USE_THREADS
- PADOFFSET tmp;
- if (name[1] == '\0' && !isALPHA(name[0])
- && (tmp = find_thread_magical(name)) != NOT_IN_PAD) {
- return *av_fetch(thr->magicals, tmp, FALSE);
+ 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 = gv_fetchpv(name, create, SVt_PV);
+ 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 (op == (OP*)&myop)
op = pp_entersub(ARGS);
if (op)
- runops();
+ CALLRUNOPS();
retval = stack_sp - (stack_base + oldmark);
if ((flags & G_EVAL) && !(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
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 */
if (op == (OP*)&myop)
op = pp_entereval(ARGS);
if (op)
- runops();
+ CALLRUNOPS();
retval = stack_sp - (stack_base + oldmark);
if (!(flags & G_KEEPERR))
sv_setpv(ERRSV,"");
}
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);
/* 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;
sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
}
-static void
-usage(name) /* XXX move this out into a module ? */
-char *name;
+STATIC void
+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? */
- static char *usage[] = {
+ static char *usage_msg[] = {
"-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)",
"\n",
NULL
};
- char **p = usage;
+ char **p = usage_msg;
printf("\nUsage: %s [switches] [--] [programfile] [arguments]", name);
while (*p)
/* This routine handles any switches that can be given during run */
char *
-moreswitches(s)
-char *s;
+moreswitches(char *s)
{
I32 numlen;
U32 rschar;
return s;
case 'h':
usage(origargv[0]);
- exit(0);
+ PerlProc_exit(0);
case 'i':
if (inplace)
Safefree(inplace);
#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>
#endif
}
-static void
-init_main_stash()
+STATIC void
+init_main_stash(void)
{
dTHR;
GV *gv;
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);
}
#ifdef CAN_PROTOTYPE
-static void
+STATIC void
open_script(char *scriptname, bool dosearch, SV *sv)
#else
-static void
+STATIC void
open_script(scriptname,dosearch,sv)
char *scriptname;
bool dosearch;
*
* 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 ||
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (Stat(cur,&statbuf) >= 0) {
+ if (PerlLIO_stat(cur,&statbuf) >= 0) {
dosearch = 0;
scriptname = cur;
#ifdef SEARCH_EXTS
#ifdef DOSISH
&& !strchr(scriptname, '\\')
#endif
- && (s = getenv("PATH"))) {
+ && (s = PerlEnv_getenv("PATH"))) {
bool seen_dot = 0;
bufend = s + strlen(s);
do {
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tokenbuf));
- retval = Stat(tokenbuf,&statbuf);
+ retval = PerlLIO_stat(tokenbuf,&statbuf);
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
&& extidx>=0 && ext[extidx] /* try an extension? */
xfailed = savepv(tokenbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed && (Stat(scriptname,&statbuf) < 0))
+ if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&statbuf) < 0))
#endif
seen_dot = 1; /* Disable message. */
if (!xfound)
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 */
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1, uid, (Uid_t)-1);
#else
- setuid(uid);
+ PerlProc_setuid(uid);
#endif
#endif
#endif
- if (geteuid() != uid)
+ if (PerlProc_geteuid() != uid)
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 (!rsfp) {
#ifdef DOSUID
#ifndef IAMSUID /* in case script is not readable before setuid */
- if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
+ if (euid && PerlLIO_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;
+STATIC void
+validate_suid(char *validarg, char *scriptname)
{
int which;
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
setresuid(euid,uid,(Uid_t)-1) < 0
# endif
#endif
- || getuid() != euid || geteuid() != uid)
+ || PerlProc_getuid() != euid || PerlProc_geteuid() != uid)
croak("Can't swap uid and euid"); /* really paranoid */
- if (Stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
+ 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 = 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");
}
setresuid(uid,euid,(Uid_t)-1) < 0
# endif
#endif
- || getuid() != uid || geteuid() != euid)
+ || 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");
(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");
}
#ifdef HAS_SETRESGID
(void)setresgid((Gid_t)-1,statbuf.st_gid,(Gid_t)-1);
#else
- setgid(statbuf.st_gid);
+ PerlProc_setgid(statbuf.st_gid);
#endif
#endif
#endif
- if (getegid() != statbuf.st_gid)
+ if (PerlProc_getegid() != statbuf.st_gid)
croak("Can't do setegid!\n");
}
if (statbuf.st_mode & S_ISUID) {
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,statbuf.st_uid,(Uid_t)-1);
#else
- setuid(statbuf.st_uid);
+ PerlProc_setuid(statbuf.st_uid);
#endif
#endif
#endif
- if (geteuid() != statbuf.st_uid)
+ if (PerlProc_geteuid() != statbuf.st_uid)
croak("Can't do seteuid!\n");
}
else if (uid) { /* oops, mustn't run as root */
#ifdef HAS_SETRESUID
(void)setresuid((Uid_t)-1,(Uid_t)uid,(Uid_t)-1);
#else
- setuid((Uid_t)uid);
+ PerlProc_setuid((Uid_t)uid);
#endif
#endif
#endif
- if (geteuid() != uid)
+ if (PerlProc_geteuid() != uid)
croak("Can't do seteuid!\n");
}
init_ids();
/* 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)
#endif /* DOSUID */
}
-static void
-find_beginning()
+STATIC void
+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()
+STATIC void
+init_ids(void)
{
- uid = (int)getuid();
- euid = (int)geteuid();
- gid = (int)getgid();
- egid = (int)getegid();
+ uid = (int)PerlProc_getuid();
+ euid = (int)PerlProc_geteuid();
+ gid = (int)PerlProc_getgid();
+ egid = (int)PerlProc_getegid();
#ifdef VMS
uid |= gid << 16;
euid |= egid << 16;
tainting |= (uid && (euid != uid || egid != gid));
}
-static void
-forbid_setid(s)
-char *s;
+STATIC void
+forbid_setid(char *s)
{
if (euid != uid)
croak("No %s allowed while running setuid", s);
croak("No %s allowed while running setgid", s);
}
-static void
-init_debugger()
+STATIC void
+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()
+STATIC void
+nuke_stacks(void)
{
dTHR;
Safefree(cxstack);
} )
}
+#ifndef PERL_OBJECT
static PerlIO *tmpfp; /* moved outside init_lexer() because of UNICOS bug */
+#endif
-static void
-init_lexer()
+STATIC void
+init_lexer(void)
{
+#ifdef PERL_OBJECT
+ PerlIO *tmpfp;
+#endif
tmpfp = rsfp;
rsfp = Nullfp;
lex_start(linestr);
subname = newSVpv("main",4);
}
-static void
-init_predump_symbols()
+STATIC void
+init_predump_symbols(void)
{
dTHR;
GV *tmpgv;
GV *othergv;
#ifdef USE_THREADS
- sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1);
+ sv_setpvn(*av_fetch(thr->threadsv,find_threadsv("\""),FALSE)," ", 1);
#else
sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
#endif /* USE_THREADS */
osname = savepv(OSNAME);
}
-static void
-init_postdump_symbols(argc,argv,env)
-register int argc;
-register char **argv;
-register char **env;
+STATIC void
+init_postdump_symbols(register int argc, register char **argv, register char **env)
{
dTHR;
char *s;
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
sv_setiv(GvSV(tmpgv), (IV)getpid());
}
-static void
-init_perllib()
+STATIC void
+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
# define PERLLIB_MANGLE(s,n) (s)
#endif
-static void
-incpush(p, addsubdirs)
-char *p;
-int addsubdirs;
+STATIC void
+incpush(char *p, int addsubdirs)
{
SV *subdir = Nullsv;
static char *archpat_auto;
/* .../archname/version if -d .../archname/version/auto */
sv_setsv(subdir, libdir);
sv_catpv(subdir, archpat_auto);
- if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(incgv),
newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
/* .../archname if -d .../archname/auto */
sv_insert(subdir, SvCUR(libdir) + sizeof(ARCHNAME),
strlen(patchlevel) + 1, "", 0);
- if (Stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode))
av_push(GvAVn(incgv),
newSVpv(SvPVX(subdir), SvCUR(subdir) - sizeof "auto"));
}
#ifdef USE_THREADS
-static struct thread *
+STATIC struct perl_thread *
init_main_thread()
{
- struct thread *thr;
+ struct perl_thread *thr;
XPV *xpv;
- Newz(53, thr, 1, struct thread);
+ Newz(53, thr, 1, struct perl_thread);
curcop = &compiling;
thr->cvcache = newHV();
- thr->magicals = newAV();
+ thr->threadsv = newAV();
thr->specific = newAV();
- thr->errsv = newSVpv("", 0);
thr->errhv = newHV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
#ifdef HAVE_THREAD_INTERN
init_thread_intern(thr);
+#endif
+
+#ifdef SET_THREAD_SELF
+ SET_THREAD_SELF(thr);
#else
thr->self = pthread_self();
-#endif /* HAVE_THREAD_INTERN */
+#endif /* SET_THREAD_SELF */
SET_THR(thr);
/*
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 *paramList)
{
dTHR;
line_t oldline = curcop->cop_line;
dJMPENV;
int ret;
- while (AvFILL(list) >= 0) {
- CV *cv = (CV*)av_shift(list);
+ while (AvFILL(paramList) >= 0) {
+ CV *cv = (CV*)av_shift(paramList);
SAVEFREESV(cv);
JMPENV_POP;
curcop = &compiling;
curcop->cop_line = oldline;
- if (list == beginav)
+ if (paramList == beginav)
sv_catpv(atsv, "BEGIN failed--compilation aborted");
else
sv_catpv(atsv, "END failed--cleanup aborted");
curcop = &compiling;
curcop->cop_line = oldline;
if (statusvalue) {
- if (list == beginav)
+ if (paramList == beginav)
croak("BEGIN failed--compilation aborted");
else
croak("END failed--cleanup aborted");
}
void
-my_exit(status)
-U32 status;
+my_exit(U32 status)
{
dTHR;
}
void
-my_failure_exit()
+my_failure_exit(void)
{
#ifdef VMS
if (vaxc$errno & 1) {
my_exit_jump();
}
-static void
-my_exit_jump()
+STATIC void
+my_exit_jump(void)
{
dTHR;
- register CONTEXT *cx;
+ register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
JMPENV_JUMP(2);
}
+
+
+