enable dynaloading in C.pm-compiled programs (non-conflicting part

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 0671004..69ded97 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
@@ -126,7 +129,6 @@ perl_construct(register PerlInterpreter *sv_interp)
            croak("panic: pthread_key_create");
 #endif
        MUTEX_INIT(&PL_sv_mutex);
-       MUTEX_INIT(&PL_cred_mutex);
        /*
         * Safe to use basic SV functions from now on (though
         * not things like mortals or tainting yet).
@@ -559,7 +561,6 @@ perl_destruct(register PerlInterpreter *sv_interp)
 #ifdef USE_THREADS
     MUTEX_DESTROY(&PL_strtab_mutex);
     MUTEX_DESTROY(&PL_sv_mutex);
-    MUTEX_DESTROY(&PL_cred_mutex);
     MUTEX_DESTROY(&PL_eval_mutex);
     MUTEX_DESTROY(&PL_cred_mutex);
     COND_DESTROY(&PL_eval_cond);
@@ -890,19 +891,25 @@ print \"  \\@INC:\\n    @INC\\n\";");
   switch_end:
 
     if (!PL_tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
-       while (s && *s) {
-           while (isSPACE(*s))
-               s++;
-           if (*s == '-') {
-               s++;
-               if (isSPACE(*s))
-                   continue;
+       while (isSPACE(*s))
+           s++;
+       if (*s == '-' && *(s+1) == 'T')
+           PL_tainting = TRUE;
+       else {
+           while (s && *s) {
+               while (isSPACE(*s))
+                   s++;
+               if (*s == '-') {
+                   s++;
+                   if (isSPACE(*s))
+                       continue;
+               }
+               if (!*s)
+                   break;
+               if (!strchr("DIMUdmw", *s))
+                   croak("Illegal switch in PERL5OPT: -%c", *s);
+               s = moreswitches(s);
            }
-           if (!*s)
-               break;
-           if (!strchr("DIMUdmw", *s))
-               croak("Illegal switch in PERL5OPT: -%c", *s);
-           s = moreswitches(s);
        }
     }
 
@@ -1103,7 +1110,7 @@ perl_run(PerlInterpreter *sv_interp)
 }
 
 SV*
-perl_get_sv(char *name, I32 create)
+perl_get_sv(const char *name, I32 create)
 {
     GV *gv;
 #ifdef USE_THREADS
@@ -1122,7 +1129,7 @@ perl_get_sv(char *name, I32 create)
 }
 
 AV*
-perl_get_av(char *name, I32 create)
+perl_get_av(const char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
     if (create)
@@ -1133,7 +1140,7 @@ perl_get_av(char *name, I32 create)
 }
 
 HV*
-perl_get_hv(char *name, I32 create)
+perl_get_hv(const char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
     if (create)
@@ -1144,7 +1151,7 @@ perl_get_hv(char *name, I32 create)
 }
 
 CV*
-perl_get_cv(char *name, I32 create)
+perl_get_cv(const char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
     /* XXX unsafe for threads if eval_owner isn't held */
@@ -1161,7 +1168,7 @@ perl_get_cv(char *name, I32 create)
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 I32
-perl_call_argv(char *sub_name, I32 flags, register char **argv)
+perl_call_argv(const char *sub_name, I32 flags, register char **argv)
               
                        /* See G_* flags in cop.h */
                        /* null terminated arg list */
@@ -1180,7 +1187,7 @@ perl_call_argv(char *sub_name, I32 flags, register char **argv)
 }
 
 I32
-perl_call_pv(char *sub_name, I32 flags)
+perl_call_pv(const char *sub_name, I32 flags)
                        /* name of the subroutine */
                        /* See G_* flags in cop.h */
 {
@@ -1188,7 +1195,7 @@ perl_call_pv(char *sub_name, I32 flags)
 }
 
 I32
-perl_call_method(char *methname, I32 flags)
+perl_call_method(const char *methname, I32 flags)
                                /* name of the subroutine */
                        /* See G_* flags in cop.h */
 {
@@ -1437,7 +1444,7 @@ perl_eval_sv(SV *sv, I32 flags)
 }
 
 SV*
-perl_eval_pv(char *p, I32 croak_on_error)
+perl_eval_pv(const char *p, I32 croak_on_error)
 {
     dSP;
     SV* sv = newSVpv(p, 0);
@@ -1461,7 +1468,7 @@ perl_eval_pv(char *p, I32 croak_on_error)
 /* Require a module. */
 
 void
-perl_require_pv(char *pv)
+perl_require_pv(const char *pv)
 {
     SV* sv;
     dSP;
@@ -2112,6 +2119,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_GETMNTENT) && 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)
 {
@@ -2180,6 +2251,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);