/* perl.c
*
- * Copyright (c) 1987-2001 Larry Wall
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, 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 "patchlevel.h" /* for local_patches */
+#ifdef NETWARE
+#include "nwutil.h"
+char *nw_get_sitelib(const char *pl);
+#endif
+
/* XXX If this causes problems, set i_unistd=undef in the hint file. */
#ifdef I_UNISTD
#include <unistd.h>
#endif
+#ifdef __BEOS__
+# define HZ 1000000
+#endif
+
+#ifndef HZ
+# ifdef CLK_TCK
+# define HZ CLK_TCK
+# else
+# define HZ 60
+# endif
+#endif
+
#if !defined(STANDARD_C) && !defined(HAS_GETENV_PROTOTYPE) && !defined(PERL_MICRO)
char *getenv (char *); /* Usually in <stdlib.h> */
#endif
#ifndef DOSUID
#define DOSUID
#endif
-#endif
+#endif /* IAMSUID */
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef DOSUID
#endif
#endif
-#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_INTERP(my_perl); \
- INIT_THREADS; \
- ALLOC_THREAD_KEY; \
- PERL_SET_THX(my_perl); \
- OP_REFCNT_INIT; \
- } \
- else { \
- PERL_SET_THX(my_perl); \
- } \
- } STMT_END
-# else
-# define INIT_TLS_AND_INTERP \
- STMT_START { \
- if (!PL_curinterp) { \
- PERL_SET_INTERP(my_perl); \
- } \
- PERL_SET_THX(my_perl); \
- } STMT_END
+static void
+S_init_tls_and_interp(pTHX)
+{
+ if (!PL_curinterp) {
+ PERL_SET_INTERP(my_perl);
+#if defined(USE_ITHREADS)
+ INIT_THREADS;
+ ALLOC_THREAD_KEY;
+ PERL_SET_THX(my_perl);
+ OP_REFCNT_INIT;
+ MUTEX_INIT(&PL_dollarzero_mutex);
# endif
-#endif
+ }
+ else {
+ PERL_SET_THX(my_perl);
+ }
+}
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
PerlInterpreter *my_perl;
/* New() needs interpreter, so call malloc() instead */
my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
- INIT_TLS_AND_INTERP;
+ S_init_tls_and_interp(my_perl);
Zero(my_perl, 1, PerlInterpreter);
PL_Mem = ipM;
PL_MemShared = ipMS;
#else
/*
+=head1 Embedding Functions
+
=for apidoc perl_alloc
Allocates a new Perl interpreter. See L<perlembed>.
perl_alloc(void)
{
PerlInterpreter *my_perl;
+#ifdef USE_5005THREADS
+ dTHX;
+#endif
/* New() 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;
+ S_init_tls_and_interp(my_perl);
+ return 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 */
-
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
if (PL_perl_destruct_level > 0)
init_interp();
#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;
+
+ SvREADONLY_on(&PL_sv_placeholder);
+ SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
}
PL_sighandlerp = Perl_sighandler;
PL_pidstatus = newHV();
-
-#ifdef MSDOS
- /*
- * There is no way we can refer to them from Perl so close them to save
- * space. The other alternative would be to provide STDAUX and STDPRN
- * filehandles.
- */
- (void)PerlIO_close(PerlIO_importFILE(stdaux, 0));
- (void)PerlIO_close(PerlIO_importFILE(stdprn, 0));
-#endif
}
PL_rs = newSVpvn("\n", 1);
init_i18nl10n(1);
SET_NUMERIC_STANDARD();
- {
- U8 *s;
- PL_patchlevel = NEWSV(0,4);
- (void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
- if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
- SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
- s = (U8*)SvPVX(PL_patchlevel);
- /* Build version strings using "native" characters */
- s = uvchr_to_utf8(s, (UV)PERL_REVISION);
- s = uvchr_to_utf8(s, (UV)PERL_VERSION);
- s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION);
- *s = '\0';
- SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel));
- SvPOK_on(PL_patchlevel);
- SvNVX(PL_patchlevel) = (NV)PERL_REVISION
- + ((NV)PERL_VERSION / (NV)1000)
-#if defined(PERL_SUBVERSION) && PERL_SUBVERSION > 0
- + ((NV)PERL_SUBVERSION / (NV)1000000)
-#endif
- ;
- SvNOK_on(PL_patchlevel); /* dual valued */
- SvUTF8_on(PL_patchlevel);
- SvREADONLY_on(PL_patchlevel);
- }
-
#if defined(LOCAL_PATCH_COUNT)
PL_localpatches = local_patches; /* For possible -v */
#endif
PL_fdpid = newAV(); /* for remembering popen pids by fd */
PL_modglobal = newHV(); /* pointers to per-interpreter module globals */
PL_errors = newSVpvn("",0);
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
#ifdef USE_ITHREADS
PL_regex_padav = newAV();
av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */
PL_regex_pad = AvARRAY(PL_regex_padav);
#endif
#ifdef USE_REENTRANT_API
- New(31337, PL_reentrant_buffer,1, REBUF);
- New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+ Perl_reentrant_init(aTHX);
#endif
/* Note that strtab is a rather special HV. Assumptions are made
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);
("__environ", (unsigned long *) &environ_pointer, NULL);
#endif /* environ */
-#ifdef USE_ENVIRON_ARRAY
+#ifndef PERL_MICRO
+# ifdef USE_ENVIRON_ARRAY
PL_origenviron = environ;
+# endif
#endif
+ /* Use sysconf(_SC_CLK_TCK) if available, if not
+ * available or if the sysconf() fails, use the HZ.
+ * BeOS has those, but returns the wrong value. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
+ PL_clocktick = sysconf(_SC_CLK_TCK);
+ if (PL_clocktick <= 0)
+#endif
+ PL_clocktick = HZ;
+
+ PL_stashcache = newHV();
+
+ PL_patchlevel = newSVpv(
+ Perl_form(aTHX_ "%d.%d.%d",
+ (int)PERL_REVISION,
+ (int)PERL_VERSION,
+ (int)PERL_SUBVERSION ), 0
+ );
+
ENTER;
}
/*
+=for apidoc nothreadhook
+
+Stub that provides thread hook for perl_destruct when there are
+no threads.
+
+=cut
+*/
+
+int
+Perl_nothreadhook(pTHX)
+{
+ return 0;
+}
+
+/*
=for apidoc perl_destruct
Shuts down a Perl interpreter. See L<perlembed>.
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
#ifdef USE_5005THREADS
- Thread t;
dTHX;
#endif /* USE_5005THREADS */
/* 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
{
LEAVE;
FREETMPS;
+ /* Need to flush since END blocks can produce output */
+ my_fflush_all();
+
+ if (CALL_FPTR(PL_threadhook)(aTHX)) {
+ /* Threads hook has vetoed further cleanup */
+ return STATUS_NATIVE_EXPORT;
+ }
+
/* We must account for everything. */
/* Destroy the main CV and syntax tree */
if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
+ /* ensure comppad/curpad to refer to main's pad */
+ if (CvPADLIST(PL_main_cv)) {
+ PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+ }
op_free(PL_main_root);
PL_main_root = Nullop;
}
* Non-referenced objects are on their own.
*/
sv_clean_objs();
+ PL_sv_objcount = 0;
}
/* unhook hooks which will soon be, or use, destroyed data */
Safefree(PL_exitlist);
+ PL_exitlist = NULL;
+ PL_exitlistlen = 0;
+
if (destruct_level == 0){
DEBUG_P(debprofdump());
#endif
/* The exit() function will do everything that needs doing. */
- return STATUS_NATIVE_EXPORT;;
+ return STATUS_NATIVE_EXPORT;
}
/* jettison our possibly duplicated environment */
/* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
* so we certainly shouldn't free it here
*/
+#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
+ )
+ {
I32 i;
for (i = 0; environ[i]; i++)
environ = PL_origenviron;
}
#endif
+#endif /* !PERL_MICRO */
+
+ /* reset so print() ends up where we expect */
+ setdefout(Nullgv);
#ifdef USE_ITHREADS
/* the syntax tree is shared between clones
PL_regex_pad = NULL;
#endif
+ SvREFCNT_dec((SV*) PL_stashcache);
+ PL_stashcache = NULL;
+
/* loosen bonds of global variables */
if(PL_rsfp) {
PL_e_script = Nullsv;
}
- while (--PL_origargc >= 0) {
- Safefree(PL_origargv[PL_origargc]);
- }
- Safefree(PL_origargv);
+ PL_perldb = 0;
/* magical thingies */
SvREFCNT_dec(PL_beginav_save);
SvREFCNT_dec(PL_endav);
SvREFCNT_dec(PL_checkav);
+ SvREFCNT_dec(PL_checkav_save);
SvREFCNT_dec(PL_initav);
PL_beginav = Nullav;
PL_beginav_save = Nullav;
PL_endav = Nullav;
PL_checkav = Nullav;
+ PL_checkav_save = Nullav;
PL_initav = Nullav;
/* shortcuts just get cleared */
PL_stderrgv = Nullgv;
PL_last_in_gv = Nullgv;
PL_replgv = Nullgv;
+ PL_DBgv = Nullgv;
+ PL_DBline = Nullgv;
+ PL_DBsub = Nullgv;
+ 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;
Safefree(PL_numeric_name);
PL_numeric_name = Nullch;
SvREFCNT_dec(PL_numeric_radix_sv);
+ PL_numeric_radix_sv = Nullsv;
#endif
/* clear utf8 character classes */
SvREFCNT_dec(PL_utf8_totitle);
SvREFCNT_dec(PL_utf8_tolower);
SvREFCNT_dec(PL_utf8_tofold);
+ SvREFCNT_dec(PL_utf8_idstart);
+ SvREFCNT_dec(PL_utf8_idcont);
PL_utf8_alnum = Nullsv;
PL_utf8_alnumc = Nullsv;
PL_utf8_ascii = Nullsv;
PL_utf8_totitle = Nullsv;
PL_utf8_tolower = Nullsv;
PL_utf8_tofold = Nullsv;
+ PL_utf8_idstart = Nullsv;
+ PL_utf8_idcont = Nullsv;
if (!specialWARN(PL_compiling.cop_warnings))
SvREFCNT_dec(PL_compiling.cop_warnings);
if (!specialCopIO(PL_compiling.cop_io))
SvREFCNT_dec(PL_compiling.cop_io);
PL_compiling.cop_io = Nullsv;
-#ifdef USE_ITHREADS
- Safefree(CopFILE(&PL_compiling));
- CopFILE(&PL_compiling) = Nullch;
- Safefree(CopSTASHPV(&PL_compiling));
-#else
- SvREFCNT_dec(CopFILEGV(&PL_compiling));
- CopFILEGV(&PL_compiling) = Nullgv;
- /* cop_stash is not refcounted */
-#endif
+ CopFILE_free(&PL_compiling);
+ CopSTASH_free(&PL_compiling);
/* Prepare to destruct main symbol table. */
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced scopes: %ld more ENTERs than LEAVEs\n",
(long)PL_scopestack_ix);
if (PL_savestack_ix != 0)
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced saves: %ld more saves than restores\n",
(long)PL_savestack_ix);
if (PL_tmps_floor != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n",
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n",
(long)PL_tmps_floor + 1);
if (cxstack_ix != -1)
- Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n",
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n",
(long)cxstack_ix + 1);
}
hent = array[0];
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Unbalanced string table refcount: (%d) for \"%s\"",
HeVAL(hent) - Nullsv, HeKEY(hent));
HeVAL(hent) = Nullsv;
#ifdef USE_ITHREADS
/* free the pointer table used for cloning */
ptr_table_free(PL_ptr_table);
+ PL_ptr_table = (PTR_TBL_t*)NULL;
#endif
/* free special SVs */
SvANY(&PL_sv_no) = NULL;
SvFLAGS(&PL_sv_no) = 0;
- SvREFCNT(&PL_sv_undef) = 0;
- SvREADONLY_off(&PL_sv_undef);
+ {
+ int i;
+ for (i=0; i<=2; i++) {
+ SvREFCNT(PERL_DEBUG_PAD(i)) = 0;
+ sv_clear(PERL_DEBUG_PAD(i));
+ SvANY(PERL_DEBUG_PAD(i)) = NULL;
+ SvFLAGS(PERL_DEBUG_PAD(i)) = 0;
+ }
+ }
if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count);
+
+#ifdef DEBUG_LEAKING_SCALARS
+ if (PL_sv_count != 0) {
+ SV* sva;
+ SV* sv;
+ register SV* svend;
+
+ for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
+ svend = &sva[SvREFCNT(sva)];
+ for (sv = sva + 1; sv < svend; ++sv) {
+ if (SvTYPE(sv) != SVTYPEMASK) {
+ 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);
+ }
+ }
+ }
+ }
+#endif
+ PL_sv_count = 0;
+
#if defined(PERLIO_LAYERS)
/* No more IO - including error messages ! */
PerlIO_cleanup(aTHX);
#endif
+ /* sv_undef needs to stay immortal until after PerlIO_cleanup
+ as currently layers use it rather than Nullsv as a marker
+ for no arg - and will try and SvREFCNT_dec it.
+ */
+ SvREFCNT(&PL_sv_undef) = 0;
+ SvREADONLY_off(&PL_sv_undef);
+
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_poscache);
- Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh));
+ free_tied_hv_pool();
Safefree(PL_op_mask);
Safefree(PL_psig_ptr);
+ PL_psig_ptr = (SV**)NULL;
Safefree(PL_psig_name);
+ PL_psig_name = (SV**)NULL;
Safefree(PL_bitcount);
+ PL_bitcount = Nullch;
Safefree(PL_psig_pend);
+ PL_psig_pend = (int*)NULL;
+ PL_formfeed = Nullsv;
+ Safefree(PL_ofmt);
+ PL_ofmt = Nullch;
nuke_stacks();
+ PL_tainting = FALSE;
+ PL_taint_warn = FALSE;
PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */
+ 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
- Safefree(PL_reentrant_buffer->tmbuff);
- Safefree(PL_reentrant_buffer);
+ Perl_reentrant_free(aTHX);
#endif
sv_free_arenas();
}
}
/* we know that type >= SVt_PV */
- (void)SvOOK_off(PL_mess_sv);
+ SvOOK_off(PL_mess_sv);
Safefree(SvPVX(PL_mess_sv));
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
# endif
PerlMem_free(aTHXx);
# ifdef NETWARE
- nw5_delete_internal_host(host);
+ nw_delete_internal_host(host);
# else
win32_delete_internal_host(host);
# endif
++PL_exitlistlen;
}
+#ifdef HAS_PROCSELFEXE
+/* This is a function so that we don't hold on to MAXPATHLEN
+ bytes of stack longer than necessary
+ */
+STATIC void
+S_procself_val(pTHX_ SV *sv, char *arg0)
+{
+ char buf[MAXPATHLEN];
+ int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+ /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+ includes a spurious NUL which will cause $^X to fail in system
+ or backticks (this will prevent extensions from being built and
+ many tests from working). readlink is not meant to add a NUL.
+ Normal readlink works fine.
+ */
+ if (len > 0 && buf[len-1] == '\0') {
+ len--;
+ }
+
+ /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
+ returning the text "unknown" from the readlink rather than the path
+ to the executable (or returning an error from the readlink). Any valid
+ path has a '/' in it somewhere, so use that to validate the result.
+ See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703
+ */
+ if (len > 0 && memchr(buf, '/', len)) {
+ sv_setpvn(sv,buf,len);
+ }
+ else {
+ sv_setpv(sv,arg0);
+ }
+}
+#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(GvSV(tmpgv), os2_execname(aTHX));
+#else
+ sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+#endif
+#endif
+ }
+}
+
/*
=for apidoc perl_parse
#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
- PL_origargc = argc;
+#if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT)
+ /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0
+ * This MUST be done before any hash stores or fetches take place.
+ * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set)
+ * yourself, it is your responsibility to provide a good random seed!
+ * You can also define PERL_HASH_SEED in compile time, see hv.h. */
+ if (!PL_rehash_seed_set)
+ PL_rehash_seed = get_hash_seed();
{
- /* we copy rather than point to argv
- * since perl_clone will copy and perl_destruct
- * has no way of knowing if we've made a copy or
- * just point to argv
- */
- int i = PL_origargc;
- New(0, PL_origargv, i+1, char*);
- PL_origargv[i] = '\0';
- while (i-- > 0) {
- PL_origargv[i] = savepv(argv[i]);
- }
+ char *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);
+ }
}
+#endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */
+ PL_origargc = argc;
+ PL_origargv = argv;
+ {
+ /* 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: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;
+ int i;
+ 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 =
+ (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0]));
+
+ /* See if all the arguments are contiguous in memory. Note
+ * that 'contiguous' is a loose term because some platforms
+ * align the argv[] and the envp[]. If the arguments look
+ * like non-aligned, assume that they are 'strictly' or
+ * 'traditionally' contiguous. If the arguments look like
+ * aligned, we just check that they are within aligned
+ * PTRSIZE bytes. As long as no system has something bizarre
+ * like the argv[] interleaved with some other data, we are
+ * fine. (Did I just evoke Murphy's Law?) --jhi */
+ if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) {
+ while (*s) s++;
+ for (i = 1; i < PL_origargc; i++) {
+ if ((PL_origargv[i] == s + 1
+#ifdef OS2
+ || PL_origargv[i] == s + 2
+#endif
+ )
+ ||
+ (aligned &&
+ (PL_origargv[i] > s &&
+ PL_origargv[i] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
+ )
+ {
+ s = PL_origargv[i];
+ while (*s) s++;
+ }
+ else
+ break;
+ }
+ }
+ /* Can we grab env area too to be used as the area for $0? */
+ if (PL_origenviron) {
+ if ((PL_origenviron[0] == s + 1
+#ifdef OS2
+ || (PL_origenviron[0] == s + 9 && (s += 8))
+#endif
+ )
+ ||
+ (aligned &&
+ (PL_origenviron[0] > s &&
+ PL_origenviron[0] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
+ )
+ {
+#ifndef OS2
+ s = PL_origenviron[0];
+ while (*s) s++;
+#endif
+ my_setenv("NoNe SuCh", Nullch);
+ /* Force copy of environment. */
+ for (i = 1; PL_origenviron[i]; i++) {
+ if (PL_origenviron[i] == s + 1
+ ||
+ (aligned &&
+ (PL_origenviron[i] > s &&
+ PL_origenviron[i] <=
+ INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask)))
+ )
+ {
+ s = PL_origenviron[i];
+ while (*s) s++;
+ }
+ else
+ break;
+ }
+ }
+ }
+ PL_origalen = s - PL_origargv[0] + 1;
+ }
if (PL_do_undump) {
PL_do_undump = FALSE;
cxstack_ix = -1; /* start label stack again */
init_ids();
+ assert (!PL_tainted);
+ TAINT;
+ S_set_caret_X(aTHX);
+ TAINT_NOT;
init_postdump_symbols(argc,argv,env);
return 0;
}
if (PL_main_root) {
- PL_curpad = AvARRAY(PL_comppad);
op_free(PL_main_root);
PL_main_root = Nullop;
}
int argc = PL_origargc;
char **argv = PL_origargv;
char *scriptname = NULL;
- int fdscript = -1;
VOL bool dosearch = FALSE;
char *validarg = "";
- AV* comppadlist;
register SV *sv;
register char *s;
char *cddir = Nullch;
+ 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:
switch (*s) {
case 'C':
-#ifdef WIN32
- win32_argv2utf8(argc-1, argv+1);
- /* FALL THROUGH */
-#endif
#ifndef PERL_STRICT_CR
case '\r':
#endif
case 'W':
case 'X':
case 'w':
+ case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
+ case 't':
+ CHECK_MALLOC_TOO_LATE_FOR('t');
+ if( !PL_tainting ) {
+ PL_taint_warn = TRUE;
+ PL_tainting = TRUE;
+ }
+ s++;
+ goto reswitch;
case 'T':
+ CHECK_MALLOC_TOO_LATE_FOR('T');
PL_tainting = TRUE;
+ PL_taint_warn = FALSE;
s++;
goto reswitch;
#ifdef MACOS_TRADITIONAL
/* ignore -e for Dev:Pseudo argument */
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
- break;
+ 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);
char *p;
STRLEN len = strlen(s);
p = savepvn(s, len);
- incpush(p, TRUE, TRUE);
+ incpush(p, TRUE, TRUE, FALSE, FALSE);
sv_catpvn(sv, "-I", 2);
sv_catpvn(sv, p, len);
sv_catpvn(sv, " ", 1);
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]);
+ Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
+ 0, PL_localpatches[i], 0);
}
}
#endif
char *popt = s;
while (isSPACE(*s))
s++;
- if (*s == '-' && *(s+1) == 'T')
+ if (*s == '-' && *(s+1) == 'T') {
+ CHECK_MALLOC_TOO_LATE_FOR('T');
PL_tainting = TRUE;
+ PL_taint_warn = FALSE;
+ }
else {
char *popt_copy = Nullch;
while (s && *s) {
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmw", *s))
+ if (!strchr("DIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
break;
}
}
- moreswitches(d);
+ if (*d == 't') {
+ if( !PL_tainting ) {
+ PL_taint_warn = TRUE;
+ PL_tainting = TRUE;
+ }
+ } else {
+ moreswitches(d);
+ }
}
}
}
+ if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
+ PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+ }
+
if (!scriptname)
scriptname = argv[0];
if (PL_e_script) {
scriptname = "-";
}
+ /* Set $^X early so that it can be used for relocatable paths in @INC */
+ assert (!PL_tainted);
+ TAINT;
+ S_set_caret_X(aTHX);
+ TAINT_NOT;
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)
Sighandler_t sigstate = rsignal_state(SIGCHLD);
if (sigstate == SIG_IGN) {
if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ WARN_SIGNAL,
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
"Can't ignore signal CHLD, forcing to default");
(void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
}
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvUNIQUE_on(PL_compcv);
- PL_comppad = newAV();
- av_push(PL_comppad, Nullsv);
- PL_curpad = AvARRAY(PL_comppad);
- PL_comppad_name = newAV();
- PL_comppad_name_fill = 0;
- PL_min_intro_pending = 0;
- PL_padix = 0;
+ CvPADLIST(PL_compcv) = pad_new(0);
#ifdef USE_5005THREADS
- av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
- PL_curpad[0] = (SV*)newAV();
- SvPADMY_on(PL_curpad[0]); /* XXX Needed? */
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(PL_compcv));
#endif /* USE_5005THREADS */
- comppadlist = newAV();
- AvREAL_off(comppadlist);
- av_store(comppadlist, 0, (SV*)PL_comppad_name);
- av_store(comppadlist, 1, (SV*)PL_comppad);
- CvPADLIST(PL_compcv) = comppadlist;
-
boot_core_PerlIO();
boot_core_UNIVERSAL();
-#ifndef PERL_MICRO
boot_core_xsutils();
-#endif
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
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
+ * locale.c:Perl_init_i18nl10n() if the environment
+ * look like the user wants to use UTF-8. */
+ if (PL_unicode) {
+ /* Requires init_predump_symbols(). */
+ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
+ IO* io;
+ PerlIO* fp;
+ SV* sv;
+
+ /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
+ * and the default open disciplines. */
+ if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) &&
+ PL_stdingv && (io = GvIO(PL_stdingv)) &&
+ (fp = IoIFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) &&
+ PL_defoutgv && (io = GvIO(PL_defoutgv)) &&
+ (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) &&
+ PL_stderrgv && (io = GvIO(PL_stderrgv)) &&
+ (fp = IoOFP(io)))
+ PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
+ if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) &&
+ (sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
+ U32 in = PL_unicode & PERL_UNICODE_IN_FLAG;
+ U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG;
+ if (in) {
+ if (out)
+ sv_setpvn(sv, ":utf8\0:utf8", 11);
+ else
+ sv_setpvn(sv, ":utf8\0", 6);
+ }
+ else if (out)
+ sv_setpvn(sv, "\0:utf8", 6);
+ SvSETMAGIC(sv);
+ }
+ }
+ }
+
+ if ((s = PerlEnv_getenv("PERL_SIGNALS"))) {
+ if (strEQ(s, "unsafe"))
+ PL_signals |= PERL_SIGNALS_UNSAFE_FLAG;
+ else if (strEQ(s, "safe"))
+ PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG;
+ else
+ Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s);
+ }
+
init_lexer();
/* now parse the script */
- SETERRNO(0,SS$_NORMAL);
+ SETERRNO(0,SS_NORMAL);
PL_error_count = 0;
#ifdef MACOS_TRADITIONAL
if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
PL_e_script = Nullsv;
}
-/*
- Not sure that this is still the right place to do this now that we
- no longer use PL_nrs. HVDS 2001/09/09
-*/
- sv_setsv(get_sv("/", TRUE), PL_rs);
-
if (PL_do_undump)
my_unexec();
if (!PL_restartop) {
DEBUG_x(dump_all());
- DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+ if (!DEBUG_q_TEST)
+ PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
PTR2UV(thr)));
if (PL_minus_c) {
#ifdef MACOS_TRADITIONAL
- PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
+ PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
+ (gMacPerl_ErrorFormat ? "# " : ""),
+ MacPerl_MPWFileName(PL_origfilename));
#else
PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
#endif
}
/*
+=head1 SV Manipulation Functions
+
=for apidoc p||get_sv
Returns the SV of the specified Perl scalar. If C<create> is set and the
}
/*
+=head1 Array Manipulation Functions
+
=for apidoc p||get_av
Returns the AV of the specified Perl array. If C<create> is set and the
}
/*
+=head1 Hash Manipulation Functions
+
=for apidoc p||get_hv
Returns the HV of the specified Perl hash. If C<create> is set and the
}
/*
+=head1 CV Manipulation Functions
+
=for apidoc p||get_cv
Returns the CV of the specified Perl subroutine. If C<create> is set and
/* Be sure to refetch the stack pointer after calling these routines. */
/*
+
+=head1 Callback Functions
+
=for apidoc p||call_argv
Performs a callback to the specified Perl sub. See L<perlcall>.
ENTER;
SAVETMPS;
- push_return(Nullop);
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
PUSHEVAL(cx, 0, 0);
PL_eval_root = PL_op; /* Only needed so that goto works right. */
POPBLOCK(cx,newpm);
POPEVAL(cx);
- pop_return();
PL_curpm = newpm;
LEAVE;
}
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) {
/* Require a module. */
/*
+=head1 Embedding Functions
+
=for apidoc p||require_pv
Tells Perl to C<require> the file named by the string argument. It is
analogous to the Perl code C<eval "require '$file'">. It's even
-implemented that way; consider using Perl_load_module instead.
+implemented that way; consider using load_module instead.
=cut */
static char *usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
"-a autosplit mode with -n or -p (splits $_ into @F)",
-"-C enable native wide character system interfaces",
+"-C[number/list] enables the listed Unicode features",
"-c check syntax only (runs BEGIN and CHECK blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
-"-e 'command' one line of program (several -e's allowed, omit programfile)",
+"-e program one line of program (several -e's allowed, omit programfile)",
"-F/pattern/ split() pattern for -a switch (//'s are optional)",
"-i[extension] edit <> files in place (makes backup if extension supplied)",
"-Idirectory specify @INC/#include directory (several -I's allowed)",
"-P run program through C preprocessor before compilation",
"-s enable rudimentary parsing for switches after programfile",
"-S look for programfile using PATH environment variable",
+"-t enable tainting warnings",
"-T enable tainting checks",
"-u dump core after parsing program",
"-U allow unsafe operations",
"-V[:variable] print configuration summary (or a single Config.pm variable)",
"-w enable many useful warnings (RECOMMENDED)",
"-W enable all warnings",
-"-X disable all warnings",
"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"-X disable all warnings",
"\n",
NULL
};
PerlIO_printf(PerlIO_stdout(), "\n %s", *p++);
}
+/* convert a string of -D options (or digits) into an int.
+ * sets *s to point to the char after the options */
+
+#ifdef DEBUGGING
+int
+Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
+{
+ static char *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 HXDSTRJvCAq";
+
+ for (; isALNUM(**s); (*s)++) {
+ 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, use -D'' to see choices\n", **s);
+ }
+ }
+ else if (isDIGIT(**s)) {
+ i = atoi(*s);
+ for (; isALNUM(**s); (*s)++) ;
+ }
+ else if (givehelp) {
+ char **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),
+ "-Dp not implemented on this platform\n");
+# endif
+ return i;
+}
+#endif
+
/* This routine handles any switches that can be given during run */
char *
Perl_moreswitches(pTHX_ char *s)
{
STRLEN numlen;
- U32 rschar;
+ UV rschar;
switch (*s) {
case '0':
{
- I32 flags = 0;
- numlen = 4;
- rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
- SvREFCNT_dec(PL_rs);
- if (rschar & ~((U8)~0))
- PL_rs = &PL_sv_undef;
- else if (!rschar && numlen >= 2)
- PL_rs = newSVpvn("", 0);
- else {
- char ch = rschar;
- PL_rs = newSVpvn(&ch, 1);
- }
- return s + numlen;
+ I32 flags = 0;
+
+ SvREFCNT_dec(PL_rs);
+ if (s[1] == 'x' && s[2]) {
+ char *e;
+ U8 *tmps;
+
+ for (s += 2, e = s; *e; e++);
+ numlen = e - s;
+ flags = PERL_SCAN_SILENT_ILLDIGIT;
+ rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
+ if (s + numlen < e) {
+ rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */
+ numlen = 0;
+ s--;
+ }
+ PL_rs = newSVpvn("", 0);
+ SvGROW(PL_rs, (STRLEN)(UNISKIP(rschar) + 1));
+ tmps = (U8*)SvPVX(PL_rs);
+ uvchr_to_utf8(tmps, rschar);
+ SvCUR_set(PL_rs, UNISKIP(rschar));
+ SvUTF8_on(PL_rs);
+ }
+ else {
+ numlen = 4;
+ rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
+ if (rschar & ~((U8)~0))
+ PL_rs = &PL_sv_undef;
+ else if (!rschar && numlen >= 2)
+ PL_rs = newSVpvn("", 0);
+ else {
+ char ch = (char)rschar;
+ PL_rs = newSVpvn(&ch, 1);
+ }
+ }
+ sv_setsv(get_sv("/", TRUE), PL_rs);
+ return s + numlen;
}
case 'C':
- PL_widesyscalls = TRUE;
- s++;
+ s++;
+ PL_unicode = parse_unicode_opts(&s);
return s;
case 'F':
PL_minus_F = TRUE;
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 == '=') {
sv_catpvn(sv, start, s-start);
sv_catpv(sv, " split(/,/,q{");
sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
+ sv_catpv(sv, "})");
}
s += strlen(s);
my_setenv("PERL5DB", SvPV(sv, PL_na));
{
#ifdef DEBUGGING
forbid_setid("-D");
- if (isALPHA(s[1])) {
- /* if adding extra options, remember to update DEBUG_MASK */
- static char debopts[] = "psltocPmfrxuLHXDSTR";
- char *d;
-
- for (s++; *s && (d = strchr(debopts,*s)); s++)
- PL_debug |= 1 << (d - debopts);
- }
- else {
- PL_debug = atoi(s+1);
- for (s++; isDIGIT(*s); s++) ;
- }
- PL_debug |= DEBUG_TOP_FLAG;
-#else
+ s++;
+ PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
+#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING,
- "Recompile perl with -DDEBUGGING to use -D switch\n");
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+ "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
for (s++; isALNUM(*s); s++) ;
#endif
/*SUPPRESS 530*/
}
case 'h':
usage(PL_origargv[0]);
- PerlProc_exit(0);
+ my_exit(0);
case 'i':
if (PL_inplace)
Safefree(PL_inplace);
+#if defined(__CYGWIN__) /* do backup extension automagically */
+ if (*(s+1) == '\0') {
+ PL_inplace = savepv(".bak");
+ return s+1;
+ }
+#endif /* __CYGWIN__ */
PL_inplace = savepv(s+1);
/*SUPPRESS 530*/
for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE, TRUE);
+ incpush(e, TRUE, TRUE, FALSE, FALSE);
Safefree(e);
s = p;
if (*s == '-')
}
}
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 */
Perl_croak(aTHX_ "Module name required with -%c option",
s[-1]);
sv_catpvn(sv, start, s-start);
- sv_catpv(sv, " split(/,/,q{");
+ sv_catpv(sv, " split(/,/,q");
+ sv_catpvn(sv, "\0)", 1); /* Use NUL as q//-delimiter. */
sv_catpv(sv, ++s);
- sv_catpv(sv, "})");
+ sv_catpvn(sv, "\0)", 2);
}
s += strlen(s);
if (!PL_preambleav)
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;
PL_doswitches = TRUE;
s++;
return s;
+ case 't':
+ if (!PL_tainting)
+ TOO_LATE_FOR('t');
+ s++;
+ return s;
case 'T':
if (!PL_tainting)
- Perl_croak(aTHX_ "Too late for \"-T\" option");
+ TOO_LATE_FOR('T');
s++;
return s;
case 'u':
s++;
return s;
case 'v':
+ if (!sv_derived_from(PL_patchlevel, "version"))
+ (void *)upg_version(PL_patchlevel);
#if !defined(DGUX)
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s",
- PL_patchlevel, ARCHNAME));
+ Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
+ vstringify(PL_patchlevel),
+ ARCHNAME));
#else /* DGUX */
/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
PerlIO_printf(PerlIO_stdout(),
- Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel));
+ Perl_form(aTHX_ "\nThis is perl, v%_\n",
+ vstringify(PL_patchlevel)));
PerlIO_printf(PerlIO_stdout(),
Perl_form(aTHX_ " built under %s at %s %s\n",
OSNAME, __DATE__, __TIME__));
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2001, Larry Wall\n");
+ "\n\nCopyright 1987-2004, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
- "\nMac OS port Copyright 1991-2001, Matthias Neeracher;\n"
+ "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
"maintained by Chris Nandor\n");
#endif
#ifdef MSDOS
#ifdef OS2
PerlIO_printf(PerlIO_stdout(),
"\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
- "Version 5 port Copyright (c) 1994-1999, Andreas Kaiser, Ilya Zakharevich\n");
+ "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n");
#endif
#ifdef atarist
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef MPE
PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n");
+ "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
#endif
#ifdef OEMVS
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef __VOS__
PerlIO_printf(PerlIO_stdout(),
- "Stratus VOS port by Paul_Green@stratus.com, 1997-1999\n");
+ "Stratus VOS port by Paul.Green@stratus.com, 1997-2002\n");
#endif
#ifdef __OPEN_VM
PerlIO_printf(PerlIO_stdout(),
#endif
#ifdef EPOC
PerlIO_printf(PerlIO_stdout(),
- "EPOC port by Olaf Flebbe, 1999-2000\n");
+ "EPOC port by Olaf Flebbe, 1999-2002\n");
#endif
#ifdef UNDER_CE
- printf("WINCE port by Rainer Keuchel, 2001\n");
- printf("Built on " __DATE__ " " __TIME__ "\n\n");
+ PerlIO_printf(PerlIO_stdout(),"WINCE port by Rainer Keuchel, 2001-2002\n");
+ PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
#ifdef BINARY_BUILD_NOTICE
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");
- PerlProc_exit(0);
+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))
PL_dowarn |= G_WARN_ON;
return s;
case 'W':
PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_ALL ;
s++;
return s;
case 'X':
PL_dowarn = G_WARN_ALL_OFF;
+ if (!specialWARN(PL_compiling.cop_warnings))
+ SvREFCNT_dec(PL_compiling.cop_warnings);
PL_compiling.cop_warnings = pWARN_NONE ;
s++;
return s;
{
GV *gv;
-
-
PL_curstash = PL_defstash = newHV();
PL_curstname = newSVpvn("main",4);
gv = gv_fetchpv("main::",TRUE, SVt_PVHV);
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_ char *scriptname, bool dosearch, SV *sv)
{
- *fdscript = -1;
+#ifndef IAMSUID
+ char *quote;
+ char *code;
+ char *cpp_discard_flag;
+ char *perl;
+#endif
+
+ PL_fdscript = -1;
+ PL_suidscript = -1;
if (PL_e_script) {
PL_origfilename = savepv("-e");
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
char *s = scriptname + 8;
- *fdscript = atoi(s);
+ 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;
}
}
-#ifdef USE_ITHREADS
- Safefree(CopFILE(PL_curcop));
-#else
- SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+ CopFILE_free(PL_curcop);
CopFILE_set(PL_curcop, PL_origfilename);
- if (strEQ(PL_origfilename,"-"))
+ if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = "";
- if (*fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- if (PL_rsfp)
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
-#endif
+ 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;
SV *cpp = newSVpvn("",0);
SV *cmd = NEWSV(0,0);
+ if (cpp_cfg[0] == 0) /* PERL_MICRO? */
+ Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined");
if (strEQ(cpp_cfg, "cppstdin"))
Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
sv_catpv(cpp, cpp_cfg);
- sv_catpvn(sv, "-I", 2);
- sv_catpv(sv,PRIVLIB_EXP);
+# ifndef VMS
+ sv_catpvn(sv, "-I", 2);
+ sv_catpv(sv,PRIVLIB_EXP);
+# endif
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
-#if defined(MSDOS) || defined(WIN32)
- Perl_sv_setpvf(aTHX_ cmd, "\
-sed %s -e \"/^[^#]/b\" \
- -e \"/^#[ ]*include[ ]/b\" \
- -e \"/^#[ ]*define[ ]/b\" \
- -e \"/^#[ ]*if[ ]/b\" \
- -e \"/^#[ ]*ifdef[ ]/b\" \
- -e \"/^#[ ]*ifndef[ ]/b\" \
- -e \"/^#[ ]*else/b\" \
- -e \"/^#[ ]*elif[ ]/b\" \
- -e \"/^#[ ]*undef[ ]/b\" \
- -e \"/^#[ ]*endif/b\" \
- -e \"s/^#.*//\" \
- %s | %"SVf" -C %"SVf" %s",
- (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
-#else
-# ifdef __OPEN_VM
- Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ ]*include[ ]/b' \
- -e '/^#[ ]*define[ ]/b' \
- -e '/^#[ ]*if[ ]/b' \
- -e '/^#[ ]*ifdef[ ]/b' \
- -e '/^#[ ]*ifndef[ ]/b' \
- -e '/^#[ ]*else/b' \
- -e '/^#[ ]*elif[ ]/b' \
- -e '/^#[ ]*undef[ ]/b' \
- -e '/^#[ ]*endif/b' \
- -e 's/^[ ]*#.*//' \
- %s | %"SVf" %"SVf" %s",
-# else
- Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ ]*include[ ]/b' \
- -e '/^#[ ]*define[ ]/b' \
- -e '/^#[ ]*if[ ]/b' \
- -e '/^#[ ]*ifdef[ ]/b' \
- -e '/^#[ ]*ifndef[ ]/b' \
- -e '/^#[ ]*else/b' \
- -e '/^#[ ]*elif[ ]/b' \
- -e '/^#[ ]*undef[ ]/b' \
- -e '/^#[ ]*endif/b' \
- -e 's/^[ ]*#.*//' \
- %s | %"SVf" -C %"SVf" %s",
-# endif
-#ifdef LOC_SED
- LOC_SED,
-#else
- "sed",
-#endif
- (PL_doextract ? "-e '1,/^#/d\n'" : ""),
-#endif
- scriptname, cpp, sv, CPPMINUS);
+
+# if defined(MSDOS) || defined(WIN32) || defined(VMS)
+ quote = "\"";
+# else
+ quote = "'";
+# endif
+
+# ifdef VMS
+ cpp_discard_flag = "";
+# else
+ cpp_discard_flag = "-C";
+# endif
+
+# ifdef OS2
+ perl = os2_execname(aTHX);
+# else
+ perl = PL_origargv[0];
+# endif
+
+
+ /* This strips off Perl comments which might interfere with
+ the C pre-processor, including #!. #line directives are
+ deliberately stripped to avoid confusion with Perl's version
+ of #line. FWP played some golf with it so it will fit
+ into VMS's 255 character buffer.
+ */
+ if( PL_doextract )
+ code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
+ else
+ code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
+
+ Perl_sv_setpvf(aTHX_ cmd, "\
+%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
+ perl, quote, code, quote, scriptname, cpp,
+ 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",
}
else {
PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
- if (PL_rsfp)
- fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1); /* ensure close-on-exec */
-#endif
+# if defined(HAS_FCNTL) && defined(F_SETFD)
+ if (PL_rsfp)
+ /* ensure close-on-exec */
+ 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 */
- 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_croak(aTHX_ "Can't do setuid\n");
- }
-#endif
-#endif
-#ifdef IAMSUID
- errno = EPERM;
- Perl_croak(aTHX_ "Can't open perl script: %s\n",
- Strerror(errno));
-#else
+ /* PSz 16 Sep 03 Keep neat error message */
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
-#endif
+ 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) && \
defined(HAS_STRUCT_FS_DATA) && \
defined(NOSTAT_ONE)
# define FD_ON_NOSUID_CHECK_OKAY
- struct stat fdst;
+ Stat_t fdst;
if (fstat(fd, &fdst) == 0) {
struct ustat us;
fdst.st_dev == fsd.fd_req.dev) {
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;
- struct stat stb, fsb;
+ Stat_t stb, fsb;
if (mtab && (fstat(fd, &stb) == 0)) {
while (entry = getmntent(mtab)) {
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_ char *validarg, 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
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;
#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*/
- Perl_croak(aTHX_ "Permission denied");
-#else
+ if (PerlLIO_access(CopFILE(PL_curcop),1)) { /*double check*/
+ Perl_croak(aTHX_ "Can't access() script\n");
+ }
+
/* 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.
*/
{
- struct stat 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)
- Perl_croak(aTHX_ "Permission denied"); /* testing full pathname here */
-#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
- if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
- Perl_croak(aTHX_ "Permission denied");
-#endif
- if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
+ Stat_t tmpstatbuf;
+ 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);
- 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))
- Perl_croak(aTHX_ "Permission denied");
+ if (!S_ISREG(PL_statbuf.st_mode)) {
+ 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 */
Perl_croak(aTHX_ "No #! line");
s = SvPV(PL_linestr,n_a)+2;
- if (*s == ' ') s++;
- while (!isSPACE(*s)) s++;
+ /* 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 > 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 */
+ (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
+ || s2[-1] == '-')); s2--) ;
+ /* Sanity check on buffer start */
+ if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
+ (s-9 < SvPV(PL_linestr,n_a)+2 || 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, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\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);
-#endif
- Perl_croak(aTHX_ "Can't do setuid\n");
+ PERL_FPU_POST_EXEC
+#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
+ 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 {
+/* 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])
- Perl_croak(aTHX_ "Permission denied");
- 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
+ PERL_FPU_PRE_EXEC
PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
(int)PERL_REVISION, (int)PERL_VERSION,
(int)PERL_SUBVERSION), PL_origargv);/* try again */
- Perl_croak(aTHX_ "Can't do setuid\n");
+ PERL_FPU_POST_EXEC
+ 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) */
S_find_beginning(pTHX)
{
register char *s, *s2;
+#ifdef MACOS_TRADITIONAL
+ int maclines = 0;
+#endif
/* skip forward in input to the real script? */
if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
if (!gMacPerl_AlwaysExtract)
Perl_croak(aTHX_ "No Perl script found in input\n");
-
+
if (PL_doextract) /* require explicit override ? */
if (!OverrideExtract(PL_origfilename))
Perl_croak(aTHX_ "User aborted script\n");
else
PL_doextract = FALSE;
-
+
/* Pater peccavi, file does not have #! */
PerlIO_rewind(PL_rsfp);
-
+
break;
}
#else
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)))
;
}
#ifdef MACOS_TRADITIONAL
+ /* We are always searching for the #!perl line in MacPerl,
+ * so if we find it, still keep the line count correct
+ * by counting lines we already skipped over
+ */
+ for (; maclines > 0 ; maclines--)
+ PerlIO_ungetc(PL_rsfp, '\n');
+
break;
+
+ /* gMacPerl_AlwaysExtract is false in MPW tool */
+ } else if (gMacPerl_AlwaysExtract) {
+ ++maclines;
#endif
}
}
PL_uid |= PL_gid << 16;
PL_euid |= PL_egid << 16;
#endif
+ /* 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,
+ * before even the options are parsed, so PL_tainting has
+ * not been initialized properly. */
+bool
+Perl_doing_taint(int argc, char *argv[], char *envp[])
+{
+#ifndef PERL_IMPLICIT_SYS
+ /* If we have PERL_IMPLICIT_SYS we can't call getuid() et alia
+ * before we have an interpreter-- and the whole point of this
+ * function is to be called at such an early stage. If you are on
+ * a system with PERL_IMPLICIT_SYS but you do have a concept of
+ * "tainted because running with altered effective ids', you'll
+ * have to add your own checks somewhere in here. The two most
+ * known samples of 'implicitness' are Win32 and NetWare, neither
+ * of which has much of concept of 'uids'. */
+ int uid = PerlProc_getuid();
+ int euid = PerlProc_geteuid();
+ int gid = PerlProc_getgid();
+ int egid = PerlProc_getegid();
+
+#ifdef VMS
+ uid |= gid << 16;
+ euid |= egid << 16;
+#endif
+ if (uid && (euid != uid || egid != gid))
+ return 1;
+#endif /* !PERL_IMPLICIT_SYS */
+ /* This is a really primitive check; environment gets ignored only
+ * if -T are the first chars together; otherwise one gets
+ * "Too late" message. */
+ if ( argc > 1 && argv[1][0] == '-'
+ && (argv[1][1] == 't' || argv[1][1] == 'T') )
+ return 1;
+ return 0;
}
STATIC void
S_forbid_setid(pTHX_ 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
HV *ostash = PL_curstash;
PL_curstash = PL_debstash;
- PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV))));
+ PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV))));
AvREAL_off(PL_dbargs);
- PL_DBgv = gv_fetchpv("DB", GV_ADDMULTI, SVt_PVGV);
- PL_DBline = gv_fetchpv("dbline", GV_ADDMULTI, SVt_PVAV);
- PL_DBsub = gv_HVadd(gv_fetchpv("sub", GV_ADDMULTI, SVt_PVHV));
+ 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("single", GV_ADDMULTI, SVt_PV)));
+ PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
- PL_DBtrace = GvSV((gv_fetchpv("trace", GV_ADDMULTI, SVt_PV)));
+ PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBtrace, 0);
- PL_DBsignal = GvSV((gv_fetchpv("signal", GV_ADDMULTI, SVt_PV)));
+ 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;
}
New(54,PL_savestack,REASONABLE(128),ANY);
PL_savestack_ix = 0;
PL_savestack_max = REASONABLE(128);
-
- New(54,PL_retstack,REASONABLE(16),OP*);
- PL_retstack_ix = 0;
- PL_retstack_max = REASONABLE(16);
}
#undef REASONABLE
Safefree(PL_markstack);
Safefree(PL_scopestack);
Safefree(PL_savestack);
- Safefree(PL_retstack);
}
STATIC void
for (; argc > 0; argc--,argv++) {
SV *sv = newSVpv(argv[0],0);
av_push(GvAVn(PL_argvgv),sv);
- if (PL_widesyscalls)
- (void)sv_utf8_decode(sv);
+ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
+ if (PL_unicode & PERL_UNICODE_ARGV_FLAG)
+ SvUTF8_on(sv);
+ }
+ if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */
+ (void)sv_utf8_decode(sv);
}
}
}
-#ifdef HAS_PROCSELFEXE
-/* This is a function so that we don't hold on to MAXPATHLEN
- bytes of stack longer than necessary
- */
-STATIC void
-S_procself_val(pTHX_ SV *sv, char *arg0)
-{
- char buf[MAXPATHLEN];
- int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
- if (len > 0) {
- sv_setpvn(sv,buf,len);
- }
- else {
- sv_setpv(sv,arg0);
- }
-}
-#endif /* HAS_PROCSELFEXE */
-
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
char *s;
SV *sv;
GV* tmpgv;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- char **dup_env_base = 0;
- int dup_env_count = 0;
-#endif
PL_toptarget = NEWSV(0,0);
sv_upgrade(PL_toptarget, SVt_PVFM);
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
- }
if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
HV *hv;
GvMULTI_on(PL_envgv);
hv = GvHVn(PL_envgv);
hv_magic(hv, Nullgv, PERL_MAGIC_env);
+#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
/* Note that if the supplied env parameter is actually a copy
of the global environ then it may now point to free'd memory
*/
if (!env)
env = environ;
- if (env != environ)
- environ[0] = Nullch;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
+ if (env != environ
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
{
- char **env_base;
- for (env_base = env; *env; env++)
- dup_env_count++;
- if ((dup_env_base = (char **)
- safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
- char **dup_env;
- for (env = env_base, dup_env = dup_env_base;
- *env;
- env++, dup_env++) {
- /* With environ one needs to use safesysmalloc(). */
- *dup_env = safesysmalloc(strlen(*env) + 1);
- (void)strcpy(*dup_env, *env);
- }
- *dup_env = Nullch;
- env = dup_env_base;
- } /* else what? */
+ environ[0] = Nullch;
}
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
- if (env)
+ if (env) {
+ char** origenv = environ;
for (; *env; env++) {
- if (!(s = strchr(*env,'=')))
+ if (!(s = strchr(*env,'=')) || s == *env)
continue;
- *s++ = '\0';
-#if defined(MSDOS)
+#if defined(MSDOS) && !defined(DJGPP)
+ *s = '\0';
(void)strupr(*env);
+ *s = '=';
#endif
- sv = newSVpv(s--,0);
+ sv = newSVpv(s+1, 0);
(void)hv_store(hv, *env, s - *env, sv, 0);
- *s = '=';
+ if (env != environ)
+ mg_set(sv);
+ if (origenv != environ) {
+ /* realloc has shifted us */
+ env = (env - origenv) + environ;
+ origenv = environ;
+ }
}
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
- if (dup_env_base) {
- char **dup_env;
- for (dup_env = dup_env_base; *dup_env; dup_env++)
- safesysfree(*dup_env);
- safesysfree(dup_env_base);
- }
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
+ }
#endif /* USE_ENVIRON_ARRAY */
+#endif /* !PERL_MICRO */
}
TAINT_NOT;
if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
SvREADONLY_on(GvSV(tmpgv));
}
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = (IV)getppid();
+#endif
+
+ /* touch @F array to prevent spurious warnings 20020415 MJD */
+ if (PL_minus_a) {
+ (void) get_av("main::F", TRUE | GV_ADDMULTI);
+ }
+ /* touch @- and @+ arrays to prevent spurious warnings 20020415 MJD */
+ (void) get_av("main::-", TRUE | GV_ADDMULTI);
+ (void) get_av("main::+", TRUE | GV_ADDMULTI);
}
STATIC void
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
if (s)
- incpush(s, TRUE, TRUE);
+ incpush(s, TRUE, TRUE, TRUE, FALSE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
#else /* VMS */
/* Treat PERL5?LIB as a possible search list logical name -- the
* "natural" VMS idiom for a Unix path string. We allow each
char buf[256];
int idx = 0;
if (my_trnlnm("PERL5LIB",buf,0))
- do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
#endif
#ifdef MACOS_TRADITIONAL
{
- struct stat tmpstatbuf;
+ Stat_t tmpstatbuf;
SV * privdir = NEWSV(55, 0);
char * macperl = PerlEnv_getenv("MACPERL");
Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
SvREFCNT_dec(privdir);
}
if (!PL_tainting)
- incpush(":", FALSE, FALSE);
+ incpush(":", FALSE, FALSE, TRUE, FALSE);
#else
#ifndef PRIVLIB_EXP
# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
#endif
#if defined(WIN32)
- incpush(PRIVLIB_EXP, TRUE, FALSE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
#endif
#ifdef SITEARCH_EXP
/* sitearch is always relative to sitelib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush(SITEARCH_EXP, FALSE, FALSE);
+ incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef SITELIB_EXP
# if defined(WIN32)
- incpush(SITELIB_EXP, TRUE, FALSE); /* this picks up sitearch as well */
+ /* this picks up sitearch as well */
+ incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
# else
- incpush(SITELIB_EXP, FALSE, FALSE);
+ incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
- incpush(SITELIB_STEM, FALSE, TRUE);
+ incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
#endif
#ifdef PERL_VENDORARCH_EXP
/* vendorarch is always relative to vendorlib on Windows for
* DLL-based path intuition to work correctly */
# if !defined(WIN32)
- incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE, FALSE); /* this picks up vendorarch as well */
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
# else
- incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
# endif
#endif
#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
- incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
#endif
#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
#endif
if (!PL_tainting)
- incpush(".", FALSE, FALSE);
+ incpush(".", FALSE, FALSE, TRUE, FALSE);
#endif /* MACOS_TRADITIONAL */
}
# 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(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)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep,
+ int canrelocate)
{
SV *subdir = Nullsv;
return;
if (addsubdirs || addoldvers) {
- subdir = sv_newmortal();
+ subdir = NEWSV(0,0);
}
/* Break at all separators */
char *s;
/* skip any consecutive separators */
- while ( *p == PERLLIB_SEP ) {
- /* Uncomment the next line for PATH semantics */
- /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
- p++;
+ if (usesep) {
+ while ( *p == PERLLIB_SEP ) {
+ /* Uncomment the next line for PATH semantics */
+ /* av_push(GvAVn(PL_incgv), newSVpvn(".", 1)); */
+ p++;
+ }
}
- if ( (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
+ if ( usesep && (s = strchr(p, PERLLIB_SEP)) != Nullch ) {
sv_setpvn(libdir, PERLLIB_MANGLE(p, (STRLEN)(s - p)),
(STRLEN)(s - p));
p = s + 1;
p = Nullch; /* break out */
}
#ifdef MACOS_TRADITIONAL
- if (!strchr(SvPVX(libdir), ':'))
- sv_insert(libdir, 0, 0, ":", 1);
+ if (!strchr(SvPVX(libdir), ':')) {
+ char buf[256];
+
+ sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
+ }
if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
sv_catpv(libdir, ":");
#endif
+#ifdef PERL_RELOCATABLE_INC
+ /*
+ * Relocatable include entries are marked with a leading .../
+ *
+ * The algorithm is
+ * 0: Remove that leading ".../"
+ * 1: Remove trailing executable name (anything after the last '/')
+ * from the perl path to give a perl prefix
+ * Then
+ * While the @INC element starts "../" and the prefix ends with a real
+ * directory (ie not . or ..) chop that real directory off the prefix
+ * and the leading "../" from the @INC element. ie a logical "../"
+ * cleanup
+ * Finally concatenate the prefix and the remainder of the @INC element
+ * The intent is that /usr/local/bin/perl and .../../lib/perl5
+ * generates /usr/local/lib/perl5
+ */
+ {
+ char *libpath = SvPVX(libdir);
+ STRLEN libpath_len = SvCUR(libdir);
+ if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) {
+ /* Game on! */
+ SV *caret_X = get_sv("\030", 0);
+ /* Going to use the SV just as a scratch buffer holding a C
+ string: */
+ SV *prefix_sv;
+ char *prefix;
+ char *lastslash;
+
+ /* $^X is *the* source of taint if tainting is on, hence
+ SvPOK() won't be true. */
+ assert(caret_X);
+ assert(SvPOKp(caret_X));
+ prefix_sv = newSVpvn(SvPVX(caret_X), SvCUR(caret_X));
+ /* Firstly take off the leading .../
+ If all else fail we'll do the paths relative to the current
+ directory. */
+ sv_chop(libdir, libpath + 4);
+ /* Don't use SvPV as we're intentionally bypassing taining,
+ mortal copies that the mg_get of tainting creates, and
+ corruption that seems to come via the save stack.
+ I guess that the save stack isn't correctly set up yet. */
+ libpath = SvPVX(libdir);
+ libpath_len = SvCUR(libdir);
+
+ /* This would work more efficiently with memrchr, but as it's
+ only a GNU extension we'd need to probe for it and
+ implement our own. Not hard, but maybe not worth it? */
+
+ prefix = SvPVX(prefix_sv);
+ lastslash = strrchr(prefix, '/');
+
+ /* First time in with the *lastslash = '\0' we just wipe off
+ the trailing /perl from (say) /usr/foo/bin/perl
+ */
+ if (lastslash) {
+ SV *tempsv;
+ while ((*lastslash = '\0'), /* Do that, come what may. */
+ (libpath_len >= 3 && memEQ(libpath, "../", 3)
+ && (lastslash = strrchr(prefix, '/')))) {
+ if (lastslash[1] == '\0'
+ || (lastslash[1] == '.'
+ && (lastslash[2] == '/' /* ends "/." */
+ || (lastslash[2] == '/'
+ && lastslash[3] == '/' /* or "/.." */
+ )))) {
+ /* Prefix ends "/" or "/." or "/..", any of which
+ are fishy, so don't do any more logical cleanup.
+ */
+ break;
+ }
+ /* Remove leading "../" from path */
+ libpath += 3;
+ libpath_len -= 3;
+ /* Next iteration round the loop removes the last
+ directory name from prefix by writing a '\0' in
+ the while clause. */
+ }
+ /* prefix has been terminated with a '\0' to the correct
+ length. libpath points somewhere into the libdir SV.
+ We need to join the 2 with '/' and drop the result into
+ libdir. */
+ tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath);
+ SvREFCNT_dec(libdir);
+ /* And this is the new libdir. */
+ libdir = tempsv;
+ if (PL_tainting &&
+ (PL_uid != PL_euid || PL_gid != PL_egid)) {
+ /* Need to taint reloccated paths if running set ID */
+ SvTAINTED_on(libdir);
+ }
+ }
+ SvREFCNT_dec(prefix_sv);
+ }
+ }
+#endif
/*
* BEFORE pushing libdir onto @INC we may first push version- and
* archname-specific sub-directories.
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- struct stat 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
while (AvFILL(paramList) >= 0) {
cv = (CV*)av_shift(paramList);
- if (PL_savebegin && (paramList == PL_beginav)) {
+ if (PL_savebegin) {
+ if (paramList == PL_beginav) {
/* save PL_beginav for compiler */
- if (! PL_beginav_save)
- PL_beginav_save = newAV();
- av_push(PL_beginav_save, (SV*)cv);
+ if (! PL_beginav_save)
+ PL_beginav_save = newAV();
+ av_push(PL_beginav_save, (SV*)cv);
+ }
+ else if (paramList == PL_checkav) {
+ /* save PL_checkav for compiler */
+ if (! PL_checkav_save)
+ PL_checkav_save = newAV();
+ av_push(PL_checkav_save, (SV*)cv);
+ }
} else {
SAVEFREESV(cv);
}
atsv = ERRSV;
(void)SvPV(atsv, len);
if (len) {
- STRLEN n_a;
PL_curcop = &PL_compiling;
CopLINE_set(PL_curcop, oldline);
if (paramList == PL_beginav)
while (PL_scopestack_ix > oldscope)
LEAVE;
JMPENV_POP;
- Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a));
+ Perl_croak(aTHX_ "%"SVf"", atsv);
}
break;
case 1:
STATUS_NATIVE_SET(44);
}
else {
- if (!vaxc$errno && errno) /* unlikely */
+ if (!vaxc$errno) /* unlikely */
STATUS_NATIVE_SET(44);
else
STATUS_NATIVE_SET(vaxc$errno);
https://perl5.git.perl.org / perl5.git / blobdiff