/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* "A ship then new they built for him/of mithril and of elven glass" --Bilbo
*/
+/* This file contains the top-level functions that are used to create, use
+ * and destroy a perl interpreter, plus the functions used by XS code to
+ * call back into perl. Note that it does not contain the actual main()
+ * function of the interpreter; that can be found in perlmain.c
+ */
+
+/* PSz 12 Nov 03
+ *
+ * Be proud that perl(1) may proclaim:
+ * Setuid Perl scripts are safer than C programs ...
+ * Do not abandon (deprecate) suidperl. Do not advocate C wrappers.
+ *
+ * The flow was: perl starts, notices script is suid, execs suidperl with same
+ * arguments; suidperl opens script, checks many things, sets itself with
+ * right UID, execs perl with similar arguments but with script pre-opened on
+ * /dev/fd/xxx; perl checks script is as should be and does work. This was
+ * insecure: see perlsec(1) for many problems with this approach.
+ *
+ * The "correct" flow should be: perl starts, opens script and notices it is
+ * suid, checks many things, execs suidperl with similar arguments but with
+ * script on /dev/fd/xxx; suidperl checks script and /dev/fd/xxx object are
+ * same, checks arguments match #! line, sets itself with right UID, execs
+ * perl with same arguments; perl checks many things and does work.
+ *
+ * (Opening the script in perl instead of suidperl, we "lose" scripts that
+ * are readable to the target UID but not to the invoker. Where did
+ * unreadable scripts work anyway?)
+ *
+ * For now, suidperl and perl are pretty much the same large and cumbersome
+ * program, so suidperl can check its argument list (see comments elsewhere).
+ *
+ * References:
+ * Original bug report:
+ * http://bugs.perl.org/index.html?req=bug_id&bug_id=20010322.218
+ * http://rt.perl.org/rt2/Ticket/Display.html?id=6511
+ * Comments and discussion with Debian:
+ * http://bugs.debian.org/203426
+ * http://bugs.debian.org/220486
+ * Debian Security Advisory DSA 431-1 (does not fully fix problem):
+ * http://www.debian.org/security/2004/dsa-431
+ * CVE candidate:
+ * http://cve.mitre.org/cgi-bin/cvename.cgi?name=CAN-2003-0618
+ * Previous versions of this patch sent to perl5-porters:
+ * http://www.mail-archive.com/perl5-porters@perl.org/msg71953.html
+ * http://www.mail-archive.com/perl5-porters@perl.org/msg75245.html
+ * http://www.mail-archive.com/perl5-porters@perl.org/msg75563.html
+ * http://www.mail-archive.com/perl5-porters@perl.org/msg75635.html
+ *
+Paul Szabo - psz@maths.usyd.edu.au http://www.maths.usyd.edu.au:8000/u/psz/
+School of Mathematics and Statistics University of Sydney 2006 Australia
+ *
+ */
+/* PSz 13 Nov 03
+ * Use truthful, neat, specific error messages.
+ * Cannot always hide the truth; security must not depend on doing so.
+ */
+
+/* PSz 18 Feb 04
+ * Use global(?), thread-local fdscript for easier checks.
+ * (I do not understand how we could possibly get a thread race:
+ * do not all threads go through the same initialization? Or in
+ * fact, are not threads started only after we get the script and
+ * so know what to do? Oh well, make things super-safe...)
+ */
+
#include "EXTERN.h"
#define PERL_IN_PERL_C
#include "perl.h"
#include <unistd.h>
#endif
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+# ifdef I_SYS_WAIT
+# include <sys/wait.h>
+# endif
+# ifdef I_SYSUIO
+# include <sys/uio.h>
+# endif
+
+union control_un {
+ struct cmsghdr cm;
+ char control[CMSG_SPACE(sizeof(int))];
+};
+
+#endif
+
#ifdef __BEOS__
# define HZ 1000000
#endif
#ifndef DOSUID
#define DOSUID
#endif
-#endif
+#endif /* IAMSUID */
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef DOSUID
#endif
#endif
-#if defined(USE_ITHREADS)
+#if defined(USE_5005THREADS)
+# define INIT_TLS_AND_INTERP \
+ STMT_START { \
+ if (!PL_curinterp) { \
+ PERL_SET_INTERP(my_perl); \
+ INIT_THREADS; \
+ ALLOC_THREAD_KEY; \
+ } \
+ } STMT_END
+#else
+# if defined(USE_ITHREADS)
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
PERL_SET_THX(my_perl); \
} \
} STMT_END
-#else
+# else
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
PERL_SET_THX(my_perl); \
} STMT_END
# endif
+#endif
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
struct IPerlProc* ipP)
{
PerlInterpreter *my_perl;
- /* New() needs interpreter, so call malloc() instead */
+ /* Newx() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
INIT_TLS_AND_INTERP;
Zero(my_perl, 1, PerlInterpreter);
dTHX;
#endif
- /* New() needs interpreter, so call malloc() instead */
+ /* Newx() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
INIT_TLS_AND_INTERP;
- Zero(my_perl, 1, PerlInterpreter);
- return my_perl;
+ return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
}
#endif /* PERL_IMPLICIT_SYS */
void
perl_construct(pTHXx)
{
+#ifdef USE_5005THREADS
+#ifndef FAKE_THREADS
+ struct perl_thread *thr = NULL;
+#endif /* FAKE_THREADS */
+#endif /* USE_5005THREADS */
+
+ PERL_UNUSED_ARG(my_perl);
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
#endif
/* Init the real globals (and main thread)? */
if (!PL_linestr) {
+#ifdef USE_5005THREADS
+ MUTEX_INIT(&PL_sv_mutex);
+ /*
+ * Safe to use basic SV functions from now on (though
+ * not things like mortals or tainting yet).
+ */
+ 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(&PL_svref_mutex);
+# endif /* EMULATE_ATOMIC_REFCOUNTS */
+
+ MUTEX_INIT(&PL_cred_mutex);
+ MUTEX_INIT(&PL_sv_lock_mutex);
+ MUTEX_INIT(&PL_fdpid_mutex);
+
+ thr = init_main_thread();
+#endif /* USE_5005THREADS */
+
#ifdef PERL_FLEXIBLE_EXCEPTIONS
PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
#endif
SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
sv_setpv(&PL_sv_no,PL_No);
+ /* value lookup in void context - happens to have the side effect
+ of caching the numeric forms. */
+ SvIV(&PL_sv_no);
SvNV(&PL_sv_no);
SvREADONLY_on(&PL_sv_no);
SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
sv_setpv(&PL_sv_yes,PL_Yes);
+ SvIV(&PL_sv_yes);
SvNV(&PL_sv_yes);
SvREADONLY_on(&PL_sv_yes);
SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
}
#if defined(LOCAL_PATCH_COUNT)
- PL_localpatches = local_patches; /* For possible -v */
+ PL_localpatches = (char **) local_patches; /* For possible -v */
#endif
#ifdef HAVE_INTERP_INTERN
It is properly deallocated in perl_destruct() */
PL_strtab = newHV();
+#ifdef USE_5005THREADS
+ MUTEX_INIT(&PL_strtab_mutex);
+#endif
HvSHAREKEYS_off(PL_strtab); /* mandatory */
hv_ksplit(PL_strtab, 512);
#endif
/* Use sysconf(_SC_CLK_TCK) if available, if not
- * available or if the sysconf() fails, use the HZ. */
-#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+ * available or if the sysconf() fails, use the HZ.
+ * BeOS has those, but returns the wrong value.
+ * The HZ if not originally defined has been by now
+ * been defined as CLK_TCK, if available. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
PL_clocktick = sysconf(_SC_CLK_TCK);
if (PL_clocktick <= 0)
#endif
return 0;
}
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+void
+Perl_dump_sv_child(pTHX_ SV *sv)
+{
+ ssize_t got;
+ const int sock = PL_dumper_fd;
+ const int debug_fd = PerlIO_fileno(Perl_debug_log);
+ union control_un control;
+ struct msghdr msg;
+ struct iovec vec[2];
+ struct cmsghdr *cmptr;
+ int returned_errno;
+ unsigned char buffer[256];
+
+ if(sock == -1 || debug_fd == -1)
+ return;
+
+ PerlIO_flush(Perl_debug_log);
+
+ /* All these shenanigans are to pass a file descriptor over to our child for
+ it to dump out to. We can't let it hold open the file descriptor when it
+ forks, as the file descriptor it will dump to can turn out to be one end
+ of pipe that some other process will wait on for EOF. (So as it would
+ be open, the wait would be forever. */
+
+ msg.msg_control = control.control;
+ msg.msg_controllen = sizeof(control.control);
+ /* We're a connected socket so we don't need a destination */
+ msg.msg_name = NULL;
+ msg.msg_namelen = 0;
+ msg.msg_iov = vec;
+ msg.msg_iovlen = 1;
+
+ cmptr = CMSG_FIRSTHDR(&msg);
+ cmptr->cmsg_len = CMSG_LEN(sizeof(int));
+ cmptr->cmsg_level = SOL_SOCKET;
+ cmptr->cmsg_type = SCM_RIGHTS;
+ *((int *)CMSG_DATA(cmptr)) = 1;
+
+ vec[0].iov_base = (void*)&sv;
+ vec[0].iov_len = sizeof(sv);
+ got = sendmsg(sock, &msg, 0);
+
+ if(got < 0) {
+ perror("Debug leaking scalars parent sendmsg failed");
+ abort();
+ }
+ if(got < sizeof(sv)) {
+ perror("Debug leaking scalars parent short sendmsg");
+ abort();
+ }
+
+ /* Return protocol is
+ int: errno value
+ unsigned char: length of location string (0 for empty)
+ unsigned char*: string (not terminated)
+ */
+ vec[0].iov_base = (void*)&returned_errno;
+ vec[0].iov_len = sizeof(returned_errno);
+ vec[1].iov_base = buffer;
+ vec[1].iov_len = 1;
+
+ got = readv(sock, vec, 2);
+
+ if(got < 0) {
+ perror("Debug leaking scalars parent read failed");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+ if(got < sizeof(returned_errno) + 1) {
+ perror("Debug leaking scalars parent short read");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+
+ if (*buffer) {
+ got = read(sock, buffer + 1, *buffer);
+ if(got < 0) {
+ perror("Debug leaking scalars parent read 2 failed");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+
+ if(got < *buffer) {
+ perror("Debug leaking scalars parent short read 2");
+ PerlIO_flush(PerlIO_stderr());
+ abort();
+ }
+ }
+
+ if (returned_errno || *buffer) {
+ Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
+ " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
+ returned_errno, strerror(returned_errno));
+ }
+}
+#endif
+
/*
=for apidoc perl_destruct
{
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ pid_t child;
+#endif
#ifdef USE_5005THREADS
+ Thread t;
dTHX;
#endif /* USE_5005THREADS */
+ PERL_UNUSED_ARG(my_perl);
+
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
+#ifdef USE_5005THREADS
+#ifndef FAKE_THREADS
+ /* Pass 1 on any remaining threads: detach joinables, join zombies */
+ retry_cleanup:
+ MUTEX_LOCK(&PL_threads_mutex);
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "perl_destruct: waiting for %d threads...\n",
+ 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_S(PerlIO_printf(Perl_debug_log,
+ "perl_destruct: joining zombie %p\n", t));
+ ThrSETSTATE(t, THRf_DEAD);
+ MUTEX_UNLOCK(&t->mutex);
+ 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(&PL_threads_mutex);
+ JOIN(t, &av);
+ SvREFCNT_dec((SV*)av);
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "perl_destruct: joined zombie %p OK\n", t));
+ goto retry_cleanup;
+ case THRf_R_JOINABLE:
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "perl_destruct: detaching thread %p\n", t));
+ ThrSETSTATE(t, THRf_R_DETACHED);
+ /*
+ * We unlock threads_mutex and t->mutex in the opposite order
+ * from which we locked them just so that DETACH won't
+ * deadlock if it panics. It's only a breach of good style
+ * not a bug since they are unlocks not locks.
+ */
+ MUTEX_UNLOCK(&PL_threads_mutex);
+ DETACH(t);
+ MUTEX_UNLOCK(&t->mutex);
+ goto retry_cleanup;
+ default:
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "perl_destruct: ignoring %p (state %u)\n",
+ t, ThrSTATE(t)));
+ MUTEX_UNLOCK(&t->mutex);
+ /* fall through and out */
+ }
+ }
+ /* 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 (PL_nthreads > 1)
+ {
+ DEBUG_S(PerlIO_printf(Perl_debug_log,
+ "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_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
+ MUTEX_DESTROY(&PL_threads_mutex);
+ COND_DESTROY(&PL_nthreads_cond);
+ PL_nthreads--;
+#endif /* !defined(FAKE_THREADS) */
+#endif /* USE_5005THREADS */
+
destruct_level = PL_perl_destruct_level;
#ifdef DEBUGGING
{
- char *s;
- if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
- int i = atoi(s);
+ const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL");
+ if (s) {
+ const int i = atoi(s);
if (destruct_level < i)
destruct_level = i;
}
}
#endif
-
- if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
+ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
dJMPENV;
int x = 0;
JMPENV_PUSH(x);
+ PERL_UNUSED_VAR(x);
if (PL_endav && !PL_minus_c)
call_list(PL_scopestack_ix, PL_endav);
JMPENV_POP;
return STATUS_NATIVE_EXPORT;
}
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ if (destruct_level != 0) {
+ /* Fork here to create a child. Our child's job is to preserve the
+ state of scalars prior to destruction, so that we can instruct it
+ to dump any scalars that we later find have leaked.
+ There's no subtlety in this code - it assumes POSIX, and it doesn't
+ fail gracefully */
+ int fd[2];
+
+ if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) {
+ perror("Debug leaking scalars socketpair failed");
+ abort();
+ }
+
+ child = fork();
+ if(child == -1) {
+ perror("Debug leaking scalars fork failed");
+ abort();
+ }
+ if (!child) {
+ /* We are the child */
+ const int sock = fd[1];
+ const int debug_fd = PerlIO_fileno(Perl_debug_log);
+ int f;
+ const char *where;
+ /* Our success message is an integer 0, and a char 0 */
+ static const char success[sizeof(int) + 1];
+
+ close(fd[0]);
+
+ /* We need to close all other file descriptors otherwise we end up
+ with interesting hangs, where the parent closes its end of a
+ pipe, and sits waiting for (another) child to terminate. Only
+ that child never terminates, because it never gets EOF, because
+ we also have the far end of the pipe open. We even need to
+ close the debugging fd, because sometimes it happens to be one
+ end of a pipe, and a process is waiting on the other end for
+ EOF. Normally it would be closed at some point earlier in
+ destruction, but if we happen to cause the pipe to remain open,
+ EOF never occurs, and we get an infinite hang. Hence all the
+ games to pass in a file descriptor if it's actually needed. */
+
+ f = sysconf(_SC_OPEN_MAX);
+ if(f < 0) {
+ where = "sysconf failed";
+ goto abort;
+ }
+ while (f--) {
+ if (f == sock)
+ continue;
+ close(f);
+ }
+
+ while (1) {
+ SV *target;
+ union control_un control;
+ struct msghdr msg;
+ struct iovec vec[1];
+ struct cmsghdr *cmptr;
+ ssize_t got;
+ int got_fd;
+
+ msg.msg_control = control.control;
+ msg.msg_controllen = sizeof(control.control);
+ /* We're a connected socket so we don't need a source */
+ msg.msg_name = NULL;
+ msg.msg_namelen = 0;
+ msg.msg_iov = vec;
+ msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
+
+ vec[0].iov_base = (void*)⌖
+ vec[0].iov_len = sizeof(target);
+
+ got = recvmsg(sock, &msg, 0);
+
+ if(got == 0)
+ break;
+ if(got < 0) {
+ where = "recv failed";
+ goto abort;
+ }
+ if(got < sizeof(target)) {
+ where = "short recv";
+ goto abort;
+ }
+
+ if(!(cmptr = CMSG_FIRSTHDR(&msg))) {
+ where = "no cmsg";
+ goto abort;
+ }
+ if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) {
+ where = "wrong cmsg_len";
+ goto abort;
+ }
+ if(cmptr->cmsg_level != SOL_SOCKET) {
+ where = "wrong cmsg_level";
+ goto abort;
+ }
+ if(cmptr->cmsg_type != SCM_RIGHTS) {
+ where = "wrong cmsg_type";
+ goto abort;
+ }
+
+ got_fd = *(int*)CMSG_DATA(cmptr);
+ /* For our last little bit of trickery, put the file descriptor
+ back into Perl_debug_log, as if we never actually closed it
+ */
+ if(got_fd != debug_fd) {
+ if (dup2(got_fd, debug_fd) == -1) {
+ where = "dup2";
+ goto abort;
+ }
+ }
+ sv_dump(target);
+
+ PerlIO_flush(Perl_debug_log);
+
+ got = write(sock, &success, sizeof(success));
+
+ if(got < 0) {
+ where = "write failed";
+ goto abort;
+ }
+ if(got < sizeof(success)) {
+ where = "short write";
+ goto abort;
+ }
+ }
+ _exit(0);
+ abort:
+ {
+ int send_errno = errno;
+ unsigned char length = (unsigned char) strlen(where);
+ struct iovec failure[3] = {
+ {(void*)&send_errno, sizeof(send_errno)},
+ {&length, 1},
+ {(void*)where, length}
+ };
+ int got = writev(sock, failure, 3);
+ /* Bad news travels fast. Faster than data. We'll get a SIGPIPE
+ in the parent if we try to read from the socketpair after the
+ child has exited, even if there was data to read.
+ So sleep a bit to give the parent a fighting chance of
+ reading the data. */
+ sleep(2);
+ _exit((got == -1) ? errno : 0);
+ }
+ /* End of child. */
+ }
+ PL_dumper_fd = fd[0];
+ close(fd[1]);
+ }
+#endif
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
+ /* Do this now, because destroying ops can cause new SVs to be generated
+ in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they
+ PL_curcop to point to a valid op from which the filename structure
+ member is copied. */
+ PL_curcop = &PL_compiling;
if (PL_main_root) {
/* ensure comppad/curpad to refer to main's pad */
if (CvPADLIST(PL_main_cv)) {
op_free(PL_main_root);
PL_main_root = Nullop;
}
- PL_curcop = &PL_compiling;
PL_main_start = Nullop;
SvREFCNT_dec(PL_main_cv);
PL_main_cv = Nullcv;
*/
sv_clean_objs();
PL_sv_objcount = 0;
+ if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
+ PL_defoutgv = Nullgv; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
*/
#ifndef PERL_MICRO
#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
- if (environ != PL_origenviron
+ if (environ != PL_origenviron && !PL_use_safe_putenv
#ifdef USE_ITHREADS
/* only main thread can free environ[0] contents */
&& PL_curinterp == aTHX
#endif
#endif /* !PERL_MICRO */
+ /* reset so print() ends up where we expect */
+ setdefout(Nullgv);
+
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
* so op_free(PL_main_root) only ReREFCNT_dec's
while (i) {
SV *resv = ary[--i];
- REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
if (SvFLAGS(resv) & SVf_BREAK) {
/* this is PL_reg_curpm, already freed
else if(SvREPADTMP(resv)) {
SvREPADTMP_off(resv);
}
- else {
+ else if(SvIOKp(resv)) {
+ REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
ReREFCNT_dec(re);
}
}
PL_DBsingle = Nullsv;
PL_DBtrace = Nullsv;
PL_DBsignal = Nullsv;
- PL_DBassertion = Nullsv;
PL_DBcv = Nullcv;
PL_dbargs = Nullav;
PL_debstash = Nullhv;
- /* reset so print() ends up where we expect */
- setdefout(Nullgv);
-
SvREFCNT_dec(PL_argvout_stack);
PL_argvout_stack = Nullav;
/* Yell and reset the HeVAL() slots that are still holding refcounts,
* so that sv_free() won't fail on them.
*/
- I32 riter;
- I32 max;
- HE *hent;
- HE **array;
-
- riter = 0;
- max = HvMAX(PL_strtab);
- array = HvARRAY(PL_strtab);
- hent = array[0];
+ I32 riter = 0;
+ const I32 max = HvMAX(PL_strtab);
+ HE ** const array = HvARRAY(PL_strtab);
+ HE *hent = array[0];
+
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Unbalanced string table refcount: (%d) for \"%s\"",
- HeVAL(hent) - Nullsv, HeKEY(hent));
+ "Unbalanced string table refcount: (%ld) for \"%s\"",
+ (long)(HeVAL(hent) - Nullsv), HeKEY(hent));
HeVAL(hent) = Nullsv;
hent = HeNEXT(hent);
}
svend = &sva[SvREFCNT(sva)];
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK) {
- PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
+ PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
+ " flags=0x08%"UVxf
+ " refcnt=%"UVuf pTHX__FORMAT "\n",
+ sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#endif
}
}
}
}
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ {
+ int status;
+ fd_set rset;
+ /* Wait for up to 4 seconds for child to terminate.
+ This seems to be the least effort way of timing out on reaping
+ its exit status. */
+ struct timeval waitfor = {4, 0};
+ int sock = PL_dumper_fd;
+
+ shutdown(sock, 1);
+ FD_ZERO(&rset);
+ FD_SET(sock, &rset);
+ select(sock + 1, &rset, NULL, NULL, &waitfor);
+ waitpid(child, &status, WNOHANG);
+ close(sock);
+ }
+#endif
#endif
PL_sv_count = 0;
SvREFCNT(&PL_sv_undef) = 0;
SvREADONLY_off(&PL_sv_undef);
- SvREFCNT(&PL_sv_placeholder) = 0;
- SvREADONLY_off(&PL_sv_placeholder);
-
Safefree(PL_origfilename);
PL_origfilename = Nullch;
Safefree(PL_reg_start_tmp);
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
- if (PL_reg_curpm)
- Safefree(PL_reg_curpm);
+ Safefree(PL_reg_curpm);
Safefree(PL_reg_poscache);
free_tied_hv_pool();
Safefree(PL_op_mask);
PL_debug = 0;
DEBUG_P(debprofdump());
+#ifdef USE_5005THREADS
+ MUTEX_DESTROY(&PL_strtab_mutex);
+ MUTEX_DESTROY(&PL_sv_mutex);
+ MUTEX_DESTROY(&PL_eval_mutex);
+ MUTEX_DESTROY(&PL_cred_mutex);
+ MUTEX_DESTROY(&PL_fdpid_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(PL_thrsv));
+ Safefree(SvANY(PL_thrsv));
+ Safefree(PL_thrsv);
+ PL_thrsv = Nullsv;
+#endif /* USE_5005THREADS */
#ifdef USE_REENTRANT_API
Perl_reentrant_free(aTHX);
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
+ /* we know that type == SVt_PVMG */
+
/* 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 != PERL_MAGIC_regex_global
- && mg->mg_len >= 0)
- Safefree(mg->mg_ptr);
- Safefree(mg);
- }
+ MAGIC* mg;
+ MAGIC* moremagic;
+ for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
+ && mg->mg_len >= 0)
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
}
+
/* we know that type >= SVt_PV */
- (void)SvOOK_off(PL_mess_sv);
- Safefree(SvPVX(PL_mess_sv));
+ SvPV_free(PL_mess_sv);
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
PL_mess_sv = Nullsv;
#endif
}
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+/* provide destructors to clean up the thread key when libperl is unloaded */
+#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
+
+#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__)
+#pragma fini "perl_fini"
+#endif
+
+static void
+#if defined(__GNUC__)
+__attribute__((destructor))
+#endif
+perl_fini(void)
+{
+ if (PL_curinterp)
+ FREE_THREAD_KEY;
+}
+
+#endif /* WIN32 */
+#endif /* THREADS */
+
void
Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
{
dTHX;
#endif
+ PERL_UNUSED_VAR(my_perl);
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\
setuid perl scripts securely.\n");
-#endif
+#endif /* IAMSUID */
#endif
#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
if (!PL_rehash_seed_set)
PL_rehash_seed = get_hash_seed();
{
- char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
+ const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- if (s) {
- int i = atoi(s);
-
- if (i == 1)
- PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n",
- PL_rehash_seed);
- }
+ if (s && (atoi(s) == 1))
+ PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed);
}
#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
{
/* Set PL_origalen be the sum of the contiguous argv[]
* elements plus the size of the env in case that it is
- * contiguous with the argv[]. This is used in mg.c:mg_set()
+ * contiguous with the argv[]. This is used in mg.c:Perl_magic_set()
* as the maximum modifiable length of $0. In the worst case
* the area we are able to modify is limited to the size of
* the original argv[0]. (See below for 'contiguous', though.)
* --jhi */
- char *s = NULL;
+ const char *s = NULL;
int i;
- UV mask =
+ const UV mask =
~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0);
/* Do the mask check only if the args seem like aligned. */
- UV aligned =
+ const UV aligned =
(mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
/* See if all the arguments are contiguous in memory. Note
}
}
}
- PL_origalen = s - PL_origargv[0] + 1;
+ PL_origalen = s - PL_origargv[0];
}
if (PL_do_undump) {
{
int argc = PL_origargc;
char **argv = PL_origargv;
- char *scriptname = NULL;
- int fdscript = -1;
+ const char *scriptname = NULL;
VOL bool dosearch = FALSE;
- char *validarg = "";
+ const char *validarg = "";
register SV *sv;
register char *s;
- char *cddir = Nullch;
+ const char *cddir = Nullch;
+#ifdef USE_SITECUSTOMIZE
+ bool minus_f = FALSE;
+#endif
+ PL_fdscript = -1;
+ PL_suidscript = -1;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvn("",0); /* first used for -I flags */
SAVEFREESV(sv);
validarg = " PHOOEY ";
else
validarg = argv[0];
+ /*
+ * Can we rely on the kernel to start scripts with argv[1] set to
+ * contain all #! line switches (the whole line)? (argv[0] is set to
+ * the interpreter name, argv[2] to the script name; argv[3] and
+ * above may contain other arguments.)
+ */
#endif
s = argv[0]+1;
reswitch:
case 'W':
case 'X':
case 'w':
- case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
break;
#endif
- if (PL_euid != PL_uid || PL_egid != PL_gid)
- Perl_croak(aTHX_ "No -e allowed in setuid scripts");
+ forbid_setid("-e");
if (!PL_e_script) {
PL_e_script = newSVpvn("",0);
filter_add(read_e_script, NULL);
sv_catpv(PL_e_script, "\n");
break;
+ case 'f':
+#ifdef USE_SITECUSTOMIZE
+ minus_f = TRUE;
+#endif
+ s++;
+ goto reswitch;
+
case 'I': /* -I handled both here and in moreswitches() */
forbid_setid("-I");
if (!*++s && (s=argv[1]) != Nullch) {
argc--,argv++;
}
if (s && *s) {
- char *p;
STRLEN len = strlen(s);
- p = savepvn(s, len);
+ const char * const p = savepvn(s, len);
incpush(p, TRUE, TRUE, FALSE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
s++;
goto reswitch;
case 'V':
- if (!PL_preambleav)
- PL_preambleav = newAV();
- av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0));
- if (*++s != ':') {
- PL_Sv = newSVpv("print myconfig();",0);
+ {
+ SV *opts_prog;
+
+ if (!PL_preambleav)
+ PL_preambleav = newAV();
+ av_push(PL_preambleav,
+ newSVpv("use Config;",0));
+ if (*++s != ':') {
+ STRLEN opts;
+
+ opts_prog = newSVpv("print Config::myconfig(),",0);
#ifdef VMS
- sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\",");
+ sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\",");
#else
- sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\",");
+ sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\",");
#endif
- sv_catpv(PL_Sv,"\" Compile-time options:");
+ opts = SvCUR(opts_prog);
+
+ Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
# ifdef DEBUGGING
- sv_catpv(PL_Sv," DEBUGGING");
+ " DEBUGGING"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS
+ " DEBUG_LEAKING_SCALARS"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ " DEBUG_LEAKING_SCALARS_FORK_DUMP"
+# endif
+# ifdef FAKE_THREADS
+ " FAKE_THREADS"
# endif
# ifdef MULTIPLICITY
- sv_catpv(PL_Sv," MULTIPLICITY");
+ " MULTIPLICITY"
+# endif
+# ifdef MYMALLOC
+ " MYMALLOC"
+# endif
+# ifdef NO_MATHOMS
+ " NO_MATHOMS"
+# endif
+# ifdef PERL_DONT_CREATE_GVSV
+ " PERL_DONT_CREATE_GVSV"
+# endif
+# ifdef PERL_GLOBAL_STRUCT
+ " PERL_GLOBAL_STRUCT"
+# endif
+# ifdef PERL_IMPLICIT_CONTEXT
+ " PERL_IMPLICIT_CONTEXT"
+# endif
+# ifdef PERL_IMPLICIT_SYS
+ " PERL_IMPLICIT_SYS"
+# endif
+# ifdef PERL_MALLOC_WRAP
+ " PERL_MALLOC_WRAP"
+# endif
+# ifdef PERL_NEED_APPCTX
+ " PERL_NEED_APPCTX"
+# endif
+# ifdef PERL_NEED_TIMESBASE
+ " PERL_NEED_TIMESBASE"
+# endif
+# ifdef PERL_OLD_COPY_ON_WRITE
+ " PERL_OLD_COPY_ON_WRITE"
+# endif
+# ifdef PERL_TRACK_MEMPOOL
+ " PERL_TRACK_MEMPOOL"
+# endif
+# ifdef PERL_USE_SAFE_PUTENV
+ " PERL_USE_SAFE_PUTENV"
+# endif
+# ifdef PL_OP_SLAB_ALLOC
+ " PL_OP_SLAB_ALLOC"
+# endif
+# ifdef THREADS_HAVE_PIDS
+ " THREADS_HAVE_PIDS"
# endif
# ifdef USE_5005THREADS
- sv_catpv(PL_Sv," USE_5005THREADS");
+ " USE_5005THREADS"
# endif
-# ifdef USE_ITHREADS
- sv_catpv(PL_Sv," USE_ITHREADS");
+# ifdef USE_64_BIT_ALL
+ " USE_64_BIT_ALL"
# endif
# ifdef USE_64_BIT_INT
- sv_catpv(PL_Sv," USE_64_BIT_INT");
+ " USE_64_BIT_INT"
# endif
-# ifdef USE_64_BIT_ALL
- sv_catpv(PL_Sv," USE_64_BIT_ALL");
+# ifdef USE_ITHREADS
+ " USE_ITHREADS"
+# endif
+# ifdef USE_LARGE_FILES
+ " USE_LARGE_FILES"
# endif
# ifdef USE_LONG_DOUBLE
- sv_catpv(PL_Sv," USE_LONG_DOUBLE");
+ " USE_LONG_DOUBLE"
# endif
-# ifdef USE_LARGE_FILES
- sv_catpv(PL_Sv," USE_LARGE_FILES");
+# ifdef USE_PERLIO
+ " USE_PERLIO"
# endif
-# ifdef USE_SOCKS
- sv_catpv(PL_Sv," USE_SOCKS");
+# ifdef USE_REENTRANT_API
+ " USE_REENTRANT_API"
# endif
-# ifdef PERL_IMPLICIT_CONTEXT
- sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT");
+# ifdef USE_SFIO
+ " USE_SFIO"
# endif
-# ifdef PERL_IMPLICIT_SYS
- sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
+# ifdef USE_SITECUSTOMIZE
+ " USE_SITECUSTOMIZE"
+# endif
+# ifdef USE_SOCKS
+ " USE_SOCKS"
# endif
- sv_catpv(PL_Sv,"\\n\",");
+ );
+
+ while (SvCUR(opts_prog) > opts+76) {
+ /* find last space after "options: " and before col 76
+ */
+
+ const char *space;
+ char *pv = SvPV_nolen(opts_prog);
+ const char c = pv[opts+76];
+ pv[opts+76] = '\0';
+ space = strrchr(pv+opts+26, ' ');
+ pv[opts+76] = c;
+ if (!space) break; /* "Can't happen" */
+
+ /* break the line before that space */
+
+ opts = space - pv;
+ sv_insert(opts_prog, opts, 0,
+ "\\n ", 25);
+ }
+
+ sv_catpv(opts_prog,"\\n\",");
#if defined(LOCAL_PATCH_COUNT)
- if (LOCAL_PATCH_COUNT > 0) {
- int i;
- sv_catpv(PL_Sv,"\" Locally applied patches:\\n\",");
- for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
- if (PL_localpatches[i])
- Perl_sv_catpvf(aTHX_ PL_Sv,"q\" \t%s\n\",",PL_localpatches[i]);
+ if (LOCAL_PATCH_COUNT > 0) {
+ int i;
+ sv_catpv(opts_prog,
+ "\" Locally applied patches:\\n\",");
+ for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
+ if (PL_localpatches[i])
+ Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
+ 0, PL_localpatches[i], 0);
+ }
}
- }
#endif
- Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME);
+ Perl_sv_catpvf(aTHX_ opts_prog,
+ "\" Built under %s\\n\"",OSNAME);
#ifdef __DATE__
# ifdef __TIME__
- Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__);
+ Perl_sv_catpvf(aTHX_ opts_prog,
+ ",\" Compiled at %s %s\\n\"",__DATE__,
+ __TIME__);
# else
- Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__);
+ Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"",
+ __DATE__);
# endif
#endif
- sv_catpv(PL_Sv, "; \
-$\"=\"\\n \"; \
-@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; ");
+ sv_catpv(opts_prog, "; $\"=\"\\n \"; "
+ "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } "
+ "sort grep {/^PERL/} keys %ENV; ");
#ifdef __CYGWIN__
- sv_catpv(PL_Sv,"\
-push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
+ sv_catpv(opts_prog,
+ "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";");
#endif
- sv_catpv(PL_Sv, "\
-print \" \\%ENV:\\n @env\\n\" if @env; \
-print \" \\@INC:\\n @INC\\n\";");
- }
- else {
- PL_Sv = newSVpv("config_vars(qw(",0);
- sv_catpv(PL_Sv, ++s);
- sv_catpv(PL_Sv, "))");
- s += strlen(s);
+ sv_catpv(opts_prog,
+ "print \" \\%ENV:\\n @env\\n\" if @env;"
+ "print \" \\@INC:\\n @INC\\n\";");
+ }
+ else {
+ ++s;
+ opts_prog = Perl_newSVpvf(aTHX_
+ "Config::config_vars(qw%c%s%c)",
+ 0, s, 0);
+ s += strlen(s);
+ }
+ av_push(PL_preambleav, opts_prog);
+ /* don't look for script or read stdin */
+ scriptname = BIT_BUCKET;
+ goto reswitch;
}
- av_push(PL_preambleav, PL_Sv);
- scriptname = BIT_BUCKET; /* don't look for script or read stdin */
- goto reswitch;
case 'x':
PL_doextract = TRUE;
s++;
}
/* catch use of gnu style long options */
if (strEQ(s, "version")) {
- s = "v";
+ s = (char *)"v";
goto reswitch;
}
if (strEQ(s, "help")) {
- s = "h";
+ s = (char *)"h";
goto reswitch;
}
s--;
}
}
switch_end:
- sv_setsv(get_sv("/", TRUE), PL_rs);
if (
#ifndef SECURE_INTERNAL_GETENV
#endif
(s = PerlEnv_getenv("PERL5OPT")))
{
- char *popt = s;
+ const char *popt = s;
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtwA", *s))
+ if (!strchr("DIMUdmtw", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
}
}
+#ifdef USE_SITECUSTOMIZE
+ if (!minus_f) {
+ if (!PL_preambleav)
+ PL_preambleav = newAV();
+ av_unshift(PL_preambleav, 1);
+ (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP));
+ }
+#endif
+
if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
}
init_perllib();
- open_script(scriptname,dosearch,sv,&fdscript);
+ open_script(scriptname,dosearch,sv);
- validate_suid(validarg, scriptname,fdscript);
+ validate_suid(validarg, scriptname);
#ifndef PERL_MICRO
#if defined(SIGCHLD) || defined(SIGCLD)
if (PL_doextract) {
#endif
find_beginning();
- if (cddir && PerlDir_chdir(cddir) < 0)
+ if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
}
CvPADLIST(PL_compcv) = pad_new(0);
#ifdef USE_5005THREADS
CvOWNER(PL_compcv) = 0;
- New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+ Newx(CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */
if (!PL_do_undump)
init_postdump_symbols(argc,argv,env);
- /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
- * PL_utf8locale is conditionally turned on by
+ /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
+ * or explicitly in some platforms.
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
+#if defined(SYMBIAN)
+ PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
+#endif
if (PL_unicode) {
/* Requires init_predump_symbols(). */
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
dTHX;
#endif
+ PERL_UNUSED_ARG(my_perl);
+
oldscope = PL_scopestack_ix;
#ifdef VMS
VMSISH_HUSHED = 0;
#endif
-STATIC void *
+STATIC void
S_run_body(pTHX_ I32 oldscope)
{
DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n",
if (!PL_restartop) {
DEBUG_x(dump_all());
+#ifdef DEBUGGING
PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#endif
DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
PTR2UV(thr)));
PL_op = PL_main_start;
CALLRUNOPS(aTHX);
}
-
my_exit(0);
/* NOTREACHED */
- return NULL;
}
/*
HV*
Perl_get_hv(pTHX_ const char *name, I32 create)
{
- GV* gv = gv_fetchpv(name, create, SVt_PVHV);
+ GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
if (create)
return GvHVn(gv);
if (gv)
/* we're trying to emulate pp_entertry() here */
{
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
if (flags & G_KEEPERR)
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
}
PL_markstack_ptr++;
#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
break;
case 1:
STATUS_ALL_FAILURE;
pop_return();
PL_curpm = newpm;
LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
}
JMPENV_POP;
}
#endif
STATIC void
-S_call_body(pTHX_ OP *myop, int is_eval)
+S_call_body(pTHX_ const OP *myop, bool is_eval)
{
if (PL_op == myop) {
if (is_eval)
UNOP myop; /* fake syntax tree node */
volatile I32 oldmark = SP - PL_stack_base;
volatile I32 retval = 0;
- I32 oldscope;
int ret;
OP* oldop = PL_op;
dJMPENV;
Zero(PL_op, 1, UNOP);
EXTEND(PL_stack_sp, 1);
*++PL_stack_sp = sv;
- oldscope = PL_scopestack_ix;
if (!(flags & G_NOARGS))
myop.op_flags = OPf_STACKED;
CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body),
(OP*)&myop, TRUE);
#else
+ /* fail now; otherwise we could fail after the JMPENV_PUSH but
+ * before a PUSHEVAL, which corrupts the stack after a croak */
+ TAINT_PROPER("eval_sv()");
+
JMPENV_PUSH(ret);
#endif
switch (ret) {
#endif
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
break;
case 1:
STATUS_ALL_FAILURE;
PUTBACK;
if (croak_on_error && SvTRUE(ERRSV)) {
- STRLEN n_a;
- Perl_croak(aTHX_ SvPVx(ERRSV, n_a));
+ Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV));
}
return sv;
dSP;
PUSHSTACKi(PERLSI_REQUIRE);
PUTBACK;
- sv = sv_newmortal();
- sv_setpv(sv, "require '");
- sv_catpv(sv, pv);
- sv_catpv(sv, "'");
- eval_sv(sv, G_DISCARD);
+ sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0);
+ eval_sv(sv_2mortal(sv), G_DISCARD);
SPAGAIN;
POPSTACK;
}
}
STATIC void
-S_usage(pTHX_ char *name) /* XXX move this out into a module ? */
+S_usage(pTHX_ const 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 option. Others? */
- static char *usage_msg[] = {
+ static const char * const usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
"-C[number/list] enables the listed Unicode features",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-e program one line of program (several -e's allowed, omit programfile)",
+"-f don't do $sitelib/sitecustomize.pl at startup",
"-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 execute `use/no module...' before executing program",
-"-n assume 'while (<>) { ... }' loop around program",
+"-[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",
"\n",
NULL
};
- char **p = usage_msg;
+ const char * const *p = usage_msg;
PerlIO_printf(PerlIO_stdout(),
"\nUsage: %s [switches] [--] [programfile] [arguments]",
int
Perl_get_debug_opts(pTHX_ char **s)
{
+ return get_debug_opts_flags(s, 1);
+}
+
+int
+Perl_get_debug_opts_flags(pTHX_ char **s, int flags)
+{
+ static const char * const usage_msgd[] = {
+ " Debugging flag values: (see also -d)",
+ " p Tokenizing and parsing (with v, displays parse stack)",
+ " s Stack snapshots (with v, displays all stacks)",
+ " l Context (loop) stack processing",
+ " t Trace execution",
+ " o Method and overloading resolution",
+ " c String/numeric conversions",
+ " P Print profiling info, preprocessor command for -P, source file input state",
+ " m Memory allocation",
+ " f Format processing",
+ " r Regular expression parsing and execution",
+ " x Syntax tree dump",
+ " u Tainting checks",
+ " H Hash dump -- usurps values()",
+ " X Scratchpad allocation",
+ " D Cleaning up",
+ " S Thread synchronization",
+ " T Tokenising",
+ " R Include reference counts of dumped variables (eg when using -Ds)",
+ " J Do not s,t,P-debug (Jump over) opcodes within package DB",
+ " v Verbose: use in conjunction with other flags",
+ " C Copy On Write",
+ " A Consistency checks on internal structures",
+ " q quiet - currently only suppresses the 'EXECUTING' message",
+ NULL
+ };
int i = 0;
if (isALPHA(**s)) {
/* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxu HXDSTRJvC";
+ static const char debopts[] = "psltocPmfrxu HXDSTRJvC";
for (; isALNUM(**s); (*s)++) {
- char *d = strchr(debopts,**s);
+ const char *d = strchr(debopts,**s);
if (d)
i |= 1 << (d - debopts);
else if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "invalid option -D%c\n", **s);
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+ "invalid option -D%c, use -D'' to see choices\n", **s);
}
}
- else {
+ else if (isDIGIT(**s)) {
i = atoi(*s);
for (; isALNUM(**s); (*s)++) ;
}
+ else if (flags & 1) {
+ /* Give help. */
+ const char *const *p = usage_msgd;
+ while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
+ }
# ifdef EBCDIC
if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
char *
Perl_moreswitches(pTHX_ char *s)
{
- STRLEN numlen;
UV rschar;
switch (*s) {
case '0':
{
I32 flags = 0;
+ STRLEN numlen;
SvREFCNT_dec(PL_rs);
if (s[1] == 'x' && s[2]) {
- char *e;
+ const char *e = s+=2;
U8 *tmps;
- for (s += 2, e = s; *e; e++);
+ while (*e)
+ e++;
numlen = e - s;
flags = PERL_SCAN_SILENT_ILLDIGIT;
rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
PL_rs = newSVpvn(&ch, 1);
}
}
+ sv_setsv(get_sv("/", TRUE), PL_rs);
return s + numlen;
}
case 'C':
case 'd':
forbid_setid("-d");
s++;
+
+ /* -dt indicates to the debugger that threads will be used */
+ if (*s == 't' && !isALNUM(s[1])) {
+ ++s;
+ my_setenv("PERL5DB_THREADED", "1");
+ }
+
/* The following permits -d:Mod to accepts arguments following an =
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
- char *start;
+ const char *start;
SV *sv;
sv = newSVpv("use Devel::", 0);
start = ++s;
sv_catpv(sv, start);
else {
sv_catpvn(sv, start, s-start);
- sv_catpv(sv, " split(/,/,q{");
- sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
+ Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
}
s += strlen(s);
- my_setenv("PERL5DB", SvPV(sv, PL_na));
+ my_setenv("PERL5DB", (char *)SvPV_nolen_const(sv));
}
if (!PL_perldb) {
PL_perldb = PERLDB_ALL;
#ifdef DEBUGGING
forbid_setid("-D");
s++;
- PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
+ PL_debug = get_debug_opts_flags( &s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "Recompile perl with -DDEBUGGING to use -D switch\n");
+ "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
for (s++; isALNUM(*s); s++) ;
#endif
- /*SUPPRESS 530*/
return s;
}
case 'h':
usage(PL_origargv[0]);
my_exit(0);
case 'i':
- if (PL_inplace)
- Safefree(PL_inplace);
+ Safefree(PL_inplace);
#if defined(__CYGWIN__) /* do backup extension automagically */
if (*(s+1) == '\0') {
PL_inplace = savepv(".bak");
}
#endif /* __CYGWIN__ */
PL_inplace = savepv(s+1);
- /*SUPPRESS 530*/
- for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
+ for (s = PL_inplace; *s && !isSPACE(*s); s++)
+ ;
if (*s) {
*s++ = '\0';
if (*s == '-') /* Additional switches on #! line. */
}
if (isDIGIT(*s)) {
I32 flags = 0;
+ STRLEN numlen;
PL_ors_sv = newSVpvn("\n",1);
numlen = 3 + (*s == '0');
*SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
}
}
return s;
- case 'A':
- forbid_setid("-A");
- if (!PL_preambleav)
- PL_preambleav = newAV();
- if (*++s) {
- SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
- sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
- sv_catpv(sv,s);
- sv_catpvn(sv, "\0)", 2);
- s+=strlen(s);
- av_push(PL_preambleav, sv);
- }
- else
- av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
- return s;
case 'M':
forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
if (*++s) {
char *start;
SV *sv;
- char *use = "use ";
+ const char *use = "use ";
/* -M-foo == 'no foo' */
- if (*s == '-') { use = "no "; ++s; }
- sv = newSVpv(use,0);
+ /* Leading space on " no " is deliberate, to make both
+ possibilities the same length. */
+ if (*s == '-') { use = " no "; ++s; }
+ sv = newSVpvn(use,4);
start = s;
/* We allow -M'Module qw(Foo Bar)' */
while(isALNUM(*s) || *s==':') ++s;
av_push(PL_preambleav, sv);
}
else
- Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
+ Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
return s;
case 'n':
PL_minus_n = TRUE;
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2003, Larry Wall\n");
+ "\n\nCopyright 1987-2006, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\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 source kit.\n\n\
Complete documentation for Perl, including FAQ lists, should be found on\n\
-this system using `man perl' or `perldoc perl'. If you have access to the\n\
-Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
+this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\
+Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
my_exit(0);
case 'w':
if (! (PL_dowarn & G_WARN_ALL_MASK))
# if defined(PERL_IMPLICIT_CONTEXT)
# if defined(USE_5005THREADS)
# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# else /* !USE_5005THREADS */
# define PERLVARI(var,type,init) aTHX->var = init;
# define PERLVARIC(var,type,init) aTHX->var = init;
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
SvREADONLY_on(gv);
- HvNAME(PL_defstash) = savepv("main");
+ hv_name_set(PL_defstash, "main", 4, 0);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */
GvMULTI_on(PL_replgv);
(void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */
+#ifdef PERL_DONT_CREATE_GVSV
+ gv_SVadd(PL_errgv);
+#endif
sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */
sv_setpvn(ERRSV, "", 0);
PL_curstash = PL_defstash;
CopSTASH_set(&PL_compiling, PL_defstash);
PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV));
PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
+ PL_nullstash = GvHV(gv_fetchpv("<none>::", GV_ADDMULTI, SVt_PVHV));
/* We must init $/ before switches are processed. */
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
+/* PSz 18 Nov 03 fdscript now global but do not change prototype */
STATIC void
-S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
{
- char *quote;
- char *code;
- char *cpp_discard_flag;
- char *perl;
+#ifndef IAMSUID
+ const char *quote;
+ const char *code;
+ const char *cpp_discard_flag;
+ const char *perl;
+#endif
- *fdscript = -1;
+ PL_fdscript = -1;
+ PL_suidscript = -1;
if (PL_e_script) {
PL_origfilename = savepv("-e");
}
else {
/* if find_script() returns, it returns a malloc()-ed value */
- PL_origfilename = scriptname = find_script(scriptname, dosearch, NULL, 1);
+ scriptname = PL_origfilename = find_script((char *)scriptname, dosearch, NULL, 1);
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
- char *s = scriptname + 8;
- *fdscript = atoi(s);
+ const char *s = scriptname + 8;
+ PL_fdscript = atoi(s);
while (isDIGIT(*s))
s++;
if (*s) {
+ /* PSz 18 Feb 04
+ * Tell apart "normal" usage of fdscript, e.g.
+ * with bash on FreeBSD:
+ * perl <( echo '#!perl -DA'; echo 'print "$0\n"')
+ * from usage in suidperl.
+ * Does any "normal" usage leave garbage after the number???
+ * Is it a mistake to use a similar /dev/fd/ construct for
+ * suidperl?
+ */
+ PL_suidscript = 1;
+ /* PSz 20 Feb 04
+ * Be supersafe and do some sanity-checks.
+ * Still, can we be sure we got the right thing?
+ */
+ if (*s != '/') {
+ Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s);
+ }
+ if (! *(s+1)) {
+ Perl_croak(aTHX_ "Missing (suid) fd script name\n");
+ }
scriptname = savepv(s + 1);
Safefree(PL_origfilename);
- PL_origfilename = scriptname;
+ PL_origfilename = (char *)scriptname;
}
}
}
CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
- if (strEQ(PL_origfilename,"-"))
- scriptname = "";
- if (*fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
+ if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
+ scriptname = (char *)"";
+ if (PL_fdscript >= 0) {
+ PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
if (PL_rsfp)
/* ensure close-on-exec */
fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
# endif
}
+#ifdef IAMSUID
+ else {
+ Perl_croak(aTHX_ "sperl needs fd script\n"
+ "You should not call sperl directly; do you need to "
+ "change a #! line\nfrom sperl to perl?\n");
+
+/* PSz 11 Nov 03
+ * Do not open (or do other fancy stuff) while setuid.
+ * Perl does the open, and hands script to suidperl on a fd;
+ * suidperl only does some checks, sets up UIDs and re-execs
+ * perl with that fd as it has always done.
+ */
+ }
+ if (PL_suidscript != 1) {
+ Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
+ }
+#else /* IAMSUID */
else if (PL_preprocess) {
- char *cpp_cfg = CPPSTDIN;
+ const char *cpp_cfg = CPPSTDIN;
SV *cpp = newSVpvn("",0);
SV *cmd = NEWSV(0,0);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
- scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
+ scriptname, SvPVX_const (cpp), SvPVX_const (sv),
+ CPPMINUS));
# if defined(MSDOS) || defined(WIN32) || defined(VMS)
quote = "\"";
cpp_discard_flag, sv, CPPMINUS);
PL_doextract = FALSE;
-# ifdef IAMSUID /* actually, this is caught earlier */
- if (PL_euid != PL_uid && !PL_euid) { /* if running suidperl */
-# ifdef HAS_SETEUID
- (void)seteuid(PL_uid); /* musn't stay setuid root */
-# else
-# ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1, PL_uid);
-# else
-# ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
-# else
- PerlProc_setuid(PL_uid);
-# endif
-# endif
-# endif
- if (PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
- }
-# endif /* IAMSUID */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: cmd=\"%s\"\n",
- SvPVX(cmd)));
+ SvPVX_const(cmd)));
- PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
+ PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
# endif
}
+#endif /* IAMSUID */
if (!PL_rsfp) {
-# ifdef DOSUID
-# ifndef IAMSUID /* in case script is not readable before setuid */
- if (PL_euid &&
- PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
- PL_statbuf.st_mode & (S_ISUID|S_ISGID))
- {
- /* try again */
- PERL_FPU_PRE_EXEC
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT,
- BIN_EXP, (int)PERL_REVISION,
- (int)PERL_VERSION,
- (int)PERL_SUBVERSION), PL_origargv);
- PERL_FPU_POST_EXEC
- Perl_croak(aTHX_ "Can't do setuid\n");
- }
-# endif
-# endif
-# ifdef IAMSUID
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
-# else
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
-# endif
+ /* PSz 16 Sep 03 Keep neat error message */
+ if (PL_e_script)
+ Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
+ else
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
STATIC int
S_fd_on_nosuid_fs(pTHX_ int fd)
{
+/* PSz 27 Feb 04
+ * We used to do this as "plain" user (after swapping UIDs with setreuid);
+ * but is needed also on machines without setreuid.
+ * Seems safe enough to run as root.
+ */
int check_okay = 0; /* able to do all the required sys/libcalls */
int on_nosuid = 0; /* the fd is on a nosuid fs */
+ /* PSz 12 Nov 03
+ * Need to check noexec also: nosuid might not be set, the average
+ * sysadmin would say that nosuid is irrelevant once he sets noexec.
+ */
+ int on_noexec = 0; /* the fd is on a noexec fs */
+
/*
* Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
* fstatvfs() is UNIX98.
check_okay = fstatvfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
+#ifdef ST_NOEXEC
+ /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
+ on platforms where it is present. */
+ on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
+#endif
# endif /* fstatvfs */
# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
defined(PERL_MOUNT_NOSUID) && \
+ defined(PERL_MOUNT_NOEXEC) && \
defined(HAS_FSTATFS) && \
defined(HAS_STRUCT_STATFS) && \
defined(HAS_STRUCT_STATFS_F_FLAGS)
check_okay = fstatfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
+ on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
# endif /* fstatfs */
# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
defined(PERL_MOUNT_NOSUID) && \
+ defined(PERL_MOUNT_NOEXEC) && \
defined(HAS_FSTAT) && \
defined(HAS_USTAT) && \
defined(HAS_GETMNT) && \
cmplen = sizeof(fsd.fd_req.path);
if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- }
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
}
}
}
# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
defined(HAS_GETMNTENT) && \
defined(HAS_HASMNTOPT) && \
- defined(MNTOPT_NOSUID)
+ defined(MNTOPT_NOSUID) && \
+ defined(MNTOPT_NOEXEC)
# define FD_ON_NOSUID_CHECK_OKAY
FILE *mtab = fopen("/etc/mtab", "r");
struct mntent *entry;
check_okay = 1;
if (hasmntopt(entry, MNTOPT_NOSUID))
on_nosuid = 1;
+ if (hasmntopt(entry, MNTOPT_NOEXEC))
+ on_noexec = 1;
break;
} /* A single fs may well fail its stat(). */
}
# endif /* getmntent+hasmntopt */
if (!check_okay)
- Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid", PL_origfilename);
- return on_nosuid;
+ Perl_croak(aTHX_ "Can't check filesystem of script \"%s\" for nosuid/noexec", PL_origfilename);
+ if (on_nosuid)
+ Perl_croak(aTHX_ "Setuid script \"%s\" on nosuid filesystem", PL_origfilename);
+ if (on_noexec)
+ Perl_croak(aTHX_ "Setuid script \"%s\" on noexec filesystem", PL_origfilename);
+ return ((!check_okay) || on_nosuid || on_noexec);
}
#endif /* IAMSUID */
STATIC void
-S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
+S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
{
#ifdef IAMSUID
- int which;
-#endif
+ /* int which; */
+#endif /* IAMSUID */
/* do we need to emulate setuid on scripts? */
* uid. We don't just make perl setuid root because that loses the
* effective uid we had before invoking perl, if it was different from the
* uid.
+ * PSz 27 Feb 04
+ * Description/comments above do not match current workings:
+ * suidperl must be hardlinked to sperlN.NNN (that is what we exec);
+ * suidperl called with script open and name changed to /dev/fd/N/X;
+ * suidperl croaks if script is not setuid;
+ * making perl setuid would be a huge security risk (and yes, that
+ * would lose any euid we might have had).
*
* DOSUID must be defined in both perl and suidperl, and IAMSUID must
* be defined in suidperl only. suidperl must be setuid root. The
*/
#ifdef DOSUID
- char *s, *s2;
+ const char *s, *s2;
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)) {
+ if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
- STRLEN n_a;
+ const char *linestr;
#ifdef IAMSUID
-#ifndef HAS_SETREUID
+ if (PL_fdscript < 0 || PL_suidscript != 1)
+ Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
+ /* PSz 11 Nov 03
+ * Since the script is opened by perl, not suidperl, some of these
+ * checks are superfluous. Leaving them in probably does not lower
+ * security(?!).
+ */
+ /* PSz 27 Feb 04
+ * Do checks even for systems with no HAS_SETREUID.
+ * We used to swap, then re-swap UIDs with
+#ifdef HAS_SETREUID
+ if (setreuid(PL_euid,PL_uid) < 0
+ || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
+ Perl_croak(aTHX_ "Can't swap uid and euid");
+#endif
+#ifdef HAS_SETREUID
+ if (setreuid(PL_uid,PL_euid) < 0
+ || PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
+ Perl_croak(aTHX_ "Can't reswap uid and euid");
+#endif
+ */
+
/* On this access check to make sure the directories are readable,
* there is actually a small window that the user could use to make
* filename point to an accessible directory. So there is a faint
* non-accessible directory. I don't know what to do about that.
* But I don't think it's too important. The manual lies when
* it says access() is useful in setuid programs.
+ *
+ * So, access() is pretty useless... but not harmful... do anyway.
*/
if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
+ Perl_croak(aTHX_ "Can't access() script\n");
}
-#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
* inode to make sure we did stat() on the same file we opened.
* Then we just have to make sure he or she can execute it.
+ *
+ * PSz 24 Feb 04
+ * As the script is opened by perl, not suidperl, we do not need to
+ * care much about access rights.
+ *
+ * The 'script changed' check is needed, or we can get lied to
+ * about $0 with e.g.
+ * suidperl /dev/fd/4//bin/x 4<setuidscript
+ * Without HAS_SETREUID, is it safe to stat() as root?
+ *
+ * Are there any operating systems that pass /dev/fd/xxx for setuid
+ * scripts, as suggested/described in perlsec(1)? Surely they do not
+ * pass the script name as we do, so the "script changed" test would
+ * fail for them... but we never get here with
+ * SETUID_SCRIPTS_ARE_SECURE_NOW defined.
+ *
+ * This is one place where we must "lie" about return status: not
+ * say if the stat() failed. We are doing this as root, and could
+ * be tricked into reporting existence or not of files that the
+ * "plain" user cannot even see.
*/
{
Stat_t tmpstatbuf;
-
- if (
-#ifdef HAS_SETREUID
- setreuid(PL_euid,PL_uid) < 0
-#else
-# if HAS_SETRESUID
- setresuid(PL_euid,PL_uid,(Uid_t)-1) < 0
-# endif
-#endif
- || PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't swap uid and euid"); /* really paranoid */
- if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0) {
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n"); /* testing full pathname here */
- }
-#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
- }
-#endif
- if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
+ if (PerlLIO_stat(CopFILE(PL_curcop),&tmpstatbuf) < 0 ||
+ tmpstatbuf.st_dev != PL_statbuf.st_dev ||
tmpstatbuf.st_ino != PL_statbuf.st_ino) {
- (void)PerlIO_close(PL_rsfp);
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
+ Perl_croak(aTHX_ "Setuid script changed\n");
}
- if (
-#ifdef HAS_SETREUID
- setreuid(PL_uid,PL_euid) < 0
-#else
-# if defined(HAS_SETRESUID)
- setresuid(PL_uid,PL_euid,(Uid_t)-1) < 0
-# endif
-#endif
- || 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");
+
+ }
+ if (!cando(S_IXUSR,FALSE,&PL_statbuf)) /* can real uid exec? */
+ Perl_croak(aTHX_ "Real UID cannot exec script\n");
+
+ /* PSz 27 Feb 04
+ * We used to do this check as the "plain" user (after swapping
+ * UIDs). But the check for nosuid and noexec filesystem is needed,
+ * and should be done even without HAS_SETREUID. (Maybe those
+ * operating systems do not have such mount options anyway...)
+ * Seems safe enough to do as root.
+ */
+#if !defined(NO_NOSUID_CHECK)
+ if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
+ Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
}
-#endif /* HAS_SETREUID */
+#endif
#endif /* IAMSUID */
if (!S_ISREG(PL_statbuf.st_mode)) {
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
+ Perl_croak(aTHX_ "Setuid script not plain file\n");
}
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 */
+ /* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
CopLINE_inc(PL_curcop);
- if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
- strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
+ if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch)
+ Perl_croak(aTHX_ "No #! line");
+ linestr = SvPV_nolen_const(PL_linestr);
+ /* required even on Sys V */
+ if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
Perl_croak(aTHX_ "No #! line");
- s = SvPV(PL_linestr,n_a)+2;
- if (*s == ' ') s++;
- while (!isSPACE(*s)) s++;
- 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 */
+ linestr += 2;
+ s = linestr;
+ /* PSz 27 Feb 04 */
+ /* Sanity check on line length */
+ if (strlen(s) < 1 || strlen(s) > 4000)
+ Perl_croak(aTHX_ "Very long #! line");
+ /* Allow more than a single space after #! */
+ while (isSPACE(*s)) s++;
+ /* Sanity check on buffer end */
+ while ((*s) && !isSPACE(*s)) s++;
+ for (s2 = s; (s2 > linestr &&
+ (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
+ || s2[-1] == '-')); s2--) ;
+ /* Sanity check on buffer start */
+ if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
+ (s-9 < linestr || strnNE(s-9,"perl",4)) )
Perl_croak(aTHX_ "Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
* mentioning suidperl explicitly, but they may not add any strange
* arguments beyond what #! says if they do invoke suidperl that way.
*/
+ /*
+ * The way validarg was set up, we rely on the kernel to start
+ * scripts with argv[1] set to contain all #! line switches (the
+ * whole line).
+ */
+ /*
+ * Check that we got all the arguments listed in the #! line (not
+ * just that there are no extraneous arguments). Might not matter
+ * much, as switches from #! line seem to be acted upon (also), and
+ * so may be checked and trapped in perl. But, security checks must
+ * be done in suidperl and not deferred to perl. Note that suidperl
+ * does not get around to parsing (and checking) the switches on
+ * the #! line (but execs perl sooner).
+ * Allow (require) a trailing newline (which may be of two
+ * characters on some architectures?) (but no other trailing
+ * whitespace).
+ */
len = strlen(validarg);
if (strEQ(validarg," PHOOEY ") ||
- strnNE(s,validarg,len) || !isSPACE(s[len]))
+ strnNE(s,validarg,len) || !isSPACE(s[len]) ||
+ !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1]))))
Perl_croak(aTHX_ "Args must match #! line");
#ifndef IAMSUID
- if (PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
+ if (PL_fdscript < 0 &&
+ 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, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
#endif /* IAMSUID */
- if (PL_euid) { /* oops, we're not the setuid root perl */
- (void)PerlIO_close(PL_rsfp);
+ if (PL_fdscript < 0 &&
+ PL_euid) { /* oops, we're not the setuid root perl */
+ /* PSz 18 Feb 04
+ * When root runs a setuid script, we do not go through the same
+ * steps of execing sperl and then perl with fd scripts, but
+ * simply set up UIDs within the same perl invocation; so do
+ * not have the same checks (on options, whatever) that we have
+ * for plain users. No problem really: would have to be a script
+ * that does not actually work for plain users; and if root is
+ * foolish and can be persuaded to run such an unsafe script, he
+ * might run also non-setuid ones, and deserves what he gets.
+ *
+ * Or, we might drop the PL_euid check above (and rely just on
+ * PL_fdscript to avoid loops), and do the execs
+ * even for root.
+ */
#ifndef IAMSUID
- /* try again */
+ int which;
+ /* PSz 11 Nov 03
+ * Pass fd script to suidperl.
+ * Exec suidperl, substituting fd script for scriptname.
+ * Pass script name as "subdir" of fd, which perl will grok;
+ * in fact will use that to distinguish this from "normal"
+ * usage, see comments above.
+ */
+ PerlIO_rewind(PL_rsfp);
+ PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0); /* just in case rewind didn't */
+ /* PSz 27 Feb 04 Sanity checks on scriptname */
+ if ((!scriptname) || (!*scriptname) ) {
+ Perl_croak(aTHX_ "No setuid script name\n");
+ }
+ if (*scriptname == '-') {
+ Perl_croak(aTHX_ "Setuid script name may not begin with dash\n");
+ /* Or we might confuse it with an option when replacing
+ * name in argument list, below (though we do pointer, not
+ * string, comparisons).
+ */
+ }
+ for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ;
+ if (!PL_origargv[which]) {
+ Perl_croak(aTHX_ "Can't change argv to have fd script\n");
+ }
+ 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(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
+#endif
PERL_FPU_PRE_EXEC
PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);
PERL_FPU_POST_EXEC
-#endif
- Perl_croak(aTHX_ "Can't do setuid\n");
+#endif /* IAMSUID */
+ Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
}
if (PL_statbuf.st_mode & S_ISGID && PL_statbuf.st_gid != PL_egid) {
+/* PSz 26 Feb 04
+ * This seems back to front: we try HAS_SETEGID first; if not available
+ * then try HAS_SETREGID; as a last chance we try HAS_SETRESGID. May be OK
+ * in the sense that we only want to set EGID; but are there any machines
+ * with either of the latter, but not the former? Same with UID, later.
+ */
#ifdef HAS_SETEGID
(void)setegid(PL_statbuf.st_gid);
#else
}
init_ids();
if (!cando(S_IXUSR,TRUE,&PL_statbuf))
- Perl_croak(aTHX_ "Permission denied\n"); /* they can't do this */
+ Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
}
#ifdef IAMSUID
- else if (PL_preprocess)
+ else if (PL_preprocess) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
- else if (fdscript >= 0)
- Perl_croak(aTHX_ "fd script not allowed in suidperl\n");
+ else if (PL_fdscript < 0 || PL_suidscript != 1)
+ /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
+ Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
else {
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
+/* PSz 16 Sep 03 Keep neat error message */
+ 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.) */
+ /*
+ * It might be thought that using setresgid and/or setresuid (changed to
+ * set the saved IDs) above might obviate the need to exec, and we could
+ * go on to "do the perl thing".
+ *
+ * Is there such a thing as "saved GID", and is that set for setuid (but
+ * not setgid) execution like suidperl? Without exec, it would not be
+ * cleared for setuid (but not setgid) scripts (or might need a dummy
+ * setresgid).
+ *
+ * We need suidperl to do the exact same argument checking that perl
+ * does. Thus it cannot be very small; while it could be significantly
+ * smaller, it is safer (simpler?) to make it essentially the same
+ * binary as perl (but they are not identical). - Maybe could defer that
+ * check to the invoked perl, and suidperl be a tiny wrapper instead;
+ * but prefer to do thorough checks in suidperl itself. Such deferral
+ * would make suidperl security rely on perl, a design no-no.
+ *
+ * Setuid things should be short and simple, thus easy to understand and
+ * verify. They should do their "own thing", without influence by
+ * attackers. It may help if their internal execution flow is fixed,
+ * regardless of platform: it may be best to exec anyway.
+ *
+ * Suidperl should at least be conceptually simple: a wrapper only,
+ * never to do any real perl. Maybe we should put
+ * #ifdef IAMSUID
+ * Perl_croak(aTHX_ "Suidperl should never do real perl\n");
+ * #endif
+ * into the perly bits.
+ */
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]) {
- errno = EPERM;
- Perl_croak(aTHX_ "Permission denied\n");
- }
- PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
- PerlIO_fileno(PL_rsfp), PL_origargv[which]));
+ /* PSz 11 Nov 03
+ * Keep original arguments: suidperl already has fd script.
+ */
+/* for (which = 1; PL_origargv[which] && PL_origargv[which] != scriptname; which++) ; */
+/* if (!PL_origargv[which]) { */
+/* errno = EPERM; */
+/* Perl_croak(aTHX_ "Permission denied\n"); */
+/* } */
+/* 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(PL_rsfp),F_SETFD,0); /* ensure no close-on-exec */
#endif
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);/* try again */
PERL_FPU_POST_EXEC
- Perl_croak(aTHX_ "Can't do setuid\n");
+ Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
#endif /* IAMSUID */
#else /* !DOSUID */
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
/* not set-id, must be wrapped */
}
#endif /* DOSUID */
+ (void)validarg;
+ (void)scriptname;
}
STATIC void
S_find_beginning(pTHX)
{
- register char *s, *s2;
+ register char *s;
+ register const char *s2;
#ifdef MACOS_TRADITIONAL
int maclines = 0;
#endif
s2 = s;
while (*s == ' ' || *s == '\t') s++;
if (*s++ == '-') {
- while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
+ while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
+ || s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
- /*SUPPRESS 530*/
while ((s = moreswitches(s)))
;
}
/* Should not happen: */
CHECK_MALLOC_TAINT(PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
+ /* BUG */
+ /* PSz 27 Feb 04
+ * Should go by suidscript, not uid!=euid: why disallow
+ * system("ls") in scripts run from setuid things?
+ * Or, is this run before we check arguments and set suidscript?
+ * What about SETUID_SCRIPTS_ARE_SECURE_NOW: could we use fdscript then?
+ * (We never have suidscript, can we be sure to have fdscript?)
+ * Or must then go by UID checks? See comments in forbid_setid also.
+ */
}
/* This is used very early in the lifetime of the program,
int euid = PerlProc_geteuid();
int gid = PerlProc_getgid();
int egid = PerlProc_getegid();
+ (void)envp;
#ifdef VMS
uid |= gid << 16;
}
STATIC void
-S_forbid_setid(pTHX_ char *s)
+S_forbid_setid(pTHX_ const char *s)
{
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
if (PL_euid != PL_uid)
Perl_croak(aTHX_ "No %s allowed while running setuid", s);
if (PL_egid != PL_gid)
Perl_croak(aTHX_ "No %s allowed while running setgid", s);
+#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+ /* PSz 29 Feb 04
+ * Checks for UID/GID above "wrong": why disallow
+ * perl -e 'print "Hello\n"'
+ * from within setuid things?? Simply drop them: replaced by
+ * fdscript/suidscript and #ifdef IAMSUID checks below.
+ *
+ * This may be too late for command-line switches. Will catch those on
+ * the #! line, after finding the script name and setting up
+ * fdscript/suidscript. Note that suidperl does not get around to
+ * parsing (and checking) the switches on the #! line, but checks that
+ * the two sets are identical.
+ *
+ * With SETUID_SCRIPTS_ARE_SECURE_NOW, could we use fdscript, also or
+ * instead, or would that be "too late"? (We never have suidscript, can
+ * we be sure to have fdscript?)
+ *
+ * Catch things with suidscript (in descendant of suidperl), even with
+ * right UID/GID. Was already checked in suidperl, with #ifdef IAMSUID,
+ * below; but I am paranoid.
+ *
+ * Also see comments about root running a setuid script, elsewhere.
+ */
+ if (PL_suidscript >= 0)
+ Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
+#ifdef IAMSUID
+ /* PSz 11 Nov 03 Catch it in suidperl, always! */
+ Perl_croak(aTHX_ "No %s allowed in suidperl", s);
+#endif /* IAMSUID */
}
void
PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
- sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
PL_DBsignal = GvSV((gv_fetchpv("DB::signal", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsignal, 0);
- PL_DBassertion = GvSV((gv_fetchpv("DB::assertion", GV_ADDMULTI, SVt_PV)));
- sv_setiv(PL_DBassertion, 0);
PL_curstash = ostash;
}
PL_stack_sp = PL_stack_base;
PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
- New(50,PL_tmps_stack,REASONABLE(128),SV*);
+ Newx(PL_tmps_stack,REASONABLE(128),SV*);
PL_tmps_floor = -1;
PL_tmps_ix = -1;
PL_tmps_max = REASONABLE(128);
- New(54,PL_markstack,REASONABLE(32),I32);
+ Newx(PL_markstack,REASONABLE(32),I32);
PL_markstack_ptr = PL_markstack;
PL_markstack_max = PL_markstack + REASONABLE(32);
SET_MARK_OFFSET;
- New(54,PL_scopestack,REASONABLE(32),I32);
+ Newx(PL_scopestack,REASONABLE(32),I32);
PL_scopestack_ix = 0;
PL_scopestack_max = REASONABLE(32);
- New(54,PL_savestack,REASONABLE(128),ANY);
+ Newx(PL_savestack,REASONABLE(128),ANY);
PL_savestack_ix = 0;
PL_savestack_max = REASONABLE(128);
PL_statname = NEWSV(66,0); /* last filename we did stat on */
- if (PL_osname)
- Safefree(PL_osname);
+ Safefree(PL_osname);
PL_osname = savepv(OSNAME);
}
void
Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
{
- char *s;
argc--,argv++; /* skip name of script */
if (PL_doswitches) {
for (; argc > 0 && **argv == '-'; argc--,argv++) {
+ char *s;
if (!argv[0][1])
break;
if (argv[0][1] == '-' && !argv[0][2]) {
(void)gv_AVadd(PL_argvgv);
av_clear(GvAVn(PL_argvgv));
for (; argc > 0; argc--,argv++) {
- SV *sv = newSVpv(argv[0],0);
+ SV * const sv = newSVpv(argv[0],0);
av_push(GvAVn(PL_argvgv),sv);
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
#endif /* HAS_PROCSELFEXE */
STATIC void
+S_set_caret_X(pTHX) {
+ GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
+ if (tmpgv) {
+#ifdef HAS_PROCSELFEXE
+ S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
+#ifdef OS2
+ sv_setpv(GvSVn(tmpgv), os2_execname(aTHX));
+#else
+ sv_setpv(GvSVn(tmpgv),PL_origargv[0]);
+#endif
+#endif
+ }
+}
+
+STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
- char *s;
- SV *sv;
GV* tmpgv;
PL_toptarget = NEWSV(0,0);
magicname("0", "0", 1);
#endif
}
- if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
-#ifdef HAS_PROCSELFEXE
- S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
-#else
-#ifdef OS2
- sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
-#else
- sv_setpv(GvSV(tmpgv),PL_origargv[0]);
-#endif
-#endif
- }
+ S_set_caret_X(aTHX);
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
{
environ[0] = Nullch;
}
- if (env)
+ if (env) {
+ char** origenv = environ;
+ char *s;
+ SV *sv;
for (; *env; env++) {
- if (!(s = strchr(*env,'=')))
+ if (!(s = strchr(*env,'=')) || s == *env)
continue;
#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
(void)hv_store(hv, *env, s - *env, sv, 0);
if (env != environ)
mg_set(sv);
+ if (origenv != environ) {
+ /* realloc has shifted us */
+ env = (env - origenv) + environ;
+ origenv = environ;
+ }
}
+ }
#endif /* USE_ENVIRON_ARRAY */
#endif /* !PERL_MICRO */
}
if (!PL_tainting) {
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
+/*
+ * It isn't possible to delete an environment variable with
+ * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
+ * case we treat PERL5LIB as undefined if it has a zero-length value.
+ */
+#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
+ if (s && *s != '\0')
+#else
if (s)
+#endif
incpush(s, TRUE, TRUE, TRUE);
else
incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH) || defined(EPOC)
+#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
# define PERLLIB_MANGLE(s,n) (s)
#endif
+/* Push a directory onto @INC if it exists.
+ Generate a new SV if we do this, to save needing to copy the SV we push
+ onto @INC */
+STATIC SV *
+S_incpush_if_exists(pTHX_ SV *dir)
+{
+ Stat_t tmpstatbuf;
+ if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
+ S_ISDIR(tmpstatbuf.st_mode)) {
+ av_push(GvAVn(PL_incgv), dir);
+ dir = NEWSV(0,0);
+ }
+ return dir;
+}
+
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
+S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep)
{
SV *subdir = Nullsv;
+ const char *p = dir;
if (!p || !*p)
return;
if (addsubdirs || addoldvers) {
- subdir = sv_newmortal();
+ subdir = NEWSV(0,0);
}
/* Break at all separators */
while (p && *p) {
SV *libdir = NEWSV(55,0);
- char *s;
+ const char *s;
/* skip any consecutive separators */
if (usesep) {
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- Stat_t tmpstatbuf;
#ifdef VMS
char *unix;
STRLEN len;
libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../version if -d .../version */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
/* .../archname if -d .../archname */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
+
}
#ifdef PERL_INC_VERSION_LIST
for (incver = incverlist; *incver; incver++) {
/* .../xxx if -d .../xxx */
Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
- if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
- S_ISDIR(tmpstatbuf.st_mode))
- av_push(GvAVn(PL_incgv), newSVsv(subdir));
+ subdir = S_incpush_if_exists(aTHX_ subdir);
}
}
#endif
/* finally push this lib directory on the end of @INC */
av_push(GvAVn(PL_incgv), libdir);
}
+ if (subdir) {
+ assert (SvREFCNT(subdir) == 1);
+ SvREFCNT_dec(subdir);
+ }
}
#ifdef USE_5005THREADS
#endif
XPV *xpv;
- Newz(53, thr, 1, struct perl_thread);
+ Newxz(thr, 1, struct perl_thread);
PL_curcop = &PL_compiling;
thr->interp = PERL_GET_INTERP;
thr->cvcache = newHV();
thr->flags = THRf_R_JOINABLE;
MUTEX_INIT(&thr->mutex);
/* Handcraft thrsv similarly to mess_sv */
- New(53, PL_thrsv, 1, SV);
- Newz(53, xpv, 1, XPV);
+ Newx(PL_thrsv, 1, SV);
+ Newxz(xpv, 1, XPV);
SvFLAGS(PL_thrsv) = SVt_PV;
SvANY(PL_thrsv) = (void*)xpv;
SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
- SvPVX(PL_thrsv) = (char*)thr;
+ SvPV_set(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 */
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
SV *atsv;
- line_t oldline = CopLINE(PL_curcop);
+ const line_t oldline = CopLINE(PL_curcop);
CV *cv;
STRLEN len;
int ret;
dJMPENV;
- while (AvFILL(paramList) >= 0) {
+ while (av_len(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
if (PL_savebegin) {
if (paramList == PL_beginav) {
call_list_body(cv);
#endif
atsv = ERRSV;
- (void)SvPV(atsv, len);
+ (void)SvPV_const(atsv, len);
if (len) {
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
STATUS_NATIVE_SET(44);
}
else {
- if (!vaxc$errno && errno) /* unlikely */
+ if (!vaxc$errno) /* unlikely */
STATUS_NATIVE_SET(44);
else
STATUS_NATIVE_SET(vaxc$errno);
}
JMPENV_JUMP(2);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(newsp);
}
static I32
read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen)
{
- char *p, *nl;
- p = SvPVX(PL_e_script);
- nl = strchr(p, '\n');
+ const char * const p = SvPVX_const(PL_e_script);
+ const char *nl = strchr(p, '\n');
+
+ PERL_UNUSED_ARG(idx);
+ PERL_UNUSED_ARG(maxlen);
+
nl = (nl) ? nl+1 : SvEND(PL_e_script);
if (nl-p == 0) {
filter_del(read_e_script);
return 0;
}
sv_catpvn(buf_sv, p, nl-p);
- sv_chop(PL_e_script, nl);
+ sv_chop(PL_e_script, (char *) nl);
return 1;
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
https://perl5.git.perl.org / perl5.git / blobdiff