/* perl.c
*
- * Copyright (c) 1987-2002 Larry Wall
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 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)
+#if defined(USE_ITHREADS)
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
ALLOC_THREAD_KEY; \
PERL_SET_THX(my_perl); \
OP_REFCNT_INIT; \
+ MUTEX_INIT(&PL_dollarzero_mutex); \
} \
else { \
PERL_SET_THX(my_perl); \
} \
} STMT_END
-# else
+#else
# define INIT_TLS_AND_INTERP \
STMT_START { \
if (!PL_curinterp) { \
PERL_SET_THX(my_perl); \
} STMT_END
# endif
-#endif
#ifdef PERL_IMPLICIT_SYS
PerlInterpreter *
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
INIT_TLS_AND_INTERP;
- Zero(my_perl, 1, PerlInterpreter);
- return 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;
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
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. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+ 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;
}
*/
int
-Perl_nothreadhook(pTHXx)
+Perl_nothreadhook(pTHX)
{
return 0;
}
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;;
+ 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);
#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_ 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
Perl_reentrant_free(aTHX);
}
}
/* 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
#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) {
}
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++;
#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);
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
while (isSPACE(*s))
s++;
if (*s == '-' && *(s+1) == 'T') {
+ CHECK_MALLOC_TOO_LATE_FOR('T');
PL_tainting = TRUE;
PL_taint_warn = FALSE;
}
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtw", *s))
+ if (!strchr("DIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*s)) {
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)
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);
- if (PL_wantutf8) { /* Requires init_predump_symbols(). */
- IO* io;
- PerlIO* fp;
- SV* sv;
- if (PL_stdingv && (io = GvIO(PL_stdingv)) && (fp = IoIFP(io)))
- PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
- if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
- PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
- if (PL_stderrgv && (io = GvIO(PL_stderrgv)) && (fp = IoOFP(io)))
- PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
- if ((sv = GvSV(gv_fetchpv("\017PEN", TRUE, SVt_PV)))) {
- sv_setpvn(sv, ":utf8\0:utf8", 11);
- SvSETMAGIC(sv);
+ /* 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
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) {
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 checks",
"-t enable tainting warnings",
+"-T enable tainting checks",
"-u dump core after parsing program",
"-U allow unsafe operations",
"-v print version, subversion (includes VERY IMPORTANT perl info)",
"-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[] = "psltocPmfrxuLHXDSTRJ";
- 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++) ;
- }
-#ifdef EBCDIC
- if (DEBUG_p_TEST_ && ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "-Dp not implemented on this platform\n");
-#endif
- PL_debug |= DEBUG_TOP_FLAG;
+ s++;
+ PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
if (ckWARN_d(WARN_DEBUGGING))
Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
- "Recompile perl with -DDEBUGGING to use -D switch\n");
+ "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
for (s++; isALNUM(*s); s++) ;
#endif
/*SUPPRESS 530*/
}
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);
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;
return s;
case 't':
if (!PL_tainting)
- Perl_croak(aTHX_ "Too late for \"-t\" option");
+ 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-2002, Larry Wall\n");
+ "\n\nCopyright 1987-2004, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
#endif
#ifdef MPE
PerlIO_printf(PerlIO_stdout(),
- "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2002\n");
+ "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2003\n");
#endif
#ifdef OEMVS
PerlIO_printf(PerlIO_stdout(),
"EPOC port by Olaf Flebbe, 1999-2002\n");
#endif
#ifdef UNDER_CE
- printf("WINCE port by Rainer Keuchel, 2001-2002\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;
{
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)
{
+#ifndef IAMSUID
char *quote;
char *code;
char *cpp_discard_flag;
char *perl;
+#endif
- *fdscript = -1;
+ 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;
CopFILE_set(PL_curcop, PL_origfilename);
if (strEQ(PL_origfilename,"-"))
scriptname = "";
- if (*fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
+ 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);
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",
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
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
-# endif
+ /* PSz 16 Sep 03 Keep neat error message */
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
STATIC int
S_fd_on_nosuid_fs(pTHX_ int fd)
{
+/* PSz 27 Feb 04
+ * We used to do this as "plain" user (after swapping UIDs with setreuid);
+ * but is needed also on machines without setreuid.
+ * Seems safe enough to run as root.
+ */
int check_okay = 0; /* able to do all the required sys/libcalls */
int on_nosuid = 0; /* the fd is on a nosuid fs */
+ /* PSz 12 Nov 03
+ * Need to check noexec also: nosuid might not be set, the average
+ * sysadmin would say that nosuid is irrelevant once he sets noexec.
+ */
+ int on_noexec = 0; /* the fd is on a noexec fs */
+
/*
* Preferred order: fstatvfs(), fstatfs(), ustat()+getmnt(), getmntent().
* fstatvfs() is UNIX98.
check_okay = fstatvfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flag & ST_NOSUID);
+#ifdef ST_NOEXEC
+ /* ST_NOEXEC certainly absent on AIX 5.1, and doesn't seem to be documented
+ on platforms where it is present. */
+ on_noexec = check_okay && (stfs.f_flag & ST_NOEXEC);
+#endif
# endif /* fstatvfs */
# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
defined(PERL_MOUNT_NOSUID) && \
+ defined(PERL_MOUNT_NOEXEC) && \
defined(HAS_FSTATFS) && \
defined(HAS_STRUCT_STATFS) && \
defined(HAS_STRUCT_STATFS_F_FLAGS)
check_okay = fstatfs(fd, &stfs) == 0;
on_nosuid = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
+ on_noexec = check_okay && (stfs.f_flags & PERL_MOUNT_NOEXEC);
# endif /* fstatfs */
# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
defined(PERL_MOUNT_NOSUID) && \
+ defined(PERL_MOUNT_NOEXEC) && \
defined(HAS_FSTAT) && \
defined(HAS_USTAT) && \
defined(HAS_GETMNT) && \
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");
+
}
-#endif /* HAS_SETREUID */
+ 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
#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 */
+ /* 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
;
}
#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);
}
}
}
{
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
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)
+ if (env != environ
+# ifdef USE_ITHREADS
+ && PL_curinterp == aTHX
+# endif
+ )
+ {
environ[0] = Nullch;
- if (env)
+ }
+ if (env) {
+ char** origenv = environ;
for (; *env; env++) {
- if (!(s = strchr(*env,'=')))
+ if (!(s = strchr(*env,'=')) || s == *env)
continue;
-#if defined(MSDOS)
+#if defined(MSDOS) && !defined(DJGPP)
*s = '\0';
(void)strupr(*env);
*s = '=';
(void)hv_store(hv, *env, s - *env, sv, 0);
if (env != environ)
mg_set(sv);
+ if (origenv != environ) {
+ /* realloc has shifted us */
+ env = (env - origenv) + environ;
+ origenv = environ;
+ }
}
+ }
#endif /* USE_ENVIRON_ARRAY */
+#endif /* !PERL_MICRO */
}
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);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
#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); } 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);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE, TRUE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE, 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);
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);
SvREFCNT_dec(privdir);
}
if (!PL_tainting)
- incpush(":", FALSE, FALSE);
+ incpush(":", FALSE, FALSE, TRUE);
#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);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE, 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);
# 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);
# else
- incpush(SITELIB_EXP, FALSE, FALSE);
+ incpush(SITELIB_EXP, FALSE, FALSE, TRUE);
# endif
#endif
#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
- incpush(SITELIB_STEM, FALSE, TRUE);
+ incpush(SITELIB_STEM, FALSE, 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);
# 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); /* this picks up vendorarch as well */
# else
- incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, 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);
#endif
#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE);
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE);
#endif
if (!PL_tainting)
- incpush(".", FALSE, FALSE);
+ incpush(".", FALSE, FALSE, TRUE);
#endif /* MACOS_TRADITIONAL */
}
#endif
STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
{
SV *subdir = Nullsv;
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
const char *incverlist[] = { PERL_INC_VERSION_LIST };
const char **incver;
#endif
- struct stat tmpstatbuf;
+ Stat_t tmpstatbuf;
#ifdef VMS
char *unix;
STRLEN len;
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);