/* perl.c
*
- * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
- * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
+ * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001
+ * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 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.
* 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"
static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
-#ifdef DOSUID
-# ifdef IAMSUID
-/* Drop scriptname */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ validarg, fdscript, suidscript, linestr_sv, rsfp)
-# else
-/* Drop suidscript */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ validarg, scriptname, fdscript, linestr_sv, rsfp)
-# endif
-#else
-# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
/* Drop everything. Heck, don't even try to call it */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
-# else
+# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP
+#else
/* Drop almost everything */
-# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
-# endif
+# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp)
#endif
#define CALL_BODY_EVAL(myop) \
PL_timesbase.tms_cstime = 0;
#endif
+ PL_registered_mros = newHV();
+ /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */
+ HvMAX(PL_registered_mros) = 0;
+
ENTER;
}
PL_exitlist = NULL;
PL_exitlistlen = 0;
+ SvREFCNT_dec(PL_registered_mros);
+
/* 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
PERL_UNUSED_ARG(my_perl);
#endif
-#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW_AND_IAMSUID
- Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now "
- "execute\nsetuid perl scripts securely.\n");
-#endif
-
#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.
char **argv = PL_origargv;
const char *scriptname = NULL;
VOL bool dosearch = FALSE;
-#ifdef DOSUID
- const char *validarg = "";
-#endif
register SV *sv;
register char c;
const char *cddir = NULL;
for (argc--,argv++; argc > 0; argc--,argv++) {
if (argv[0][0] != '-' || !argv[0][1])
break;
-#ifdef DOSUID
- if (*validarg)
- 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 ((c = *s)) {
if (s && *s) {
STRLEN len = strlen(s);
const char * const p = savepvn(s, len);
- incpush(p, TRUE, TRUE, FALSE, FALSE);
+ incpush(p, TRUE, TRUE, FALSE, FALSE, FALSE);
sv_catpvs(sv, "-I");
sv_catpvn(sv, p, len);
sv_catpvs(sv, " ");
# ifdef PERL_MEM_LOG_TIMESTAMP
" PERL_MEM_LOG_TIMESTAMP"
# endif
+# ifdef PERL_USE_DEVEL
+ " PERL_USE_DEVEL"
+# endif
# ifdef PERL_USE_SAFE_PUTENV
" PERL_USE_SAFE_PUTENV"
# endif
#else
sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n");
#endif
-
sv_catpvs(opts_prog," Compile-time options: $_\\n\",");
#if defined(LOCAL_PATCH_COUNT)
for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
if (PL_localpatches[i])
Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
- 0, PL_localpatches[i], 0);
+ 0, PL_localpatches[i], 0);
}
}
#endif
{
bool suidscript = FALSE;
-#ifdef DOSUID
- const int fdscript =
-#endif
- open_script(scriptname, dosearch, &suidscript, &rsfp);
+ open_script(scriptname, dosearch, &suidscript, &rsfp);
validate_suid(validarg, scriptname, fdscript, suidscript,
- linestr_sv, rsfp);
+ linestr_sv, rsfp);
#ifndef PERL_MICRO
# if defined(SIGCHLD) || defined(SIGCLD)
=for apidoc p||get_sv
-Returns the SV of the specified Perl scalar. If C<create> is set and the
-Perl variable does not exist then it will be created. If C<create> is not
-set and the variable does not exist then NULL is returned.
+Returns the SV of the specified Perl scalar. C<flags> are passed to
+C<gv_fetchpv>. If C<GV_ADD> is set and the
+Perl variable does not exist then it will be created. If C<flags> is zero
+and the variable does not exist then NULL is returned.
=cut
*/
SV*
-Perl_get_sv(pTHX_ const char *name, I32 create)
+Perl_get_sv(pTHX_ const char *name, I32 flags)
{
GV *gv;
PERL_ARGS_ASSERT_GET_SV;
- gv = gv_fetchpv(name, create, SVt_PV);
+ gv = gv_fetchpv(name, flags, SVt_PV);
if (gv)
return GvSV(gv);
return NULL;
=for apidoc p||get_av
-Returns the AV of the specified Perl array. If C<create> is set and the
-Perl variable does not exist then it will be created. If C<create> is not
-set and the variable does not exist then NULL is returned.
+Returns the AV of the specified Perl array. C<flags> are passed to
+C<gv_fetchpv>. If C<GV_ADD> is set and the
+Perl variable does not exist then it will be created. If C<flags> is zero
+and the variable does not exist then NULL is returned.
=cut
*/
AV*
-Perl_get_av(pTHX_ const char *name, I32 create)
+Perl_get_av(pTHX_ const char *name, I32 flags)
{
- GV* const gv = gv_fetchpv(name, create, SVt_PVAV);
+ GV* const gv = gv_fetchpv(name, flags, SVt_PVAV);
PERL_ARGS_ASSERT_GET_AV;
- if (create)
+ if (flags)
return GvAVn(gv);
if (gv)
return GvAV(gv);
=for apidoc p||get_hv
-Returns the HV of the specified Perl hash. If C<create> is set and the
-Perl variable does not exist then it will be created. If C<create> is not
-set and the variable does not exist then NULL is returned.
+Returns the HV of the specified Perl hash. C<flags> are passed to
+C<gv_fetchpv>. If C<GV_ADD> is set and the
+Perl variable does not exist then it will be created. If C<flags> is zero
+and the variable does not exist then NULL is returned.
=cut
*/
HV*
-Perl_get_hv(pTHX_ const char *name, I32 create)
+Perl_get_hv(pTHX_ const char *name, I32 flags)
{
- GV* const gv = gv_fetchpv(name, create, SVt_PVHV);
+ GV* const gv = gv_fetchpv(name, flags, SVt_PVHV);
PERL_ARGS_ASSERT_GET_HV;
- if (create)
+ if (flags)
return GvHVn(gv);
if (gv)
return GvHV(gv);
return NULL;
}
+/* Nothing in core calls this now, but we can't replace it with a macro and
+ move it to mathoms.c as a macro would evaluate name twice. */
CV*
Perl_get_cv(pTHX_ const char *name, I32 flags)
{
{
PERL_ARGS_ASSERT_CALL_PV;
- return call_sv(MUTABLE_SV(get_cv(sub_name, TRUE)), flags);
+ return call_sv(MUTABLE_SV(get_cv(sub_name, GV_ADD)), flags);
}
/*
POPSTACK;
}
-void
-Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
-{
- register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
-
- PERL_ARGS_ASSERT_MAGICNAME;
-
- if (gv)
- sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, namlen);
-}
-
STATIC void
S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */
{
PL_rs = newSVpvn(&ch, 1);
}
}
- sv_setsv(get_sv("/", TRUE), PL_rs);
+ sv_setsv(get_sv("/", GV_ADD), PL_rs);
return s + numlen;
}
case 'C':
p++;
} while (*p && *p != '-');
e = savepvn(s, e-s);
- incpush(e, TRUE, TRUE, FALSE, FALSE);
+ incpush(e, TRUE, TRUE, FALSE, FALSE, TRUE);
Safefree(e);
s = p;
if (*s == '-')
if (!sv_derived_from(PL_patchlevel, "version"))
upg_version(PL_patchlevel, TRUE);
#if !defined(DGUX)
- PerlIO_printf(PerlIO_stdout(),
- "\nThis is perl, %"SVf
+ {
+ SV* level= vstringify(PL_patchlevel);
#ifdef PERL_PATCHNUM
- " DEVEL" STRINGIFY(PERL_PATCHNUM)
-#endif
+# ifdef PERL_GIT_UNCOMMITTED_CHANGES
+ SV *num = newSVpvs(PERL_PATCHNUM "*");
+# else
+ SV *num = newSVpvs(PERL_PATCHNUM);
+# endif
+
+ if (sv_len(num)>=sv_len(level) && strnEQ(SvPV_nolen(num),SvPV_nolen(level),sv_len(level))) {
+ SvREFCNT_dec(level);
+ level= num;
+ } else {
+ Perl_sv_catpvf(aTHX_ level, " (%"SVf")", num);
+ SvREFCNT_dec(num);
+ }
+ #endif
+ PerlIO_printf(PerlIO_stdout(),
+ "\nThis is perl, %"SVf
" built for %s",
- SVfARG(vstringify(PL_patchlevel)),
+ level,
ARCHNAME);
+ SvREFCNT_dec(level);
+ }
#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_ " OS Specific Release: %s\n",
OSVERS));
#endif /* !DGUX */
-
#if defined(LOCAL_PATCH_COUNT)
if (LOCAL_PATCH_COUNT > 0)
PerlIO_printf(PerlIO_stdout(),
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2008, Larry Wall\n");
+ "\n\nCopyright 1987-2009, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI,
SVt_PVHV));
/* We must init $/ before switches are processed. */
- sv_setpvs(get_sv("/", TRUE), "\n");
+ sv_setpvs(get_sv("/", GV_ADD), "\n");
}
STATIC int
fcntl(PerlIO_fileno(*rsfpp),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 (*suidscript) {
- Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
- }
-#else /* IAMSUID */
else if (!*scriptname) {
forbid_setid(0, *suidscript);
*rsfpp = PerlIO_stdin();
fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
# endif
}
-#endif /* IAMSUID */
if (!*rsfpp) {
/* PSz 16 Sep 03 Keep neat error message */
if (PL_e_script)
* I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT
* here so that metaconfig picks them up. */
-#ifdef IAMSUID
-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.
- * fstatfs() is 4.3 BSD.
- * ustat()+getmnt() is pre-4.3 BSD.
- * getmntent() is O(number-of-mounted-filesystems) and can hang on
- * an irrelevant filesystem while trying to reach the right one.
- */
-
-#undef FD_ON_NOSUID_CHECK_OKAY /* found the syscalls to do the check? */
-
-# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
- defined(HAS_FSTATVFS)
-# define FD_ON_NOSUID_CHECK_OKAY
- struct statvfs stfs;
-
- 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)
-# define FD_ON_NOSUID_CHECK_OKAY
- struct statfs stfs;
-
- 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
- Stat_t fdst;
-
- if (fstat(fd, &fdst) == 0) {
- struct ustat us;
- if (ustat(fdst.st_dev, &us) == 0) {
- struct fs_data fsd;
- /* NOSTAT_ONE here because we're not examining fields which
- * vary between that case and STAT_ONE. */
- if (getmnt((int*)0, &fsd, (int)0, NOSTAT_ONE, us.f_fname) == 0) {
- size_t cmplen = sizeof(us.f_fname);
- if (sizeof(fsd.fd_req.path) < cmplen)
- cmplen = sizeof(fsd.fd_req.path);
- if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
- fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
- }
- }
- }
- }
-# endif /* fstat+ustat+getmnt */
-
-# if !defined(FD_ON_NOSUID_CHECK_OKAY) && \
- defined(HAS_GETMNTENT) && \
- defined(HAS_HASMNTOPT) && \
- defined(MNTOPT_NOSUID) && \
- defined(MNTOPT_NOEXEC)
-# define FD_ON_NOSUID_CHECK_OKAY
- FILE *mtab = fopen("/etc/mtab", "r");
- struct mntent *entry;
- Stat_t stb, fsb;
-
- if (mtab && (fstat(fd, &stb) == 0)) {
- while (entry = getmntent(mtab)) {
- if (stat(entry->mnt_dir, &fsb) == 0
- && fsb.st_dev == stb.st_dev)
- {
- /* found the filesystem */
- 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(). */
- }
- }
- if (mtab)
- fclose(mtab);
-# endif /* getmntent+hasmntopt */
-
- if (!check_okay)
- 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 */
-
-#ifdef DOSUID
-STATIC void
-S_validate_suid(pTHX_ const char *validarg,
-# ifndef IAMSUID
- const char *scriptname,
-# endif
- int fdscript,
-# ifdef IAMSUID
- bool suidscript,
-# endif
- SV *linestr_sv, PerlIO *rsfp)
-{
- dVAR;
- const char *s, *s2;
-
- PERL_ARGS_ASSERT_VALIDATE_SUID;
-
- /* do we need to emulate setuid on scripts? */
-
- /* This code is for those BSD systems that have setuid #! scripts disabled
- * in the kernel because of a security problem. Merely defining DOSUID
- * in perl will not fix that problem, but if you have disabled setuid
- * scripts in the kernel, this will attempt to emulate setuid and setgid
- * on scripts that have those now-otherwise-useless bits set. The setuid
- * root version must be called suidperl or sperlN.NNN. If regular perl
- * discovers that it has opened a setuid script, it calls suidperl with
- * the same argv that it had. If suidperl finds that the script it has
- * just opened is NOT setuid root, it sets the effective uid back to the
- * 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
- * Configure script will set this up for you if you want it.
- */
-
- if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
- Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
- if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
- I32 len;
- const char *linestr;
- const char *s_end;
-
-# ifdef IAMSUID
- if (fdscript < 0 || !suidscript)
- 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
- * chance that someone could execute a setuid script down in a
- * 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_ "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.
- */
- {
- 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) {
- Perl_croak(aTHX_ "Setuid script changed\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(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_ "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(linestr_sv, rsfp, 0) == NULL)
- Perl_croak(aTHX_ "No #! line");
- linestr = SvPV_nolen_const(linestr_sv);
- /* required even on Sys V */
- if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
- Perl_croak(aTHX_ "No #! line");
- linestr += 2;
- s = linestr;
- /* PSz 27 Feb 04 */
- /* Sanity check on line length */
- s_end = s + strlen(s);
- if (s_end == s || (s_end - s) > 4000)
- Perl_croak(aTHX_ "Very long #! line");
- /* Allow more than a single space after #! */
- while (isSPACE(*s)) s++;
- /* Sanity check on buffer end */
- while ((*s) && !isSPACE(*s)) s++;
- for (s2 = s; (s2 > linestr &&
- (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
- || s2[-1] == '-')); s2--) ;
- /* Sanity check on buffer start */
- if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
- (s-9 < linestr || strnNE(s-9,"perl",4)) )
- Perl_croak(aTHX_ "Not a perl script");
- while (*s == ' ' || *s == '\t') s++;
- /*
- * #! arg must be what we saw above. They can invoke it by
- * 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]) ||
- !((s_end - s) == len+1
- || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
- Perl_croak(aTHX_ "Args must match #! line");
-
-# ifndef IAMSUID
- if (fdscript < 0 &&
- PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
- PL_euid == PL_statbuf.st_uid)
- if (!PL_do_undump)
- Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
-FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
-# endif /* IAMSUID */
-
- if (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
- * fdscript to avoid loops), and do the execs
- * even for root.
- */
-# ifndef IAMSUID
- 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(rsfp);
- PerlLIO_lseek(PerlIO_fileno(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(rsfp), PL_origargv[which]));
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(rsfp),F_SETFD,0); /* ensure no close-on-exec */
-# endif
- PERL_FPU_PRE_EXEC
- PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
- (int)PERL_REVISION, (int)PERL_VERSION,
- (int)PERL_SUBVERSION), PL_origargv);
- PERL_FPU_POST_EXEC
-# endif /* 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
-# ifdef HAS_SETREGID
- (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
-# else
-# ifdef HAS_SETRESGID
- (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
-# else
- PerlProc_setgid(PL_statbuf.st_gid);
-# endif
-# endif
-# endif
- if (PerlProc_getegid() != PL_statbuf.st_gid)
- Perl_croak(aTHX_ "Can't do setegid!\n");
- }
- if (PL_statbuf.st_mode & S_ISUID) {
- if (PL_statbuf.st_uid != PL_euid)
-# ifdef HAS_SETEUID
- (void)seteuid(PL_statbuf.st_uid); /* all that for this */
-# else
-# ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
-# else
-# ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
-# else
- PerlProc_setuid(PL_statbuf.st_uid);
-# endif
-# endif
-# endif
- if (PerlProc_geteuid() != PL_statbuf.st_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
- }
- else if (PL_uid) { /* oops, mustn't run as root */
-# ifdef HAS_SETEUID
- (void)seteuid((Uid_t)PL_uid);
-# else
-# ifdef HAS_SETREUID
- (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
-# else
-# ifdef HAS_SETRESUID
- (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
-# else
- PerlProc_setuid((Uid_t)PL_uid);
-# endif
-# endif
-# endif
- if (PerlProc_geteuid() != PL_uid)
- Perl_croak(aTHX_ "Can't do seteuid!\n");
- }
- init_ids();
- if (!cando(S_IXUSR,TRUE,&PL_statbuf))
- Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */
- }
-# ifdef IAMSUID
- else if (fdscript < 0 || !suidscript)
- /* 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(rsfp);
- PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0); /* just in case rewind didn't */
- /* PSz 11 Nov 03
- * Keep original arguments: suidperl already has fd script.
- */
-# if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(PerlIO_fileno(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_FPU_POST_EXEC
- Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
-# endif /* IAMSUID */
-}
-
-#else /* !DOSUID */
-# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
/* Don't even need this function. */
-# else
+#else
STATIC void
S_validate_suid(pTHX_ PerlIO *rsfp)
{
PERL_ARGS_ASSERT_VALIDATE_SUID;
if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */
-# ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
dVAR;
PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf); /* may be either wrapped or real suid */
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");
-# endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* not set-id, must be wrapped */
}
}
-# endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
-#endif /* DOSUID */
+#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
STATIC void
S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
if (PL_egid != PL_gid)
Perl_croak(aTHX_ "No %s allowed while running setgid", message);
#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 (suidscript)
Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
-#ifdef IAMSUID
- /* PSz 11 Nov 03 Catch it in suidperl, always! */
- Perl_croak(aTHX_ "No %s allowed in suidperl", message);
-#endif /* IAMSUID */
}
void
GV *tmpgv;
IO *io;
- sv_setpvs(get_sv("\"", TRUE), " ");
+ sv_setpvs(get_sv("\"", GV_ADD), " ");
PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV));
PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO);
sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
#else
sv_setpv(GvSV(tmpgv),PL_origfilename);
- magicname("0", "0", 1);
+ {
+ GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV);
+ if (gv)
+ sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1);
+ }
#endif
}
if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
/* touch @F array to prevent spurious warnings 20020415 MJD */
if (PL_minus_a) {
- (void) get_av("main::F", TRUE | GV_ADDMULTI);
+ (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
}
}
#else
if (s)
#endif
- incpush(s, TRUE, TRUE, TRUE, FALSE);
+ incpush(s, TRUE, TRUE, TRUE, FALSE, FALSE);
else
- incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
+ incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE, 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,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+ do { incpush(buf,TRUE,TRUE,TRUE,FALSE, FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
else
- while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
+ while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE, FALSE);
#endif /* VMS */
}
ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
*/
#ifdef APPLLIB_EXP
- incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
+ incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE, FALSE);
#endif
#ifdef ARCHLIB_EXP
- incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
+ incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
#endif
#ifdef MACOS_TRADITIONAL
{
Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
- incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE, 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, TRUE, FALSE);
+ incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE, FALSE);
SvREFCNT_dec(privdir);
}
if (!PL_tainting)
- incpush(":", FALSE, FALSE, TRUE, FALSE);
+ incpush(":", FALSE, FALSE, FALSE, FALSE, 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, TRUE, TRUE);
+ incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);
#else
- incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
+ incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
#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, TRUE, TRUE);
+ incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
# endif
#endif
#ifdef SITELIB_EXP
# if defined(WIN32)
/* this picks up sitearch as well */
- incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
+ incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);
# else
- incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
+ incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
# endif
#endif
#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
/* Search for version-specific dirs below here */
- incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
+ incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE);
#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, TRUE, TRUE);
+ incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
# endif
#endif
#ifdef PERL_VENDORLIB_EXP
# if defined(WIN32)
- incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE); /* this picks up vendorarch as well */
+ incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE); /* this picks up vendorarch as well */
# else
- incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
+ incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
# endif
#endif
#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
/* Search for version-specific dirs below here */
- incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
+ incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE);
#endif
#ifdef PERL_OTHERLIBDIRS
- incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
+ incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE, FALSE);
#endif
if (!PL_tainting)
- incpush(".", FALSE, FALSE, TRUE, FALSE);
+ incpush(".", FALSE, FALSE, FALSE, FALSE, FALSE);
#endif /* MACOS_TRADITIONAL */
}
STATIC void
S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
- bool canrelocate)
+ bool canrelocate, bool unshift)
{
dVAR;
SV *subdir = NULL;
#endif
}
- /* finally push this lib directory on the end of @INC */
- av_push(GvAVn(PL_incgv), libdir);
+ /* finally add this lib directory at the end of @INC */
+ if (unshift) {
+ av_unshift( GvAVn( PL_incgv ), 1 );
+ av_store( GvAVn( PL_incgv ), 0, libdir );
+ }
+ else {
+ av_push(GvAVn(PL_incgv), libdir);
+ }
}
if (subdir) {
assert (SvREFCNT(subdir) == 1);
*/
if (MY_POSIX_EXIT) {
- /* In POSIX_EXIT mode follow Perl documentations and use 255 for
- * the exit code when there isn't an error.
- */
+ /* According to the die_exit.t tests, if errno is non-zero */
+ /* It should be used for the error status. */
- if (STATUS_UNIX == 0)
- STATUS_UNIX_EXIT_SET(255);
- else {
- STATUS_UNIX_EXIT_SET(STATUS_UNIX);
+ if (errno == EVMSERR) {
+ STATUS_NATIVE = vaxc$errno;
+ } else {
- /* The exit code could have been set by $? or vmsish which
- * means that it may not be fatal. So convert
- * success/warning codes to fatal.
- */
- if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
+ /* According to die_exit.t tests, if the child_exit code is */
+ /* also zero, then we need to exit with a code of 255 */
+ if ((errno != 0) && (errno < 256))
+ STATUS_UNIX_EXIT_SET(errno);
+ else if (STATUS_UNIX < 255) {
STATUS_UNIX_EXIT_SET(255);
+ }
+
}
+
+ /* The exit code could have been set by $? or vmsish which
+ * means that it may not have fatal set. So convert
+ * success/warning codes to fatal with out changing
+ * the POSIX status code. The severity makes VMS native
+ * status handling work, while UNIX mode programs use the
+ * the POSIX exit codes.
+ */
+ if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) {
+ STATUS_NATIVE &= STS$M_COND_ID;
+ STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG;
+ }
}
else {
/* Traditionally Perl on VMS always expects a Fatal Error. */
https://perl5.git.perl.org / perl5.git / blobdiff