CPAN update (CPAN-1.44_54) from Andreas and

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index 9ddf917..25111ad 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -64,6 +64,9 @@ static void my_exit_jump _((void)) __attribute__((noreturn));
 static void nuke_stacks _((void));
 static void open_script _((char *, bool, SV *, int *fd));
 static void usage _((char *));
+#ifdef IAMSUID
+static int  fd_on_nosuid_fs _((int));
+#endif
 static void validate_suid _((char *, char*, int));
 static I32 read_e_script _((int idx, SV *buf_sv, int maxlen));
 #endif
@@ -1145,6 +1148,7 @@ CV*
 perl_get_cv(char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
+    /* XXX unsafe for threads if eval_owner isn't held */
     if (create && !GvCVu(gv))
        return newSUB(start_subparse(FALSE, 0),
                      newSVOP(OP_CONST, 0, newSVpv(name,0)),
@@ -1447,8 +1451,10 @@ perl_eval_pv(char *p, I32 croak_on_error)
     sv = POPs;
     PUTBACK;
 
-    if (croak_on_error && SvTRUE(ERRSV))
-       croak(SvPVx(ERRSV, PL_na));
+    if (croak_on_error && SvTRUE(ERRSV)) {
+       STRLEN n_a;
+       croak(SvPVx(ERRSV, n_a));
+    }
 
     return sv;
 }
@@ -1753,6 +1759,9 @@ moreswitches(char *s)
 #ifdef POSIX_BC
        printf("BS2000 (POSIX) port by Start Amadeus GmbH, 1998\n");
 #endif
+#ifdef __MINT__
+       printf("MiNT port by Guido Flohr, 1997\n");
+#endif
 #ifdef BINARY_BUILD_NOTICE
        BINARY_BUILD_NOTICE;
 #endif
@@ -2104,6 +2113,70 @@ sed %s -e \"/^[^#]/b\" \
     }
 }
 
+#ifdef IAMSUID
+static int
+fd_on_nosuid_fs(int fd)
+{
+    int on_nosuid  = 0;
+    int check_okay = 0;
+/*
+ * Preferred order: fstatvfs(), fstatfs(), getmntent().
+ * fstatvfs() is UNIX98.
+ * fstatfs() is BSD.
+ * getmntent() is O(number-of-mounted-filesystems) and can hang.
+ */
+
+#   ifdef HAS_FSTATVFS
+    struct statvfs stfs;
+    check_okay = fstatvfs(fd, &stfs) == 0;
+    on_nosuid  = check_okay && (stfs.f_flag  & ST_NOSUID);
+#   else
+#       if defined(HAS_FSTATFS) && defined(HAS_STRUCT_STATFS_FLAGS)
+    struct statfs  stfs;
+    check_okay = fstatfs(fd, &stfs)  == 0;
+#           undef PERL_MOUNT_NOSUID
+#           if !defined(PERL_MOUNT_NOSUID) && defined(MNT_NOSUID)
+#              define PERL_MOUNT_NOSUID MNT_NOSUID
+#           endif
+#           if !defined(PERL_MOUNT_NOSUID) && defined(MS_NOSUID)
+#              define PERL_MOUNT_NOSUID MS_NOSUID
+#           endif
+#           if !defined(PERL_MOUNT_NOSUID) && defined(M_NOSUID)
+#              define PERL_MOUNT_NOSUID M_NOSUID
+#           endif
+#           ifdef PERL_MOUNT_NOSUID
+    on_nosuid  = check_okay && (stfs.f_flags & PERL_MOUNT_NOSUID);
+#           endif
+#       else
+#           if defined(HAS_GETMNENT) && defined(HAS_HASMNTOPT) && defined(MNTOPT_NOSUID)
+    FILE               *mtab = fopen("/etc/mtab", "r");
+    struct mntent      *entry;
+    struct stat                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;
+               break;
+           } /* A single fs may well fail its stat(). */
+       }
+    }
+    if (mtab)
+       fclose(mtab);
+#           endif /* mntent */
+#       endif /* statfs */
+#   endif /* statvfs */
+    if (!check_okay) 
+       croak("Can't check filesystem of script \"%s\"", PL_origfilename);
+    return on_nosuid;
+}
+#endif /* IAMSUID */
+
 STATIC void
 validate_suid(char *validarg, char *scriptname, int fdscript)
 {
@@ -2137,6 +2210,7 @@ validate_suid(char *validarg, char *scriptname, int fdscript)
        croak("Can't stat script \"%s\"",PL_origfilename);
     if (fdscript < 0 && PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
        I32 len;
+       STRLEN n_a;
 
 #ifdef IAMSUID
 #ifndef HAS_SETREUID
@@ -2171,6 +2245,10 @@ validate_suid(char *validarg, char *scriptname, int fdscript)
                croak("Can't swap uid and euid");       /* really paranoid */
            if (PerlLIO_stat(SvPVX(GvSV(PL_curcop->cop_filegv)),&tmpstatbuf) < 0)
                croak("Permission denied");     /* testing full pathname here */
+#if defined(IAMSUID) && !defined(NO_NOSUID_CHECK)
+           if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp)))
+               croak("Permission denied");
+#endif
            if (tmpstatbuf.st_dev != PL_statbuf.st_dev ||
                tmpstatbuf.st_ino != PL_statbuf.st_ino) {
                (void)PerlIO_close(PL_rsfp);
@@ -2209,12 +2287,12 @@ validate_suid(char *validarg, char *scriptname, int fdscript)
        PL_doswitches = FALSE;          /* -s is insecure in suid */
        PL_curcop->cop_line++;
        if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
-         strnNE(SvPV(PL_linestr,PL_na),"#!",2) )       /* required even on Sys V */
+         strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
            croak("No #! line");
-       s = SvPV(PL_linestr,PL_na)+2;
+       s = SvPV(PL_linestr,n_a)+2;
        if (*s == ' ') s++;
        while (!isSPACE(*s)) s++;
-       for (s2 = s;  (s2 > SvPV(PL_linestr,PL_na)+2 &&
+       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 */
            croak("Not a perl script");
@@ -2753,7 +2831,7 @@ incpush(char *p, int addsubdirs)
            char *unix;
            STRLEN len;
 
-           if ((unix = tounixspec_ts(SvPV(libdir,PL_na),Nullch)) != Nullch) {
+           if ((unix = tounixspec_ts(SvPV(libdir,len),Nullch)) != Nullch) {
                len = strlen(unix);
                while (unix[len-1] == '/') len--;  /* Cosmetic */
                sv_usepvn(libdir,unix,len);
@@ -2761,7 +2839,7 @@ incpush(char *p, int addsubdirs)
            else
                PerlIO_printf(PerlIO_stderr(),
                              "Failed to unixify @INC element \"%s\"\n",
-                             SvPV(libdir,PL_na));
+                             SvPV(libdir,len));
 #endif
            /* .../archname/version if -d .../archname/version/auto */
            sv_setsv(subdir, libdir);