#include <sys/file.h>
#endif
-dEXTCONST char rcsid[] = "perl.c\nPatch level: ###\n";
-
#ifdef IAMSUID
#ifndef DOSUID
#define DOSUID
MUTEX_INIT(&PL_svref_mutex);
#endif /* EMULATE_ATOMIC_REFCOUNTS */
+ MUTEX_INIT(&PL_cred_mutex);
+
thr = init_main_thread();
#endif /* USE_THREADS */
+ 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;
#endif
+ ((double) PATCHLEVEL / (double) 1000)
+ ((double) SUBVERSION / (double) 100000));
#else
- sprintf(patchlevel, "%5.3f", (double) 5 +
+ sprintf(PL_patchlevel, "%5.3f", (double) 5 +
((double) PATCHLEVEL / (double) 1000));
#endif
/* Pass 1 on any remaining threads: detach joinables, join zombies */
retry_cleanup:
MUTEX_LOCK(&PL_threads_mutex);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: waiting for %d threads...\n",
PL_nthreads - 1));
for (t = thr->next; t != thr; t = t->next) {
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);
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);
/*
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);
/* Pass 2 on remaining threads: wait for the thread count to drop to one */
while (PL_nthreads > 1)
{
- DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(),
"perl_destruct: final wait for %d threads\n",
PL_nthreads - 1));
COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
}
/* At this point, we're the last thread */
MUTEX_UNLOCK(&PL_threads_mutex);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+ 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) */
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 */
DEBUG_P(debprofdump());
#ifdef USE_THREADS
+ 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);
/* As the penultimate thing, free the non-arena SV for thrsv */
/* 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));
time(&PL_basetime);
oldscope = PL_scopestack_ix;
+ PL_dowarn = G_WARN_OFF;
JMPENV_PUSH(ret);
switch (ret) {
case 'u':
case 'U':
case 'v':
+ case 'W':
+ case 'X':
case 'w':
if (s = moreswitches(s))
goto reswitch;
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
sv_catpv(PL_Sv," DEBUGGING");
# endif
# ifdef NO_EMBED
- sv_catpv(Sv," NO_EMBED");
+ sv_catpv(PL_Sv," NO_EMBED");
# endif
# ifdef MULTIPLICITY
sv_catpv(PL_Sv," MULTIPLICITY");
# ifdef __TIME__
sv_catpvf(PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
# else
- sv_catpvf(Sv,",\" Compiled on %s\\n\"",__DATE__);
+ sv_catpvf(PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
# endif
#endif
sv_catpv(PL_Sv, "; \
if (PL_do_undump)
my_unexec();
- if (PL_dowarn)
+ if (ckWARN(WARN_ONCE))
gv_check(PL_defstash);
LEAVE;
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);
#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++)
PATCHLEVEL, 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)
#ifdef MPE
printf("MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1998\n");
#endif
+#ifdef OEMVS
+ printf("MVS (OS390) port by Mortice Kern Systems, 1997-1998\n");
+#endif
+#ifdef __VOS__
+ printf("Stratus VOS port by Paul_Green@stratus.com, 1997-1998\n");
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
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':
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);
#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_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; \
} STMT_END
I_REINIT;
#else
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_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(perl_get_sv("/", TRUE), "\n", 1);
}
STATIC void
-e \"/^#[ ]*endif/b\" \
-e \"s/^#.*//\" \
%s | %_ -C %_ %s",
- (doextract ? "-e \"1,/^#/d\n\"" : ""),
+ (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
#else
sv_setpvf(cmd, "\
%s %s -e '/^[^#]/b' \
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)
+ if (PerlProc_geteuid() != PL_uid)
croak("Can't do seteuid!\n");
}
#endif /* IAMSUID */
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);
+ PerlProc_execv(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
croak("Can't do setuid\n");
}
#endif
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 */
+ croak("Can't stat script \"%s\"",PL_origfilename);
+ if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
#ifdef IAMSUID
* 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*/
+ if (PerlLIO_access(SvPVX(GvSV(PL_curcop->cop_filegv)),1)) /*double check*/
croak("Permission denied");
#else
/* If we can swap euid and uid, then we can determine access rights
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)
+ || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
croak("Can't swap uid and euid"); /* really paranoid */
- if (PerlLIO_stat(SvPVX(GvSV(curcop->cop_filegv)),&tmpstatbuf) < 0)
+ if (PerlLIO_stat(SvPVX(GvSV(PL_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,
+ 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");
}
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)
+ || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
croak("Can't reswap uid and euid");
- if (!cando(S_IXUSR,FALSE,&statbuf)) /* can real uid exec? */
+ if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
croak("Permission denied\n");
}
#endif /* HAS_SETREUID */
#endif /* IAMSUID */
- if (!S_ISREG(statbuf.st_mode))
+ if (!S_ISREG(PL_statbuf.st_mode))
croak("Permission denied");
- if (statbuf.st_mode & S_IWOTH)
+ if (PL_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 */
+ 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,PL_na),"#!",2) ) /* required even on Sys V */
croak("No #! line");
- s = SvPV(linestr,na)+2;
+ s = SvPV(PL_linestr,PL_na)+2;
if (*s == ' ') s++;
while (!isSPACE(*s)) s++;
- for (s2 = s; (s2 > SvPV(linestr,na)+2 &&
+ for (s2 = s; (s2 > SvPV(PL_linestr,PL_na)+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");
croak("Args must match #! line");
#ifndef IAMSUID
- if (euid != uid && (statbuf.st_mode & S_ISUID) &&
- euid == statbuf.st_uid)
- if (!do_undump)
+ if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
+ PL_euid == PL_statbuf.st_uid)
+ if (!PL_do_undump)
croak("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(form("%s/sperl%s", BIN_EXP, PL_patchlevel), PL_origargv);
#endif
croak("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)
+ if (PerlProc_getegid() != PL_statbuf.st_gid)
croak("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)
+ if (PerlProc_geteuid() != PL_statbuf.st_uid)
croak("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)
+ if (PerlProc_geteuid() != PL_uid)
croak("Can't do seteuid!\n");
}
init_ids();
- if (!cando(S_IXUSR,TRUE,&statbuf))
+ if (!cando(S_IXUSR,TRUE,&PL_statbuf))
croak("Permission denied\n"); /* they can't do this */
}
#ifdef IAMSUID
- else if (preprocess)
+ else if (PL_preprocess)
croak("-P not allowed for setuid/setgid script\n");
else if (fdscript >= 0)
croak("fd script not allowed 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])
+ 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])
croak("Permission denied");
- origargv[which] = savepv(form("/dev/fd/%d/%s",
- PerlIO_fileno(rsfp), origargv[which]));
+ PL_origargv[which] = savepv(form("/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 */
+ PerlProc_execv(form("%s/perl%s", BIN_EXP, PL_patchlevel), PL_origargv);/* try again */
croak("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)
+ if (!PL_do_undump)
croak("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 */
PL_gid = (int)PerlProc_getgid();
PL_egid = (int)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));
}
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), newSVpv(".", 1)); */
p++;
}
char *unix;
STRLEN len;
- if ((unix = tounixspec_ts(SvPV(libdir,na),Nullch)) != Nullch) {
+ if ((unix = tounixspec_ts(SvPV(libdir,PL_na),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,PL_na));
#endif
/* .../archname/version if -d .../archname/version/auto */
sv_setsv(subdir, libdir);
{
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;
JMPENV_JUMP(2);
}
+#ifdef PERL_OBJECT
+#define NO_XSLOCKS
+#endif /* PERL_OBJECT */
#include "XSUB.h"
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff