Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[PATCH] Coverity: check for negative return values from/to library calls #13774

Closed
p5pRT opened this issue Apr 26, 2014 · 67 comments
Closed

[PATCH] Coverity: check for negative return values from/to library calls #13774

p5pRT opened this issue Apr 26, 2014 · 67 comments
Labels

Comments

@p5pRT
Copy link

p5pRT commented Apr 26, 2014

Migrated from rt.perl.org#121743 (status was 'resolved')

Searchable as RT121743$

@p5pRT
Copy link
Author

p5pRT commented Apr 26, 2014

From @jhi

Dozens of too trusting fileno calls (and then using the returned fds for
fstat etc.), plus two similar cases for getgroups().

Attached.

@p5pRT
Copy link
Author

p5pRT commented Apr 26, 2014

From @jhi

0001-Fix-for-Coverity-perl5-CIDs-28990.29003-29005.29011-.patch
From c0b207e73c8a503a10759b56243fc02cb43fdbfb Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Wed, 23 Apr 2014 17:43:15 -0400
Subject: [PATCH] Fix for Coverity perl5 CIDs 28990..29003,29005..29011,29013:
 Argument cannot be negative (NEGATIVE_RETURNS) fd is passed to a parameter
 that cannot be negative.

and CIDs 29004, 29012:
Argument cannot be negative (NEGATIVE_RETURNS)
num_groups is passed to a parameter that cannot be negative

and because of CIDs 29005 and 29006 also CID 28924.

In the first set of issues a fd is retrieved from PerlIO_fileno, and
that is then used in places like fstat(), fchown(), dup(), etc.,
without checking whether the fd is valid (>=0).

In the second set of issues a potentially negative
number is potentially passed to getgroups().

The CIDs 29005 and 29006 were a bit messy: fixing them needed also
resolving CID 28924 where the return value of fstat() was ignored,
and for completeness adding two croak calls (with perldiag updates):
a bit of a waste since it's suidperl code.
---
 dist/IO/IO.xs           |  12 ++++--
 doio.c                  |  81 +++++++++++++++++++++++-------------
 ext/PerlIO-mmap/mmap.xs |   5 ++-
 mg.c                    |  15 ++++---
 perl.c                  |  31 +++++++++-----
 perlio.c                |  16 +++++++-
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 106 +++++++++++++++++++++++++++++++++---------------
 util.c                  |  13 +++---
 9 files changed, 194 insertions(+), 89 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..d7fe0a0 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -524,9 +524,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
diff --git a/doio.c b/doio.c
index e2bfda5..0dfbf1b 100644
--- a/doio.c
+++ b/doio.c
@@ -646,6 +646,8 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
+    if (fd < 0)
+        goto say_false;
     /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
      * socket - this covers PerlIO::scalar - otherwise unless we "know" the
      * type probe for socket-ness.
@@ -732,13 +734,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -956,23 +968,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1183,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1394,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1760,10 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd >= 0 && fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1797,9 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+			if (fd >= 0 && fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1988,9 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+			if (fd >= 0 && futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2105,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) { 
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..c96e4ff 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,11 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..925da89 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,17 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        fcntl(fd, F_SETFD, 1);
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3838,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak("Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak("Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index 0ae0a43..83c8463 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2922,6 +2922,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2930,8 +2934,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3667,6 +3675,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 00700c5..b7c1942 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..96a444f 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1616,7 +1616,7 @@ PP(pp_sysread)
     char *buffer;
     STRLEN orig_size;
     SSize_t length;
-    SSize_t count;
+    SSize_t count = -1;
     SV *bufsv;
     STRLEN blen;
     int fp_utf8;
@@ -1682,6 +1682,9 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        int fd = PerlIO_fileno(IoIFP(io));
+        if (fd < 0)
+	    RETPUSHUNDEF;
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1696,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1771,8 +1774,10 @@ PP(pp_sysread)
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            int fd = PerlIO_fileno(IoIFP(io));
+            if (fd >= 0) { 
+                count = PerlLIO_read(fd, buffer, length);
+            }
 	}
     }
     else
@@ -1848,7 +1853,7 @@ PP(pp_syswrite)
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
     SV *bufsv;
     const char *buffer;
-    SSize_t retval;
+    SSize_t retval = -1;
     STRLEN blen;
     STRLEN orig_blen_bytes;
     const int op_type = PL_op->op_type;
@@ -1856,6 +1861,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1915,17 +1921,19 @@ PP(pp_syswrite)
     }
 
 #ifdef HAS_SOCKET
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto say_undef;
     if (op_type == OP_SEND) {
 	const int flags = SvIVx(*++MARK);
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2016,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2230,16 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd >= 0) {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2467,16 +2476,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2608,6 +2621,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2698,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts2;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2781,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                        } else {
+                            PL_laststatval = 
+                                PerlLIO_fstat(fd, &PL_statcache);   
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3278,11 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0)
+	FT_RETURNUNDEF;
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3331,13 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0)
+		FT_RETURNUNDEF;
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3367,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,7 +3387,12 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
 	    FT_RETURNUNDEF;
@@ -3475,19 +3509,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3534,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
diff --git a/util.c b/util.c
index 0a0ee40..17be9a5 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,14 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd >= 0) { 
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented Apr 26, 2014

From @jhi

Attached.

@p5pRT
Copy link
Author

p5pRT commented Apr 26, 2014

From @jhi

0001-Fix-for-Coverity-perl5-CIDs-29813-29814-29819-29821..patch
From 9b4739a6f95d91657d94e249f08d03cff6cb1a1d Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 24 Apr 2014 12:10:44 -0400
Subject: [PATCH] Fix for Coverity perl5 CIDs 29813, 29814, 29819,29821..29823,
 28930: Unchecked return value from library (CHECKED_RETURN) check_return:
 Calling fcntl(...) without checking return value.

and CID 29820:
Unchecked return value from library (CHECKED_RETURN)
check_return: Calling fgetc(...) without checking return value.

The fcntl() calls are doing FD_SETFD (for fds larger than PL_maxsysfd)
and FD_CLOEXEC. It is debatable whether these failing are serious
enough offenses to return undef (or otherwise fail), but this patch
makes it so, and no tests start failing.
---
 doio.c   |  3 ++-
 perlio.c |  4 ++--
 pp_sys.c | 21 ++++++++++++++-------
 util.c   |  6 ++++--
 4 files changed, 22 insertions(+), 12 deletions(-)

diff --git a/doio.c b/doio.c
index e2bfda5..c4415cf 100644
--- a/doio.c
+++ b/doio.c
@@ -755,7 +755,8 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
 	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	if (fcntl(fd,F_SETFD,fd > PL_maxsysfd) < 0) /* can change errno */
+            goto say_false;
 	RESTORE_ERRNO;
     }
 #endif
diff --git a/perlio.c b/perlio.c
index 0ae0a43..375911f 100644
--- a/perlio.c
+++ b/perlio.c
@@ -3350,8 +3350,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..abfee72 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -2400,7 +2402,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2448,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2554,7 +2559,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -4194,7 +4200,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..b8524a8 100644
--- a/util.c
+++ b/util.c
@@ -2308,7 +2308,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2454,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @tonycoz

On Sat Apr 26 12​:58​:05 2014, jhi wrote​:

Dozens of too trusting fileno calls (and then using the returned fds for
fstat etc.), plus two similar cases for getgroups().

Attached.

Fails to build with -Duseithreads due to missing aTHX_ in​:

  if (fd < 0) {
  Perl_croak("Illegal suidscript");
  } else {
  if (PerlLIO_fstat(fd, &PL_statbuf) < 0) { /* may be either wrapped or real suid */
  Perl_croak("Illegal suidscript");
  }
  }

Some other issues, the original code here for example (doio.c)​:

@​@​ -1775,8 +1797,9 @​@​ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
  if ((gv = MAYBE_DEREF_GV(*mark))) {
  if (GvIO(gv) && IoIFP(GvIOp(gv))) {
#ifdef HAS_FCHOWN
+ int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
  APPLY_TAINT_PROPER();
- if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+ if (fd >= 0 && fchown(fd, val, val2))
  tot--;
#else
  Perl_die(aTHX_ PL_no_func, "fchown");

will sensibly set errno to EBADF when fchown() fails, but the modified code doesn't.

Similarly for the others in Perl_apply(), pp_sysread(), pp_syswrite(), pp_truncate(), pp_getpeername(), pp_stat(), pp_fttty(), pp_fttext() and possibly for PerlIO​::mmap.

Tony

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @tonycoz

On Sat Apr 26 13​:01​:39 2014, jhi wrote​:

Attached.

--- a/doio.c
+++ b/doio.c
@​@​ -755,7 +755,8 @​@​ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
#if defined(HAS_FCNTL) && defined(F_SETFD)
  if (fd >= 0) {
  dSAVE_ERRNO;
- fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+ if (fcntl(fd,F_SETFD,fd > PL_maxsysfd) < 0) /* can change errno */
+ goto say_false;
  RESTORE_ERRNO;
  }
#endif

Should this PerlIO_close() the handle before C< goto say_false > ?

I suspect we should be using FD_CLOEXEC in a few other places, but that's not made any worse by your patch.

Tony

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @jhi

On Sunday-201404-27, 23​:48, Tony Cook via RT wrote​:

On Sat Apr 26 13​:01​:39 2014, jhi wrote​:

Attached.

--- a/doio.c
+++ b/doio.c
@​@​ -755,7 +755,8 @​@​ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (fd >= 0) {
dSAVE_ERRNO;
- fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+ if (fcntl(fd,F_SETFD,fd > PL_maxsysfd) < 0) /* can change errno */
+ goto say_false;
RESTORE_ERRNO;
}
#endif

Should this PerlIO_close() the handle before C< goto say_false > ?

Refreshed patch attached. (Also now doing the RESTORE_ERRNO before that
goto say_false.)

Regarding SAVE/RESTORE_ERRNO​: I am of two strongly conflicting minds...

(1) is that really worth the dance? we stomp all over it all over the
place, we rarely (if ever) do only once syscall/libcall whatever we do,
so the errno is mostly bogus anyway...

(2) we should be doing the dance in much more regimented way so that the
errno would be more reliable.

And then there's of course my more blue-sky mind thinking that the
return values from such things should be dual (or more) value, so that
it would be e.g. (pseudocode, not really a hashref)

  { bool => undef, I32 => ENOENT, ... }

That is, the reason for failure would be embedded in the return value.
And we could obsolete $! altogether... though of course we could never
deprecate it. Sigh.

I suspect we should be using FD_CLOEXEC in a few other places, but that's not made any worse by your patch.

Yeah. The FD_CLOEXEC seems to be common thing to do whenever acquiring
more fds, it probably should be wrapped into a routine.

Tony

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @jhi

0001-Fix-for-Coverity-perl5-CIDs-29813-29814-29819-29821..patch
From fa18b49cc3cc3cbc5006b12f43011227d99b8c74 Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 24 Apr 2014 12:10:44 -0400
Subject: [PATCH] Fix for Coverity perl5 CIDs 29813, 29814, 29819,29821..29823,
 28930: Unchecked return value from library (CHECKED_RETURN) check_return:
 Calling fcntl(...) without checking return value.

and CID 29820:
Unchecked return value from library (CHECKED_RETURN)
check_return: Calling fgetc(...) without checking return value.

The fcntl() calls are doing FD_SETFD (for fds larger than PL_maxsysfd)
and FD_CLOEXEC. It is debatable whether these failing are serious
enough offenses to return undef (or otherwise fail), but this patch
makes it so, and no tests start failing.
---
 doio.c   |  6 +++++-
 perlio.c |  4 ++--
 pp_sys.c | 21 ++++++++++++++-------
 util.c   |  6 ++++--
 4 files changed, 25 insertions(+), 12 deletions(-)

diff --git a/doio.c b/doio.c
index e2bfda5..2bcdbb9 100644
--- a/doio.c
+++ b/doio.c
@@ -755,8 +755,12 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
 	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 	RESTORE_ERRNO;
+        if (rc < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
diff --git a/perlio.c b/perlio.c
index 0ae0a43..375911f 100644
--- a/perlio.c
+++ b/perlio.c
@@ -3350,8 +3350,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..abfee72 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -2400,7 +2402,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2448,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2554,7 +2559,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -4194,7 +4200,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..b8524a8 100644
--- a/util.c
+++ b/util.c
@@ -2308,7 +2308,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2454,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @jhi

will sensibly set errno to EBADF when fchown() fails, but the modified code doesn't.

Similarly for the others in Perl_apply(), pp_sysread(), pp_syswrite(), pp_truncate(), pp_getpeername(), pp_stat(), pp_fttty(), pp_fttext() and possibly for PerlIO​::mmap.

Yeah. Amended the patch to set EBADF when applicable.

Also now getting failures from tests, will see what's up with them.
Better hold off on this until the dust settles.

Tony

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @jhi

will sensibly set errno to EBADF when fchown() fails, but the
modified code doesn't.

I now explictly set errno to EBADF if fd is zero (if necessary, some
places have their own "failure goto" that sets errno), and return
-1/undef/failure goto, and do not even attempt the fchown() etc. That
seemed saner than letting e.g. fchown() on a bad fd first happen and
then setting errno to EBADF if the fd was bad.

Also now getting failures from tests, will see what's up with them.

One stray "goto failure;" too many broke PerlIO​::scalar. Now passing
all tests. Refreshed patch attached.

Better hold off on this until the dust settles.

@p5pRT
Copy link
Author

p5pRT commented Apr 28, 2014

From @jhi

0001-Fix-for-Coverity-perl5-CIDs-28990.29003-29005.29011-.patch
From 5c22c14b9f4e61ae885182da2e0a12420849d3a6 Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Wed, 23 Apr 2014 17:43:15 -0400
Subject: [PATCH] Fix for Coverity perl5 CIDs 28990..29003,29005..29011,29013:
 Argument cannot be negative (NEGATIVE_RETURNS) fd is passed to a parameter
 that cannot be negative.

and CIDs 29004, 29012:
Argument cannot be negative (NEGATIVE_RETURNS)
num_groups is passed to a parameter that cannot be negative

and because of CIDs 29005 and 29006 also CID 28924.

In the first set of issues a fd is retrieved from PerlIO_fileno, and
that is then used in places like fstat(), fchown(), dup(), etc.,
without checking whether the fd is valid (>=0).

In the second set of issues a potentially negative
number is potentially passed to getgroups().

The CIDs 29005 and 29006 were a bit messy: fixing them needed also
resolving CID 28924 where the return value of fstat() was ignored,
and for completeness adding two croak calls (with perldiag updates):
a bit of a waste since it's suidperl code.
---
 dist/IO/IO.xs           |  12 +++--
 doio.c                  |  94 +++++++++++++++++++++++------------
 ext/PerlIO-mmap/mmap.xs |   6 ++-
 mg.c                    |  15 +++---
 perl.c                  |  31 ++++++++----
 perlio.c                |  16 +++++-
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 128 ++++++++++++++++++++++++++++++++++--------------
 util.c                  |  15 +++---
 9 files changed, 226 insertions(+), 95 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..d7fe0a0 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -524,9 +524,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
diff --git a/doio.c b/doio.c
index e2bfda5..7dd4f79 100644
--- a/doio.c
+++ b/doio.c
@@ -646,9 +646,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
-     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
-     * type probe for socket-ness.
+    /* Do NOT do: "if (fd < 0) goto say_false;" here.  If there is no
+     * fd assume it isn't a socket - this covers PerlIO::scalar -
+     * otherwise unless we "know" the type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 	if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
@@ -732,13 +732,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -956,23 +966,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1181,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1392,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1758,13 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+                        } else if (fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1798,12 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+			    tot--;
+                        } else if (fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1992,12 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+			} else if (futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2112,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) { 
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..6632544 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          SETERRNO(EBADF,RMS_IFI);
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..4dd4821 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,17 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        fcntl(fd, F_SETFD, 1);
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3838,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index 0ae0a43..83c8463 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2922,6 +2922,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2930,8 +2934,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3667,6 +3675,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 00700c5..b7c1942 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..40464bb 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1616,7 +1616,7 @@ PP(pp_sysread)
     char *buffer;
     STRLEN orig_size;
     SSize_t length;
-    SSize_t count;
+    SSize_t count = -1;
     SV *bufsv;
     STRLEN blen;
     int fp_utf8;
@@ -1682,6 +1682,11 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        int fd = PerlIO_fileno(IoIFP(io));
+        if (fd < 0) {
+            SETERRNO(EBADF,RMS_IFI);
+	    RETPUSHUNDEF;
+        }
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1698,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1771,8 +1776,11 @@ PP(pp_sysread)
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            int fd = PerlIO_fileno(IoIFP(io));
+            if (fd < 0)
+                SETERRNO(EBADF,RMS_IFI);
+            else
+                count = PerlLIO_read(fd, buffer, length);
 	}
     }
     else
@@ -1848,7 +1856,7 @@ PP(pp_syswrite)
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
     SV *bufsv;
     const char *buffer;
-    SSize_t retval;
+    SSize_t retval = -1;
     STRLEN blen;
     STRLEN orig_blen_bytes;
     const int op_type = PL_op->op_type;
@@ -1856,6 +1864,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1915,17 +1924,21 @@ PP(pp_syswrite)
     }
 
 #ifdef HAS_SOCKET
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0) {
+        SETERRNO(EBADF,SS_IVCHAN);
+        goto say_undef;
+    }
     if (op_type == OP_SEND) {
 	const int flags = SvIVx(*++MARK);
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2021,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2235,18 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd < 0)
+                        SETERRNO(EBADF,RMS_IFI);
+                    else {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2248,9 +2264,10 @@ PP(pp_truncate)
 	    {
 		const int tmpfd = PerlLIO_open(name, O_RDWR);
 
-		if (tmpfd < 0)
+		if (tmpfd < 0) {
+                    SETERRNO(EBADF,RMS_IFI);
 		    result = 0;
-		else {
+		} else {
 		    if (my_chsize(tmpfd, len) < 0)
 		        result = 0;
 		    PerlLIO_close(tmpfd);
@@ -2388,8 +2405,10 @@ PP(pp_socket)
 
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
-    if (fd < 0)
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
+    }
     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);	/* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
     IoTYPE(io) = IoTYPE_SOCKET;
@@ -2467,16 +2486,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2608,6 +2631,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2708,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2791,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                            SETERRNO(EBADF,RMS_IFI);
+                        } else {
+                            PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3288,13 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
+	FT_RETURNUNDEF;
+    }
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3343,15 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		FT_RETURNUNDEF;
+            }
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3381,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,9 +3401,16 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
 	    FT_RETURNUNDEF;
 	}
 	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
@@ -3475,19 +3525,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3550,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
diff --git a/util.c b/util.c
index 0a0ee40..cfb2ecc 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,16 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd < 0)
+        SETERRNO(EBADF,RMS_IFI);
+    else {
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @bulk88

On Sat Apr 26 12​:58​:05 2014, jhi wrote​:

Dozens of too trusting fileno calls (and then using the returned fds for
fstat etc.), plus two similar cases for getgroups().

Attached.

Why this isn't a horrible perf degradation?

--
bulk88 ~ bulk88 at hotmail.com

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @bulk88

It seems this patch changes user visible behavior, when previously true was returned, is now undef. What are the pros and cons of this?

--
bulk88 ~ bulk88 at hotmail.com

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @jhi

On Wednesday-201404-30, 1​:23, bulk88 via RT wrote​:

Why this isn't a horrible perf degradation?

Huh? Before​:

fileno was called
it returned -1
fstat (e.g.) was called on the -1
it failed because of the bogus fd
(hopefully) checked for fstat failing and returned undef/false/whatever

After​:
fileno was called
it returned -1
we test against the -1 and if so return undef/false/whatever
if we are still here, we call fstat (e.g.)
(hopefully) checked for fstat failing and returned undef/false/whatever

(Above showing only the failure paths, not success paths.)

So it's an earlier return in case we are fed broken fds.

The only extra I see is one extra test against the returned fd. I don't
think that's going to kill us.

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @jhi

On Wednesday-201404-30, 1​:31, bulk88 via RT wrote​:

It seems this patch changes user visible behavior, when previously true was returned, is now undef. What are the pros and cons of this?

Could you be more detailed? Where is the user visible behavior changed?
  That was not the intention. If there's a change, there should not be.

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @bulk88

On Wed Apr 30 03​:43​:33 2014, jhi wrote​:

On Wednesday-201404-30, 1​:31, bulk88 via RT wrote​:

It seems this patch changes user visible behavior, when previously
true was returned, is now undef. What are the pros and cons of this?

Could you be more detailed? Where is the user visible behavior
changed?
That was not the intention. If there's a change, there should not
be.

pp_socket currently


  if (!IoIFP(io) || !IoOFP(io)) {
  if (IoIFP(io)) PerlIO_close(IoIFP(io));
  if (IoOFP(io)) PerlIO_close(IoOFP(io));
  if (!IoIFP(io) && !IoOFP(io)) PerlLIO_close(fd);
  RETPUSHUNDEF;
  }
#if defined(HAS_FCNTL) && defined(F_SETFD)
  fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
#endif

  RETPUSHYES;
}
#endif


Your patch is


@​@​ -2400,7 +2402,8 @​@​ PP(pp_socket)
  RETPUSHUNDEF;
  }
#if defined(HAS_FCNTL) && defined(F_SETFD)
- fcntl(fd, F_SETFD, fd > PL_maxsysfd); /* ensure close-on-exec */
+ if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) /* ensure close-on-exec */
+ RETPUSHUNDEF;
#endif


Previously, if fnctl executed, regardless if it failed, the functioned returned SV * YES/true. Now it might in some rare condition (IDK what it would be, can someone give an example why PerlIO_fdopen would succeed but fnctl fail later?) return undef. On the otherhand, P5P has failed to documented the return value of socket() since forever http​://perl5.git.perl.org/perl.git/blob/HEAD​:/pod/perlfunc.pod#l6569 (I'd file a bug but dont have time to go hunting for all other retval not doced in perlfunc cases ATM).

I picked pp_socket above since it was the easiest one to write up.

Also, I'm not a *nix person, why do we call F_SETFD with "fd > PL_maxsysfd" instead of a proper C constant, optimization? will the constant always be 1?

--
bulk88 ~ bulk88 at hotmail.com

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @jhi

On Wednesday-201404-30, 16​:06, bulk88 via RT wrote​:

Previously, if fnctl executed, regardless if it failed, the functioned returned SV * YES/true. Now it might in some rare condition (IDK what it would be, can someone give an example why PerlIO_fdopen would succeed but fnctl fail later?) return undef. On the otherhand, P5P has failed to documented the return value of socket() since foreverhttp​://perl5.git.perl.org/perl.git/blob/HEAD​:/pod/perlfunc.pod#l6569 (I'd file a bug but dont have time to go hunting for all other retval not doced in perlfunc cases ATM).

Ahh, I see what you mean. Well, this is kind of fuzzy area... if you
look just before the fcntl dance, if the fps were dubious (either we
internally messed up something, or if the app messed up its logic, it
e.g. closed the handle), we did (and do) return undef.

So I extended that "if the file handle is dubious" logic to include also
the fcntl failure. (Here and elsewhere in the patch.)

Also, I'm not a *nix person, why do we call F_SETFD with "fd >
PL_maxsysfd" instead of a proper C constant, optimization? will the
constant always be 1?

The PL_maxsysfd is initialized from #define MAXSYSFD which is by default
always two (covering stdin, stdout, stderr). So whether we F_SETFD
depends on whether the fd is beyond those. I think *officially* we
should be using for the third argument the FD_CLOEXEC (which is one) for
true (close-on-exec).

FWIW, we should probably use the O_CLOEXEC flag where available, when
getting the fd in the first place. I think it's only defined for
open(), not for e.g. socket() etc. which limits its usefulness.

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @Leont

On Wed, Apr 30, 2014 at 10​:47 PM, Jarkko Hietaniemi <jhi@​iki.fi> wrote​:

Also, I'm not a *nix person, why do we call F_SETFD with "fd >
PL_maxsysfd" instead of a proper C constant, optimization? will the
constant always be 1?

The PL_maxsysfd is initialized from #define MAXSYSFD which is by default
always two (covering stdin, stdout, stderr). So whether we F_SETFD depends
on whether the fd is beyond those. I think *officially* we should be using
for the third argument the FD_CLOEXEC (which is one) for true
(close-on-exec).

Technically yes, though I share the impression it's universally 1.

FWIW, we should probably use the O_CLOEXEC flag where available, when
getting the fd in the first place. I think it's only defined for open(),
not for e.g. socket() etc. which limits its usefulness.

AFAIK that's a Linuxism (though BSDs seem to be implementing it too now),
but it's definitely a good idea in multi-threaded situations (we have to
keep the fcntl to un-cloexec if fd < PL_maxsysfd though). And actually, it
is available for sockets by or-ing the socket type argument with
SOCK_CLOEXEC.

Leon

@p5pRT
Copy link
Author

p5pRT commented Apr 30, 2014

From @jhi

On Wednesday-201404-30, 17​:57, Leon Timmermans wrote​:

AFAIK that's a Linuxism (though BSDs seem to be implementing it too now)

It's Official, don't know exactly since when​:

http​://pubs.opengroup.org/onlinepubs/9699919799/functions/open.html

@p5pRT
Copy link
Author

p5pRT commented May 1, 2014

From @jhi

Yet again refreshed patch, found two more spots with the same
potentially negative fd use.

@p5pRT
Copy link
Author

p5pRT commented May 1, 2014

From @jhi

0001-Fix-for-Coverity-perl5-CIDs-28990.29003-29005.29011-.patch
From f883ae96667b0521489a69a57381a6d22f554bb0 Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Wed, 23 Apr 2014 17:43:15 -0400
Subject: [PATCH] Fix for Coverity perl5 CIDs 28990..29003,29005..29011,29013,
 45354,45363,49926: Argument cannot be negative (NEGATIVE_RETURNS) fd is
 passed to a parameter that cannot be negative.

and CIDs 29004, 29012:
Argument cannot be negative (NEGATIVE_RETURNS)
num_groups is passed to a parameter that cannot be negative

and because of CIDs 29005 and 29006 also CID 28924.

In the first set of issues a fd is retrieved from PerlIO_fileno, and
that is then used in places like fstat(), fchown(), dup(), etc.,
without checking whether the fd is valid (>=0).

In the second set of issues a potentially negative
number is potentially passed to getgroups().

The CIDs 29005 and 29006 were a bit messy: fixing them needed also
resolving CID 28924 where the return value of fstat() was ignored,
and for completeness adding two croak calls (with perldiag updates):
a bit of a waste since it's suidperl code.
---
 dist/IO/IO.xs           |  12 +++--
 dist/threads/threads.xs |   9 ++--
 doio.c                  |  99 +++++++++++++++++++++++++------------
 ext/PerlIO-mmap/mmap.xs |   6 ++-
 mg.c                    |  15 +++---
 perl.c                  |  31 ++++++++----
 perlio.c                |  16 +++++-
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 128 ++++++++++++++++++++++++++++++++++--------------
 util.c                  |  15 +++---
 10 files changed, 235 insertions(+), 100 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..d7fe0a0 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -524,9 +524,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 8537165..cfcf98b 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -713,11 +713,12 @@ S_ithread_create(
     }
     PERL_SET_CONTEXT(aTHX);
     if (!thread) {
-        int rc;
         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
-        rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                            PL_no_mem, strlen(PL_no_mem));
-        PERL_UNUSED_VAR(rc);
+        int fd = PerlIO_fileno(Perl_error_log);
+        if (fd < 0) {
+          int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+          PERL_UNUSED_VAR(rc);
+        }
         my_exit(1);
     }
     Zero(thread, 1, ithread);
diff --git a/doio.c b/doio.c
index e2bfda5..5268be3 100644
--- a/doio.c
+++ b/doio.c
@@ -646,9 +646,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
-     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
-     * type probe for socket-ness.
+    /* Do NOT do: "if (fd < 0) goto say_false;" here.  If there is no
+     * fd assume it isn't a socket - this covers PerlIO::scalar -
+     * otherwise unless we "know" the type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 	if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
@@ -696,7 +696,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	       is assigned to (say) STDOUT - for now let dup2() fail
 	       and provide the error
 	     */
-	    if (PerlLIO_dup2(fd, savefd) < 0) {
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		goto say_false;
+            } else if (PerlLIO_dup2(fd, savefd) < 0) {
 		(void)PerlIO_close(fp);
 		goto say_false;
 	    }
@@ -732,13 +735,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -956,23 +969,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1184,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1395,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1761,13 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+                        } else if (fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1801,12 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+			    tot--;
+                        } else if (fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1995,12 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+			} else if (futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2115,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) { 
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..6632544 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          SETERRNO(EBADF,RMS_IFI);
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..4dd4821 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,17 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        fcntl(fd, F_SETFD, 1);
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3838,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index 0ae0a43..83c8463 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2922,6 +2922,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2930,8 +2934,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3667,6 +3675,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 00700c5..b7c1942 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..40464bb 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1616,7 +1616,7 @@ PP(pp_sysread)
     char *buffer;
     STRLEN orig_size;
     SSize_t length;
-    SSize_t count;
+    SSize_t count = -1;
     SV *bufsv;
     STRLEN blen;
     int fp_utf8;
@@ -1682,6 +1682,11 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        int fd = PerlIO_fileno(IoIFP(io));
+        if (fd < 0) {
+            SETERRNO(EBADF,RMS_IFI);
+	    RETPUSHUNDEF;
+        }
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1698,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1771,8 +1776,11 @@ PP(pp_sysread)
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            int fd = PerlIO_fileno(IoIFP(io));
+            if (fd < 0)
+                SETERRNO(EBADF,RMS_IFI);
+            else
+                count = PerlLIO_read(fd, buffer, length);
 	}
     }
     else
@@ -1848,7 +1856,7 @@ PP(pp_syswrite)
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
     SV *bufsv;
     const char *buffer;
-    SSize_t retval;
+    SSize_t retval = -1;
     STRLEN blen;
     STRLEN orig_blen_bytes;
     const int op_type = PL_op->op_type;
@@ -1856,6 +1864,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1915,17 +1924,21 @@ PP(pp_syswrite)
     }
 
 #ifdef HAS_SOCKET
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0) {
+        SETERRNO(EBADF,SS_IVCHAN);
+        goto say_undef;
+    }
     if (op_type == OP_SEND) {
 	const int flags = SvIVx(*++MARK);
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2021,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2235,18 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd < 0)
+                        SETERRNO(EBADF,RMS_IFI);
+                    else {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2248,9 +2264,10 @@ PP(pp_truncate)
 	    {
 		const int tmpfd = PerlLIO_open(name, O_RDWR);
 
-		if (tmpfd < 0)
+		if (tmpfd < 0) {
+                    SETERRNO(EBADF,RMS_IFI);
 		    result = 0;
-		else {
+		} else {
 		    if (my_chsize(tmpfd, len) < 0)
 		        result = 0;
 		    PerlLIO_close(tmpfd);
@@ -2388,8 +2405,10 @@ PP(pp_socket)
 
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
-    if (fd < 0)
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
+    }
     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);	/* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
     IoTYPE(io) = IoTYPE_SOCKET;
@@ -2467,16 +2486,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2608,6 +2631,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2708,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2791,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                            SETERRNO(EBADF,RMS_IFI);
+                        } else {
+                            PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3288,13 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
+	FT_RETURNUNDEF;
+    }
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3343,15 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		FT_RETURNUNDEF;
+            }
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3381,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,9 +3401,16 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
 	    FT_RETURNUNDEF;
 	}
 	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
@@ -3475,19 +3525,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3550,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
diff --git a/util.c b/util.c
index 0a0ee40..cfb2ecc 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,16 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd < 0)
+        SETERRNO(EBADF,RMS_IFI);
+    else {
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 2, 2014

From @jhi

On Thursday-201405-01, 17​:05, Jarkko Hietaniemi wrote​:

Yet again refreshed patch, found two more spots with the same
potentially negative fd use.

And one more spot added (missed that a new Coverity scan had found
more). Also hopefully better "summary line" now.

@p5pRT
Copy link
Author

p5pRT commented May 2, 2014

From @jhi

0001-fcntl-and-fgetc-calls-unchecked-for-failure.patch
From 998ff75995abae05d829ac06d7c73a3af848ca9b Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 24 Apr 2014 12:10:44 -0400
Subject: [PATCH] fcntl and fgetc calls unchecked for failure.

Fix for Coverity perl5 CIDs 29813, 29814, 29819,29821..29823, 28930:
Unchecked return value from library (CHECKED_RETURN)
check_return: Calling fcntl(...) without checking return value.

and CID 29820:
Unchecked return value from library (CHECKED_RETURN)
check_return: Calling fgetc(...) without checking return value.

The fcntl() calls are doing FD_SETFD (for fds larger than PL_maxsysfd)
and FD_CLOEXEC. It is debatable whether these failing are serious
enough offenses to return undef (or otherwise fail), but this patch
makes it so, and no tests start failing.
---
 doio.c   |  6 +++++-
 perl.c   |  6 +++++-
 perlio.c |  4 ++--
 pp_sys.c | 21 ++++++++++++++-------
 util.c   |  6 ++++--
 5 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/doio.c b/doio.c
index e2bfda5..2bcdbb9 100644
--- a/doio.c
+++ b/doio.c
@@ -755,8 +755,12 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
 	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 	RESTORE_ERRNO;
+        if (rc < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
diff --git a/perl.c b/perl.c
index 27d0d9e..1efafe7 100644
--- a/perl.c
+++ b/perl.c
@@ -3798,7 +3798,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fcntl(PerlIO_fileno(rsfp), F_SETFD, 1) < 0) {
+        Perl_croak(aTHX_ "Can't open perl script \"%s\": "
+                   "fcntl close-on-exec failed\n",
+                   CopFILE(PL_curcop));
+    }
 #endif
 
     if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
diff --git a/perlio.c b/perlio.c
index 0ae0a43..375911f 100644
--- a/perlio.c
+++ b/perlio.c
@@ -3350,8 +3350,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..abfee72 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -2400,7 +2402,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2448,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2554,7 +2559,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -4194,7 +4200,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..b8524a8 100644
--- a/util.c
+++ b/util.c
@@ -2308,7 +2308,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2454,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 2, 2014

From @jhi

On Thursday-201405-01, 21​:06, Jarkko Hietaniemi wrote​:

On Thursday-201405-01, 17​:05, Jarkko Hietaniemi wrote​:

Yet again refreshed patch, found two more spots with the same
potentially negative fd use.

And one more spot added (missed that a new Coverity scan had found
more). Also hopefully better "summary line" now.

Argh. Please discard this very latest patch ("one more spot"), sorry
about that. I'm getting mixed up in my patches, too many in-flight.
The one with "two more spots" is the currently correct one for this
issue (not checking for negative return values).

@p5pRT
Copy link
Author

p5pRT commented May 2, 2014

From @jhi

Updated patch attached.

@p5pRT
Copy link
Author

p5pRT commented May 2, 2014

From @jhi

0001-fcntl-and-fgetc-calls-unchecked-for-failure.patch
From 998ff75995abae05d829ac06d7c73a3af848ca9b Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Thu, 24 Apr 2014 12:10:44 -0400
Subject: [PATCH] fcntl and fgetc calls unchecked for failure.

Fix for Coverity perl5 CIDs 29813, 29814, 29819,29821..29823, 28930:
Unchecked return value from library (CHECKED_RETURN)
check_return: Calling fcntl(...) without checking return value.

and CID 29820:
Unchecked return value from library (CHECKED_RETURN)
check_return: Calling fgetc(...) without checking return value.

The fcntl() calls are doing FD_SETFD (for fds larger than PL_maxsysfd)
and FD_CLOEXEC. It is debatable whether these failing are serious
enough offenses to return undef (or otherwise fail), but this patch
makes it so, and no tests start failing.
---
 doio.c   |  6 +++++-
 perl.c   |  6 +++++-
 perlio.c |  4 ++--
 pp_sys.c | 21 ++++++++++++++-------
 util.c   |  6 ++++--
 5 files changed, 30 insertions(+), 13 deletions(-)

diff --git a/doio.c b/doio.c
index e2bfda5..2bcdbb9 100644
--- a/doio.c
+++ b/doio.c
@@ -755,8 +755,12 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
 	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 	RESTORE_ERRNO;
+        if (rc < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
diff --git a/perl.c b/perl.c
index 27d0d9e..1efafe7 100644
--- a/perl.c
+++ b/perl.c
@@ -3798,7 +3798,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fcntl(PerlIO_fileno(rsfp), F_SETFD, 1) < 0) {
+        Perl_croak(aTHX_ "Can't open perl script \"%s\": "
+                   "fcntl close-on-exec failed\n",
+                   CopFILE(PL_curcop));
+    }
 #endif
 
     if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
diff --git a/perlio.c b/perlio.c
index 0ae0a43..375911f 100644
--- a/perlio.c
+++ b/perlio.c
@@ -3350,8 +3350,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..abfee72 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -2400,7 +2402,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2448,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2554,7 +2559,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -4194,7 +4200,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..b8524a8 100644
--- a/util.c
+++ b/util.c
@@ -2308,7 +2308,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2454,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 3, 2014

From @jhi

On Thursday-201405-01, 17​:05, Jarkko Hietaniemi wrote​:

Yet again refreshed patch, found two more spots with the same
potentially negative fd use.

I decided to merge this ticket with perl #121745 which checked for fcntl
failure paths, since there's a lot of functional overlap​:
(1) a fd from fileno being checked against < 0, and then
(2) the fd being fed to fcntl, the return value of which we want to
check for failure
(3) in one actual case of a merge conflict (in perl.c) because the
changes for these two checks were too close for comfort

So updated combined patch attached, and please ignore/merge #121745.

@p5pRT
Copy link
Author

p5pRT commented May 3, 2014

From @jhi

0001-Check-fileno-numgroups-1-check-fcntl-fgetc-failures.patch
From 199fd738e900d42cde4181d3a4a363532c0d6fea Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Fri, 2 May 2014 22:12:24 -0400
Subject: [PATCH] Check fileno/numgroups -1, check fcntl (+fgetc) failures.

(merged fix for perl #121743 and perl #121745)
---
 dist/IO/IO.xs           |  12 +++-
 dist/threads/threads.xs |   9 +--
 doio.c                  | 105 +++++++++++++++++++++++-----------
 ext/PerlIO-mmap/mmap.xs |   6 +-
 mg.c                    |  15 +++--
 perl.c                  |  35 ++++++++----
 perlio.c                |  20 +++++--
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 149 ++++++++++++++++++++++++++++++++++--------------
 util.c                  |  21 ++++---
 10 files changed, 264 insertions(+), 112 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..d7fe0a0 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -524,9 +524,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 8537165..cfcf98b 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -713,11 +713,12 @@ S_ithread_create(
     }
     PERL_SET_CONTEXT(aTHX);
     if (!thread) {
-        int rc;
         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
-        rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                            PL_no_mem, strlen(PL_no_mem));
-        PERL_UNUSED_VAR(rc);
+        int fd = PerlIO_fileno(Perl_error_log);
+        if (fd < 0) {
+          int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+          PERL_UNUSED_VAR(rc);
+        }
         my_exit(1);
     }
     Zero(thread, 1, ithread);
diff --git a/doio.c b/doio.c
index e2bfda5..26c0032 100644
--- a/doio.c
+++ b/doio.c
@@ -646,9 +646,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
-     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
-     * type probe for socket-ness.
+    /* Do NOT do: "if (fd < 0) goto say_false;" here.  If there is no
+     * fd assume it isn't a socket - this covers PerlIO::scalar -
+     * otherwise unless we "know" the type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 	if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
@@ -696,7 +696,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	       is assigned to (say) STDOUT - for now let dup2() fail
 	       and provide the error
 	     */
-	    if (PerlLIO_dup2(fd, savefd) < 0) {
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		goto say_false;
+            } else if (PerlLIO_dup2(fd, savefd) < 0) {
 		(void)PerlIO_close(fp);
 		goto say_false;
 	    }
@@ -732,13 +735,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -755,8 +768,12 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
 	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 	RESTORE_ERRNO;
+        if (rc < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
@@ -956,23 +973,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1188,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1399,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1765,13 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+                        } else if (fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1805,12 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+			    tot--;
+                        } else if (fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1999,12 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+			} else if (futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2119,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) {
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..6632544 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          SETERRNO(EBADF,RMS_IFI);
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..6d38f8f 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,21 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        if (fcntl(PerlIO_fileno(rsfp), F_SETFD, 1) < 0) {
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": "
+                       "fcntl close-on-exec failed\n",
+                       CopFILE(PL_curcop));
+        }
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3842,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index d4c43d0..4b98f6b 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2923,6 +2923,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2931,8 +2935,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3351,8 +3359,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
@@ -3668,6 +3676,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index bca95e2..df23cd3 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..9ee7850 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -1616,7 +1618,7 @@ PP(pp_sysread)
     char *buffer;
     STRLEN orig_size;
     SSize_t length;
-    SSize_t count;
+    SSize_t count = -1;
     SV *bufsv;
     STRLEN blen;
     int fp_utf8;
@@ -1682,6 +1684,11 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        int fd = PerlIO_fileno(IoIFP(io));
+        if (fd < 0) {
+            SETERRNO(EBADF,RMS_IFI);
+	    RETPUSHUNDEF;
+        }
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1700,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1771,8 +1778,11 @@ PP(pp_sysread)
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            int fd = PerlIO_fileno(IoIFP(io));
+            if (fd < 0)
+                SETERRNO(EBADF,RMS_IFI);
+            else
+                count = PerlLIO_read(fd, buffer, length);
 	}
     }
     else
@@ -1848,7 +1858,7 @@ PP(pp_syswrite)
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
     SV *bufsv;
     const char *buffer;
-    SSize_t retval;
+    SSize_t retval = -1;
     STRLEN blen;
     STRLEN orig_blen_bytes;
     const int op_type = PL_op->op_type;
@@ -1856,6 +1866,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1915,17 +1926,21 @@ PP(pp_syswrite)
     }
 
 #ifdef HAS_SOCKET
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0) {
+        SETERRNO(EBADF,SS_IVCHAN);
+        goto say_undef;
+    }
     if (op_type == OP_SEND) {
 	const int flags = SvIVx(*++MARK);
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2023,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2237,18 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd < 0)
+                        SETERRNO(EBADF,RMS_IFI);
+                    else {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2248,9 +2266,10 @@ PP(pp_truncate)
 	    {
 		const int tmpfd = PerlLIO_open(name, O_RDWR);
 
-		if (tmpfd < 0)
+		if (tmpfd < 0) {
+                    SETERRNO(EBADF,RMS_IFI);
 		    result = 0;
-		else {
+		} else {
 		    if (my_chsize(tmpfd, len) < 0)
 		        result = 0;
 		    PerlLIO_close(tmpfd);
@@ -2388,8 +2407,10 @@ PP(pp_socket)
 
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
-    if (fd < 0)
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
+    }
     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);	/* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
     IoTYPE(io) = IoTYPE_SOCKET;
@@ -2400,7 +2421,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2467,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2467,16 +2491,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2554,7 +2582,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -2608,6 +2637,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2714,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2797,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                            SETERRNO(EBADF,RMS_IFI);
+                        } else {
+                            PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3294,13 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
+	FT_RETURNUNDEF;
+    }
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3349,15 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		FT_RETURNUNDEF;
+            }
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3387,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,9 +3407,16 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
 	    FT_RETURNUNDEF;
 	}
 	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
@@ -3475,19 +3531,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3556,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
@@ -4194,7 +4256,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..343bf72 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,16 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd < 0)
+        SETERRNO(EBADF,RMS_IFI);
+    else {
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
@@ -2308,7 +2311,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2457,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @jhi

0001-Check-fileno-numgroups-1-check-fcntl-fgetc-failures.patch
From 28be09767a365f0cc924eb0870fce37c812897fd Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Fri, 2 May 2014 22:12:24 -0400
Subject: [PATCH] Check fileno/numgroups -1, check fcntl (+fgetc) failures.

(merged fix for perl #121743 and perl #121745)
---
 dist/IO/IO.xs           |  12 +++-
 dist/threads/threads.xs |  10 +--
 doio.c                  | 105 ++++++++++++++++++++++----------
 ext/PerlIO-mmap/mmap.xs |   6 +-
 mg.c                    |  15 +++--
 perl.c                  |  34 ++++++++---
 perlio.c                |  20 ++++--
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 158 ++++++++++++++++++++++++++++++++++--------------
 util.c                  |  21 ++++---
 10 files changed, 271 insertions(+), 114 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..d7fe0a0 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -524,9 +524,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EINVAL;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 8537165..90c61ff 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -713,11 +713,13 @@ S_ithread_create(
     }
     PERL_SET_CONTEXT(aTHX);
     if (!thread) {
-        int rc;
         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
-        rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                            PL_no_mem, strlen(PL_no_mem));
-        PERL_UNUSED_VAR(rc);
+        int fd = PerlIO_fileno(Perl_error_log);
+        if (fd >= 0) {
+          /* If there's no error_log, we cannot scream about it missing. */
+          int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+          PERL_UNUSED_VAR(rc);
+        }
         my_exit(1);
     }
     Zero(thread, 1, ithread);
diff --git a/doio.c b/doio.c
index e2bfda5..26c0032 100644
--- a/doio.c
+++ b/doio.c
@@ -646,9 +646,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
-     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
-     * type probe for socket-ness.
+    /* Do NOT do: "if (fd < 0) goto say_false;" here.  If there is no
+     * fd assume it isn't a socket - this covers PerlIO::scalar -
+     * otherwise unless we "know" the type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 	if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
@@ -696,7 +696,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	       is assigned to (say) STDOUT - for now let dup2() fail
 	       and provide the error
 	     */
-	    if (PerlLIO_dup2(fd, savefd) < 0) {
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		goto say_false;
+            } else if (PerlLIO_dup2(fd, savefd) < 0) {
 		(void)PerlIO_close(fp);
 		goto say_false;
 	    }
@@ -732,13 +735,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -755,8 +768,12 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
 	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+	int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
 	RESTORE_ERRNO;
+        if (rc < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
@@ -956,23 +973,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1188,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1399,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1765,13 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+                        } else if (fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1805,12 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+			    tot--;
+                        } else if (fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1999,12 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+			} else if (futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2119,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) {
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..6632544 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          SETERRNO(EBADF,RMS_IFI);
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..452bc63 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        if (fcntl(fd, F_SETFD, 1) < 0) {
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+                       CopFILE(PL_curcop), Strerror(errno));
+        }
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3841,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index d4c43d0..4b98f6b 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2923,6 +2923,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2931,8 +2935,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3351,8 +3359,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
@@ -3668,6 +3676,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index bca95e2..df23cd3 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..ef64829 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -1627,8 +1629,9 @@ PP(pp_sysread)
     bool charstart = FALSE;
     STRLEN charskip = 0;
     STRLEN skip = 0;
-
     GV * const gv = MUTABLE_GV(*++MARK);
+    int fd;
+
     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
 	&& gv && (io = GvIO(gv)) )
     {
@@ -1659,6 +1662,8 @@ PP(pp_sysread)
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
+    /* Note that fd can here validly be -1, don't check it yet. */
+    fd = PerlIO_fileno(IoIFP(io));
     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
 	buffer = SvPVutf8_force(bufsv, blen);
 	/* UTF-8 may not have been set if they are all low bytes */
@@ -1682,6 +1687,10 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        if (fd < 0) {
+            SETERRNO(EBADF,SS_IVCHAN);
+            RETPUSHUNDEF;
+        }
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1702,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1735,6 +1744,7 @@ PP(pp_sysread)
 	else
 	    offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
     }
+
  more_bytes:
     orig_size = SvCUR(bufsv);
     /* Allocating length + offset + 1 isn't perfect in the case of reading
@@ -1765,14 +1775,18 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_SYSREAD) {
 #ifdef PERL_SOCK_SYSREAD_IS_RECV
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+            if (fd < 0)
+                SETERRNO(EBADF,SS_IVCHAN);
+            else
+                count = PerlSock_recv(fd, length, 0);
 	}
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            if (fd < 0)
+                SETERRNO(EBADF,RMS_IFI);
+            else
+                count = PerlLIO_read(fd, buffer, length);
 	}
     }
     else
@@ -1848,7 +1862,7 @@ PP(pp_syswrite)
     dVAR; dSP; dMARK; dORIGMARK; dTARGET;
     SV *bufsv;
     const char *buffer;
-    SSize_t retval;
+    SSize_t retval = -1;
     STRLEN blen;
     STRLEN orig_blen_bytes;
     const int op_type = PL_op->op_type;
@@ -1856,6 +1870,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1886,6 +1901,11 @@ PP(pp_syswrite)
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0) {
+        SETERRNO(EBADF,SS_IVCHAN);
+        goto say_undef;
+    }
 
     /* Do this first to trigger any overloading.  */
     buffer = SvPV_const(bufsv, blen);
@@ -1920,12 +1940,11 @@ PP(pp_syswrite)
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2027,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2241,19 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd < 0) {
+                        SETERRNO(EBADF,RMS_IFI);
+                        result = 0;
+                    } else {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2248,9 +2271,10 @@ PP(pp_truncate)
 	    {
 		const int tmpfd = PerlLIO_open(name, O_RDWR);
 
-		if (tmpfd < 0)
+		if (tmpfd < 0) {
+                    SETERRNO(EBADF,RMS_IFI);
 		    result = 0;
-		else {
+		} else {
 		    if (my_chsize(tmpfd, len) < 0)
 		        result = 0;
 		    PerlLIO_close(tmpfd);
@@ -2388,8 +2412,10 @@ PP(pp_socket)
 
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
-    if (fd < 0)
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
+    }
     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);	/* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
     IoTYPE(io) = IoTYPE_SOCKET;
@@ -2400,7 +2426,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2472,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2467,16 +2496,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2554,7 +2587,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -2608,6 +2642,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2719,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2802,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                            SETERRNO(EBADF,RMS_IFI);
+                        } else {
+                            PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3299,13 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
+	FT_RETURNUNDEF;
+    }
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3354,15 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		FT_RETURNUNDEF;
+            }
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3392,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,9 +3412,16 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
 	    FT_RETURNUNDEF;
 	}
 	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
@@ -3475,19 +3536,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3561,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
@@ -4194,7 +4261,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..343bf72 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,16 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd < 0)
+        SETERRNO(EBADF,RMS_IFI);
+    else {
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
@@ -2308,7 +2311,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2457,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @Hugmeir

On Mon, May 5, 2014 at 3​:13 PM, Jarkko Hietaniemi <jhi@​iki.fi> wrote​:

Refreshed patch attached.

Sigh. This is getting annoying. Too many damn code paths. One more spot
fixed, in perl.c (if we already did fd=fileno, let's use the fd...)
Attached.

(<old_grumpy_man>And running full "make test" is too damn slow these
days.</old_grumpy_man>)

TEST_JOBS=30 make test_harness -j30

:D

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @jhi

On Monday-201405-05, 9​:38, Brian Fraser via RT wrote​:

TEST_JOBS=30 make test_harness -j30

Dude, can you spare some cores?

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @Tux

On Mon, 05 May 2014 09​:39​:58 -0400, Jarkko Hietaniemi <jhi@​iki.fi>
wrote​:

On Monday-201405-05, 9​:38, Brian Fraser via RT wrote​:

TEST_JOBS=30 make test_harness -j30

Dude, can you spare some cores?

Would access to

Linux 2.6.32-358.el6.x86_64/#1 x86_64 Xeon(R) CPU L5640 @​ 2.27GHz/2267(24) x86_64 96729 Mb

Help you gain more speed in your work?

--
H.Merijn Brand http​://tux.nl Perl Monger http​://amsterdam.pm.org/
using perl5.00307 .. 5.19 porting perl5 on HP-UX, AIX, and openSUSE
http​://mirrors.develooper.com/hpux/ http​://www.test-smoke.org/
http​://qa.perl.org http​://www.goldmark.org/jeff/stupid-disclaimers/

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @jhi

On Monday-201405-05, 9​:46, H. Merijn Brand via RT wrote​:

Linux 2.6.32-358.el6.x86_64/#1 x86_64 Xeon(R) CPU L5640 @​ 2.27GHz/2267(24) x86_64 96729 Mb
Help you gain more speed in your work?

It would be certainly faster than my five-year old MacBook Pro :-)

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @demerphq

On 5 May 2014 15​:53, Jarkko Hietaniemi <jhi@​iki.fi> wrote​:

On Monday-201405-05, 9​:46, H. Merijn Brand via RT wrote​:

Linux 2.6.32-358.el6.x86_64/#1 x86_64 Xeon(R) CPU L5640 @​
2.27GHz/2267(24) x86_64 96729 Mb

Help you gain more speed in your work?

It would be certainly faster than my five-year old MacBook Pro :-)

We will fix that then.

Yves

--
perl -Mre=debug -e "/just|another|perl|hacker/"

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From dennis@kaarsemaker.net

On ma, 2014-05-05 at 16​:07 +0200, demerphq wrote​:

On 5 May 2014 15​:53, Jarkko Hietaniemi <jhi@​iki.fi> wrote​:
On Monday-201405-05, 9​:46, H. Merijn Brand via RT wrote​:
Linux 2.6.32-358.el6.x86_64/#1 x86_64 Xeon(R) CPU
L5640 @​ 2.27GHz/2267(24) x86_64 96729 Mb
> Help you gain more speed in your work?
It would be certainly faster than my five-year old MacBook
Pro :-)

We will fix that then.

The power of delegation​:

[dkaarsemaker@​dromedary-001 ~]$ id jhi
uid=1156(jhi) gid=1003(p5p) groups=1003(p5p)

:)

--
Dennis Kaarsemaker
http​://www.kaarsemaker.net

@p5pRT
Copy link
Author

p5pRT commented May 5, 2014

From @tonycoz

On Mon May 05 05​:33​:07 2014, jhi wrote​:

On Monday-201405-05, 2​:56, Tony Cook via RT wrote​:

+++ b/dist/IO/IO.xs
Elsewhere you use EBADF when fd is negative.

Yes, I remember this spot... I did use EINVAL for consistency with the
existing logic *at this spot*​: if there was no file pointer, it used
EINVAL. But of course EBADF would be more consistent with the rest of
the change. I dunno. Which "failure contour" to follow?

I'm aiming for the old behaviour - fsync() etc would have been setting errno=EBADF when supplied with a bad file handle.

@​@​ -1616,7 +1618,7 @​@​ PP(pp_sysread)
+ SSize_t count = -1;
Shouldn't this explicitly set count rather than relying upon the
initialization at the top?

I think I did the count init not so much because of the is-fd-negative
logic but because I think I saw a possible code path where count was
left uninitialized. But can't see it now, so recanted that init.

(Though, in principle, initializing a variable to an illegal value as
opposed to uninitialized should not cause *more* failures, if they do,
there's something rotten with the logic...)

While I was looking at pp_sysread + pp_syswrite I cleaned up some
further logic.

I wasn't clear enough here, this code​:

@​@​ -1765,14 +1775,18 @​@​ PP(pp_sysread)
  if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
  if (IoTYPE(io) == IoTYPE_SOCKET) {
- count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ if (fd < 0)
+ SETERRNO(EBADF,SS_IVCHAN);
+ else
+ count = PerlSock_recv(fd, length, 0);
  }
  else
#endif
  {
- count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
- buffer, length);
+ if (fd < 0)
+ SETERRNO(EBADF,RMS_IFI);
+ else
+ count = PerlLIO_read(fd, buffer, length);
  }
  }
  else

doesn't set count when fd is negative, probably breaking the code that follows that checks and uses count.

With the initialization, the first time around the loop would have been safe, but on a UTF-8 stream, sysread() can loop to fill out partial UTF-8 sequences, which would have left count as the previous value - I think fd could change if we were reading from STDIN and another thread closed it.

@​@​ -696,7 +696,10 @​@​ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
  is assigned to (say) STDOUT - for now let dup2() fail
  and provide the error
  */
- if (PerlLIO_dup2(fd, savefd) < 0) {
+ if (fd < 0) {
+ SETERRNO(EBADF,RMS_IFI);
+ goto say_false;
+ } else if (PerlLIO_dup2(fd, savefd) < 0) {
  (void)PerlIO_close(fp);
  goto say_false;
  }

The comment you can see the tail of here is now incorrect, I think.

@​@​ -755,8 +768,12 @​@​ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
#if defined(HAS_FCNTL) && defined(F_SETFD)
  if (fd >= 0) {
  dSAVE_ERRNO;
- fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+ int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
  RESTORE_ERRNO;
+ if (rc < 0) {
+ PerlLIO_close(fd);
+ goto say_false;
+ }
  }
#endif
  IoIFP(io) = fp;

If we're failing the open() based on fcntl() failing, the errno from that failure should be visible to the caller. I think that means we can remove the dSAVE_ERRNO/RESTORE_ERRNO pair.

Sigh. This is getting annoying. Too many damn code paths. One more
spot fixed, in perl.c (if we already did fd=fileno, let's use the
fd...) Attached.

Comments based on this patch.

Tony

@p5pRT
Copy link
Author

p5pRT commented May 6, 2014

From @jhi

EINVAL. But of course EBADF would be more consistent with the rest of
the change. I dunno. Which "failure contour" to follow?

I'm aiming for the old behaviour - fsync() etc would have been setting errno=EBADF when supplied with a bad file handle.

Ah, I see. With that in mind, IO.xs given a new shake.

I wasn't clear enough here, this code​:

@​@​ -1765,14 +1775,18 @​@​ PP(pp_sysread)
if (PL_op->op_type == OP_SYSREAD) {
...
+ if (fd < 0)
+ SETERRNO(EBADF,RMS_IFI);
+ else
+ count = PerlLIO_read(fd, buffer, length);
}
}
else

doesn't set count when fd is negative, probably breaking the code that follows that checks and uses count.

Now see. Now setting the count to -1 on the failure branches.

in a UTF-8 stream, sysread() can loop to fill out partial UTF-8 sequences, which would have left count as the previous value

Years of therapy... all wasted.

- I think fd could change if we were reading from STDIN and another
thread closed it.

Aaaaaa. Hmmmm... maybe reestablishing fd from fileno at more_bytes
label would help for this?

(Not attaching refreshed patch until we hash this one out.)

@​@​ -755,8 +768,12 @​@​ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
#if defined(HAS_FCNTL) && defined(F_SETFD)
if (fd >= 0) {
dSAVE_ERRNO;
- fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
+ int rc = fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
RESTORE_ERRNO;
+ if (rc < 0) {
+ PerlLIO_close(fd);
+ goto say_false;
+ }
}
#endif
IoIFP(io) = fp;

If we're failing the open() based on fcntl() failing, the errno from that failure should be visible to the caller. I think that means we can remove the dSAVE_ERRNO/RESTORE_ERRNO pair.

Gone.

@p5pRT
Copy link
Author

p5pRT commented May 6, 2014

From @jhi

Oh, well. Went ahead and refreshed patch anyway.

@p5pRT
Copy link
Author

p5pRT commented May 6, 2014

From @jhi

0001-Check-fileno-numgroups-1-check-fcntl-fgetc-failures.patch
From 026cc3058c2fec9beb42215b49dadc487f17b725 Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Fri, 2 May 2014 22:12:24 -0400
Subject: [PATCH] Check fileno/numgroups -1, check fcntl (+fgetc) failures.

(merged fix for perl #121743 and perl #121745)
---
 dist/IO/IO.xs           |  35 ++++++++---
 dist/threads/threads.xs |  10 +--
 doio.c                  | 106 ++++++++++++++++++++-----------
 ext/PerlIO-mmap/mmap.xs |   6 +-
 mg.c                    |  15 +++--
 perl.c                  |  34 +++++++---
 perlio.c                |  20 ++++--
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 162 +++++++++++++++++++++++++++++++++++-------------
 util.c                  |  21 ++++---
 10 files changed, 292 insertions(+), 121 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..829d898 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -104,11 +104,17 @@ io_blocking(pTHX_ InputStream f, int block)
 {
 #if defined(HAS_FCNTL)
     int RETVAL;
-    if(!f) {
+    int fd;
+    if (!f) {
 	errno = EBADF;
 	return -1;
     }
-    RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
+    fd = PerlIO_fileno(f);
+    if (fd < 0) {
+      errno = EBADF;
+      return -1;
+    }
+    RETVAL = fcntl(fd, F_GETFL, 0);
     if (RETVAL >= 0) {
 	int mode = RETVAL;
 	int newmode = mode;
@@ -143,7 +149,7 @@ io_blocking(pTHX_ InputStream f, int block)
 	}
 #endif
 	if (newmode != mode) {
-	    const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
+            const int ret = fcntl(fd, F_SETFL, newmode);
 	    if (ret < 0)
 		RETVAL = ret;
 	}
@@ -154,7 +160,7 @@ io_blocking(pTHX_ InputStream f, int block)
     if (block >= 0) {
 	unsigned long flags = !block;
 	/* ioctl claims to take char* but really needs a u_long sized buffer */
-	const int ret = ioctl(PerlIO_fileno(f), FIONBIO, (char*)&flags);
+	const int ret = ioctl(fd, FIONBIO, (char*)&flags);
 	if (ret != 0)
 	    return -1;
 	/* Win32 has no way to get the current blocking status of a socket.
@@ -524,9 +530,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EBADF;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
@@ -557,9 +569,14 @@ sockatmark (sock)
      int fd;
    CODE:
    {
-     fd = PerlIO_fileno(sock);
 #ifdef HAS_SOCKATMARK
-     RETVAL = sockatmark(fd);
+     int fd = PerlIO_fileno(sock);
+     if (fd < 0) {
+       errno = EBADF;
+       RETVAL = -1;
+     } else {
+       RETVAL = sockatmark(fd);
+     }
 #else
      {
        int flag = 0;
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 8537165..90c61ff 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -713,11 +713,13 @@ S_ithread_create(
     }
     PERL_SET_CONTEXT(aTHX);
     if (!thread) {
-        int rc;
         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
-        rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                            PL_no_mem, strlen(PL_no_mem));
-        PERL_UNUSED_VAR(rc);
+        int fd = PerlIO_fileno(Perl_error_log);
+        if (fd >= 0) {
+          /* If there's no error_log, we cannot scream about it missing. */
+          int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+          PERL_UNUSED_VAR(rc);
+        }
         my_exit(1);
     }
     Zero(thread, 1, ithread);
diff --git a/doio.c b/doio.c
index e2bfda5..0f2ac68 100644
--- a/doio.c
+++ b/doio.c
@@ -646,9 +646,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
-     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
-     * type probe for socket-ness.
+    /* Do NOT do: "if (fd < 0) goto say_false;" here.  If there is no
+     * fd assume it isn't a socket - this covers PerlIO::scalar -
+     * otherwise unless we "know" the type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 	if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
@@ -696,7 +696,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	       is assigned to (say) STDOUT - for now let dup2() fail
 	       and provide the error
 	     */
-	    if (PerlLIO_dup2(fd, savefd) < 0) {
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		goto say_false;
+            } else if (PerlLIO_dup2(fd, savefd) < 0) {
 		(void)PerlIO_close(fp);
 		goto say_false;
 	    }
@@ -732,13 +735,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -754,9 +767,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
-	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
-	RESTORE_ERRNO;
+        if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
@@ -956,23 +970,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1185,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1396,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1762,13 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+                        } else if (fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1802,12 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+			    tot--;
+                        } else if (fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1996,12 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+			} else if (futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2116,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) {
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..6632544 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          SETERRNO(EBADF,RMS_IFI);
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..452bc63 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        if (fcntl(fd, F_SETFD, 1) < 0) {
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+                       CopFILE(PL_curcop), Strerror(errno));
+        }
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3841,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index d4c43d0..4b98f6b 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2923,6 +2923,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2931,8 +2935,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3351,8 +3359,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
@@ -3668,6 +3676,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index bca95e2..df23cd3 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..9aa652f 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -1627,8 +1629,9 @@ PP(pp_sysread)
     bool charstart = FALSE;
     STRLEN charskip = 0;
     STRLEN skip = 0;
-
     GV * const gv = MUTABLE_GV(*++MARK);
+    int fd;
+
     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
 	&& gv && (io = GvIO(gv)) )
     {
@@ -1659,6 +1662,10 @@ PP(pp_sysread)
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
+
+    /* Note that fd can here validly be -1, don't check it yet. */
+    fd = PerlIO_fileno(IoIFP(io));
+
     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
 	buffer = SvPVutf8_force(bufsv, blen);
 	/* UTF-8 may not have been set if they are all low bytes */
@@ -1682,6 +1689,10 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        if (fd < 0) {
+            SETERRNO(EBADF,SS_IVCHAN);
+            RETPUSHUNDEF;
+        }
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1704,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1735,6 +1746,7 @@ PP(pp_sysread)
 	else
 	    offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
     }
+
  more_bytes:
     orig_size = SvCUR(bufsv);
     /* Allocating length + offset + 1 isn't perfect in the case of reading
@@ -1765,14 +1777,21 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_SYSREAD) {
 #ifdef PERL_SOCK_SYSREAD_IS_RECV
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+            if (fd < 0) {
+                SETERRNO(EBADF,SS_IVCHAN);
+                count = -1;
+            } else
+                count = PerlSock_recv(fd, length, 0);
 	}
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+                count = -1;
+            }
+            else
+                count = PerlLIO_read(fd, buffer, length);
 	}
     }
     else
@@ -1856,6 +1875,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1886,6 +1906,12 @@ PP(pp_syswrite)
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0) {
+        SETERRNO(EBADF,SS_IVCHAN);
+        retval = -1;
+        goto say_undef;
+    }
 
     /* Do this first to trigger any overloading.  */
     buffer = SvPV_const(bufsv, blen);
@@ -1920,12 +1946,11 @@ PP(pp_syswrite)
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2033,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2247,19 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd < 0) {
+                        SETERRNO(EBADF,RMS_IFI);
+                        result = 0;
+                    } else {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2248,9 +2277,10 @@ PP(pp_truncate)
 	    {
 		const int tmpfd = PerlLIO_open(name, O_RDWR);
 
-		if (tmpfd < 0)
+		if (tmpfd < 0) {
+                    SETERRNO(EBADF,RMS_IFI);
 		    result = 0;
-		else {
+		} else {
 		    if (my_chsize(tmpfd, len) < 0)
 		        result = 0;
 		    PerlLIO_close(tmpfd);
@@ -2388,8 +2418,10 @@ PP(pp_socket)
 
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
-    if (fd < 0)
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
+    }
     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);	/* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
     IoTYPE(io) = IoTYPE_SOCKET;
@@ -2400,7 +2432,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2478,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2467,16 +2502,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2554,7 +2593,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -2608,6 +2648,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2725,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2808,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                            SETERRNO(EBADF,RMS_IFI);
+                        } else {
+                            PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3305,13 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
+	FT_RETURNUNDEF;
+    }
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3360,15 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		FT_RETURNUNDEF;
+            }
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3398,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,9 +3418,16 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
 	    FT_RETURNUNDEF;
 	}
 	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
@@ -3475,19 +3542,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3567,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
@@ -4194,7 +4267,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..343bf72 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,16 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd < 0)
+        SETERRNO(EBADF,RMS_IFI);
+    else {
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
@@ -2308,7 +2311,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2457,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 7, 2014

From @tonycoz

On Mon May 05 18​:18​:16 2014, jhi wrote​:

- I think fd could change if we were reading from STDIN and another
thread closed it.

Aaaaaa. Hmmmm... maybe reestablishing fd from fileno at more_bytes
label would help for this?

(Not attaching refreshed patch until we hash this one out.)

Sorry, yes, I think it should.

The current code has a race condition if the file is closed between fetching the fd and using it, but the patch makes that larger.

Tony

@p5pRT
Copy link
Author

p5pRT commented May 7, 2014

From @jhi

On Tuesday-201405-06, 20​:26, Tony Cook via RT wrote​:

On Mon May 05 18​:18​:16 2014, jhi wrote​:

- I think fd could change if we were reading from STDIN and another
thread closed it.

Aaaaaa. Hmmmm... maybe reestablishing fd from fileno at more_bytes
label would help for this?

(Not attaching refreshed patch until we hash this one out.)

Sorry, yes, I think it should.

So done.

The current code has a race condition if the file is closed between fetching the fd and using it, but the patch makes that larger.

Tony

And here we go again, attaching...

@p5pRT
Copy link
Author

p5pRT commented May 7, 2014

From @jhi

0001-Check-fileno-numgroups-1-check-fcntl-fgetc-failures.patch
From a08c8c52935454cf7fbac7bb4397dcab7bae658a Mon Sep 17 00:00:00 2001
From: Jarkko Hietaniemi <jhi@iki.fi>
Date: Fri, 2 May 2014 22:12:24 -0400
Subject: [PATCH] Check fileno/numgroups -1, check fcntl (+fgetc) failures.

(merged fix for perl #121743 and perl #121745)
---
 dist/IO/IO.xs           |  35 +++++++---
 dist/threads/threads.xs |  10 +--
 doio.c                  | 106 +++++++++++++++++++++----------
 ext/PerlIO-mmap/mmap.xs |   6 +-
 mg.c                    |  15 +++--
 perl.c                  |  34 +++++++---
 perlio.c                |  20 ++++--
 pod/perldiag.pod        |   4 ++
 pp_sys.c                | 165 +++++++++++++++++++++++++++++++++++-------------
 util.c                  |  21 +++---
 10 files changed, 295 insertions(+), 121 deletions(-)

diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index 9056cb6..829d898 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -104,11 +104,17 @@ io_blocking(pTHX_ InputStream f, int block)
 {
 #if defined(HAS_FCNTL)
     int RETVAL;
-    if(!f) {
+    int fd;
+    if (!f) {
 	errno = EBADF;
 	return -1;
     }
-    RETVAL = fcntl(PerlIO_fileno(f), F_GETFL, 0);
+    fd = PerlIO_fileno(f);
+    if (fd < 0) {
+      errno = EBADF;
+      return -1;
+    }
+    RETVAL = fcntl(fd, F_GETFL, 0);
     if (RETVAL >= 0) {
 	int mode = RETVAL;
 	int newmode = mode;
@@ -143,7 +149,7 @@ io_blocking(pTHX_ InputStream f, int block)
 	}
 #endif
 	if (newmode != mode) {
-	    const int ret = fcntl(PerlIO_fileno(f),F_SETFL,newmode);
+            const int ret = fcntl(fd, F_SETFL, newmode);
 	    if (ret < 0)
 		RETVAL = ret;
 	}
@@ -154,7 +160,7 @@ io_blocking(pTHX_ InputStream f, int block)
     if (block >= 0) {
 	unsigned long flags = !block;
 	/* ioctl claims to take char* but really needs a u_long sized buffer */
-	const int ret = ioctl(PerlIO_fileno(f), FIONBIO, (char*)&flags);
+	const int ret = ioctl(fd, FIONBIO, (char*)&flags);
 	if (ret != 0)
 	    return -1;
 	/* Win32 has no way to get the current blocking status of a socket.
@@ -524,9 +530,15 @@ fsync(arg)
 	handle = IoOFP(sv_2io(arg));
 	if (!handle)
 	    handle = IoIFP(sv_2io(arg));
-	if(handle)
-	    RETVAL = fsync(PerlIO_fileno(handle));
-	else {
+	if (handle) {
+	    int fd = PerlIO_fileno(handle);
+	    if (fd >= 0) {
+		RETVAL = fsync(fd);
+	    } else {
+		RETVAL = -1;
+		errno = EBADF;
+	    }
+	} else {
 	    RETVAL = -1;
 	    errno = EINVAL;
 	}
@@ -557,9 +569,14 @@ sockatmark (sock)
      int fd;
    CODE:
    {
-     fd = PerlIO_fileno(sock);
 #ifdef HAS_SOCKATMARK
-     RETVAL = sockatmark(fd);
+     int fd = PerlIO_fileno(sock);
+     if (fd < 0) {
+       errno = EBADF;
+       RETVAL = -1;
+     } else {
+       RETVAL = sockatmark(fd);
+     }
 #else
      {
        int flag = 0;
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 8537165..90c61ff 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -713,11 +713,13 @@ S_ithread_create(
     }
     PERL_SET_CONTEXT(aTHX);
     if (!thread) {
-        int rc;
         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
-        rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                            PL_no_mem, strlen(PL_no_mem));
-        PERL_UNUSED_VAR(rc);
+        int fd = PerlIO_fileno(Perl_error_log);
+        if (fd >= 0) {
+          /* If there's no error_log, we cannot scream about it missing. */
+          int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+          PERL_UNUSED_VAR(rc);
+        }
         my_exit(1);
     }
     Zero(thread, 1, ithread);
diff --git a/doio.c b/doio.c
index e2bfda5..0f2ac68 100644
--- a/doio.c
+++ b/doio.c
@@ -646,9 +646,9 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 
     fd = PerlIO_fileno(fp);
-    /* If there is no fd (e.g. PerlIO::scalar) assume it isn't a
-     * socket - this covers PerlIO::scalar - otherwise unless we "know" the
-     * type probe for socket-ness.
+    /* Do NOT do: "if (fd < 0) goto say_false;" here.  If there is no
+     * fd assume it isn't a socket - this covers PerlIO::scalar -
+     * otherwise unless we "know" the type probe for socket-ness.
      */
     if (IoTYPE(io) && IoTYPE(io) != IoTYPE_PIPE && IoTYPE(io) != IoTYPE_STD && fd >= 0) {
 	if (PerlLIO_fstat(fd,&PL_statbuf) < 0) {
@@ -696,7 +696,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	       is assigned to (say) STDOUT - for now let dup2() fail
 	       and provide the error
 	     */
-	    if (PerlLIO_dup2(fd, savefd) < 0) {
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		goto say_false;
+            } else if (PerlLIO_dup2(fd, savefd) < 0) {
 		(void)PerlIO_close(fp);
 		goto say_false;
 	    }
@@ -732,13 +735,23 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
 	    if (was_fdopen) {
                 /* need to close fp without closing underlying fd */
                 int ofd = PerlIO_fileno(fp);
-                int dupfd = PerlLIO_dup(ofd);
+                int dupfd = ofd >= 0 ? PerlLIO_dup(ofd) : -1;
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* Assume if we have F_SETFD we have F_GETFD */
-                int coe = fcntl(ofd,F_GETFD);
+                int coe = ofd >= 0 ? fcntl(ofd, F_GETFD) : -1;
+                if (coe < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
 #endif
+                if (ofd < 0 || dupfd < 0) {
+                    if (dupfd >= 0)
+                        PerlLIO_close(dupfd);
+                    goto say_false;
+                }
                 PerlIO_close(fp);
-                PerlLIO_dup2(dupfd,ofd);
+                PerlLIO_dup2(dupfd, ofd);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 		/* The dup trick has lost close-on-exec on ofd */
 		fcntl(ofd,F_SETFD, coe);
@@ -754,9 +767,10 @@ S_openn_cleanup(pTHX_ GV *gv, IO *io, PerlIO *fp, char *mode, const char *oname,
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     if (fd >= 0) {
-	dSAVE_ERRNO;
-	fcntl(fd,F_SETFD,fd > PL_maxsysfd); /* can change errno */
-	RESTORE_ERRNO;
+        if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0) {
+            PerlLIO_close(fd);
+            goto say_false;
+        }
     }
 #endif
     IoIFP(io) = fp;
@@ -956,23 +970,25 @@ Perl_nextargv(pTHX_ GV *gv)
 		}
 		setdefout(PL_argvoutgv);
 		PL_lastfd = PerlIO_fileno(IoIFP(GvIOp(PL_argvoutgv)));
-		(void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
+                if (PL_lastfd >= 0) {
+                    (void)PerlLIO_fstat(PL_lastfd,&PL_statbuf);
 #ifdef HAS_FCHMOD
-		(void)fchmod(PL_lastfd,PL_filemode);
+                    (void)fchmod(PL_lastfd,PL_filemode);
 #else
-		(void)PerlLIO_chmod(PL_oldname,PL_filemode);
+                    (void)PerlLIO_chmod(PL_oldname,PL_filemode);
 #endif
-		if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
-                    int rc = 0;
+                    if (fileuid != PL_statbuf.st_uid || filegid != PL_statbuf.st_gid) {
+                        int rc = 0;
 #ifdef HAS_FCHOWN
-		    rc = fchown(PL_lastfd,fileuid,filegid);
+                        rc = fchown(PL_lastfd,fileuid,filegid);
 #else
 #ifdef HAS_CHOWN
-		    rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
+                        rc = PerlLIO_chown(PL_oldname,fileuid,filegid);
 #endif
 #endif
-                    /* XXX silently ignore failures */
-                    PERL_UNUSED_VAR(rc);
+                        /* XXX silently ignore failures */
+                        PERL_UNUSED_VAR(rc);
+                    }
 		}
                 return IoIFP(GvIOp(gv));
 	    }
@@ -1169,8 +1185,12 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 
     PERL_ARGS_ASSERT_DO_SYSSEEK;
 
-    if (io && (fp = IoIFP(io)))
-	return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
+    if (io && (fp = IoIFP(io))) {
+        int fd = PerlIO_fileno(fp);
+        if (fd >= 0) {
+            return PerlLIO_lseek(fd, pos, whence);
+        }
+    }
     report_evil_fh(gv);
     SETERRNO(EBADF,RMS_IFI);
     return (Off_t)-1;
@@ -1376,7 +1396,10 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
         sv_setpvs(PL_statname, "");
         if(io) {
 	    if (IoIFP(io)) {
-	        return (PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache));
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd >= 0) {
+                    return (PL_laststatval = PerlLIO_fstat(fd, &PL_statcache));
+                }
             } else if (IoDIRP(io)) {
                 return (PL_laststatval = PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache));
             }
@@ -1739,9 +1762,13 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHMOD
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchmod(PerlIO_fileno(IoIFP(GvIOn(gv))), val))
-			    tot--;
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+                        } else if (fchmod(fd, val))
+                            tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchmod");
 #endif
@@ -1775,8 +1802,12 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
 		if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FCHOWN
+                        int fd = PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (fchown(PerlIO_fileno(IoIFP(GvIOn(gv))), val, val2))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+			    tot--;
+                        } else if (fchown(fd, val, val2))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "fchown");
@@ -1965,9 +1996,12 @@ nothing in the core.
                 if ((gv = MAYBE_DEREF_GV(*mark))) {
 		    if (GvIO(gv) && IoIFP(GvIOp(gv))) {
 #ifdef HAS_FUTIMES
+                        int fd =  PerlIO_fileno(IoIFP(GvIOn(gv)));
 			APPLY_TAINT_PROPER();
-			if (futimes(PerlIO_fileno(IoIFP(GvIOn(gv))),
-                            (struct timeval *) utbufp))
+                        if (fd < 0) {
+                            SETERRNO(EBADF,RMS_IFI);
+                            tot--;
+			} else if (futimes(fd, (struct timeval *) utbufp))
 			    tot--;
 #else
 			Perl_die(aTHX_ PL_no_func, "futimes");
@@ -2082,15 +2116,17 @@ S_ingroup(pTHX_ Gid_t testgid, bool effective)
         bool rc = FALSE;
 
 	anum = getgroups(0, gary);
-        Newx(gary, anum, Groups_t);
-        anum = getgroups(anum, gary);
-	while (--anum >= 0)
-	    if (gary[anum] == testgid) {
-                rc = TRUE;
-                break;
-            }
+        if (anum > 0) {
+            Newx(gary, anum, Groups_t);
+            anum = getgroups(anum, gary);
+            while (--anum >= 0)
+                if (gary[anum] == testgid) {
+                    rc = TRUE;
+                    break;
+                }
 
-        Safefree(gary);
+            Safefree(gary);
+        }
         return rc;
     }
 #else
diff --git a/ext/PerlIO-mmap/mmap.xs b/ext/PerlIO-mmap/mmap.xs
index 4c96da8..6632544 100644
--- a/ext/PerlIO-mmap/mmap.xs
+++ b/ext/PerlIO-mmap/mmap.xs
@@ -40,8 +40,12 @@ PerlIOMmap_map(pTHX_ PerlIO *f)
 	abort();
     if (flags & PERLIO_F_CANREAD) {
 	PerlIOBuf * const b = PerlIOSelf(f, PerlIOBuf);
-	const int fd = PerlIO_fileno(f);
 	Stat_t st;
+	const int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+          SETERRNO(EBADF,RMS_IFI);
+          return -1;
+        }
 	code = Fstat(fd, &st);
 	if (code == 0 && S_ISREG(st.st_mode)) {
 	    SSize_t len = st.st_size - b->posn;
diff --git a/mg.c b/mg.c
index 76912bd..6414349 100644
--- a/mg.c
+++ b/mg.c
@@ -1120,12 +1120,15 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #ifdef HAS_GETGROUPS
 	{
 	    Groups_t *gary = NULL;
-	    I32 i, num_groups = getgroups(0, gary);
-            Newx(gary, num_groups, Groups_t);
-            num_groups = getgroups(num_groups, gary);
-	    for (i = 0; i < num_groups; i++)
-		Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
-            Safefree(gary);
+	    I32 i;
+            I32 num_groups = getgroups(0, gary);
+            if (num_groups > 0) {
+                Newx(gary, num_groups, Groups_t);
+                num_groups = getgroups(num_groups, gary);
+                for (i = 0; i < num_groups; i++)
+                    Perl_sv_catpvf(aTHX_ sv, " %"IVdf, (IV)gary[i]);
+                Safefree(gary);
+            }
 	}
 	(void)SvIOK_on(sv);	/* what a wonderful hack! */
 #endif
diff --git a/perl.c b/perl.c
index 27d0d9e..452bc63 100644
--- a/perl.c
+++ b/perl.c
@@ -3691,6 +3691,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
     PerlIO *rsfp = NULL;
     dVAR;
     Stat_t tmpstatbuf;
+    int fd;
 
     PERL_ARGS_ASSERT_OPEN_SCRIPT;
 
@@ -3796,13 +3797,20 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
 	    Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
 		    CopFILE(PL_curcop), Strerror(errno));
     }
+    fd = PerlIO_fileno(rsfp);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    /* ensure close-on-exec */
-    fcntl(PerlIO_fileno(rsfp), F_SETFD, 1);
+    if (fd >= 0) {
+        /* ensure close-on-exec */
+        if (fcntl(fd, F_SETFD, 1) < 0) {
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+                       CopFILE(PL_curcop), Strerror(errno));
+        }
+    }
 #endif
 
-    if (PerlLIO_fstat(PerlIO_fileno(rsfp), &tmpstatbuf) >= 0
-        && S_ISDIR(tmpstatbuf.st_mode))
+    if (fd < 0 ||
+        (PerlLIO_fstat(fd, &tmpstatbuf) >= 0
+         && S_ISDIR(tmpstatbuf.st_mode)))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
             Strerror(EISDIR));
@@ -3833,12 +3841,18 @@ S_validate_suid(pTHX_ PerlIO *rsfp)
 
     if (my_euid != my_uid || my_egid != my_gid) {	/* (suidperl doesn't exist, in fact) */
 	dVAR;
-
-	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
-	if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
-	    ||
-	    (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
-	   )
+        int fd = PerlIO_fileno(rsfp);
+        if (fd < 0) {
+            Perl_croak(aTHX_ "Illegal suidscript");
+        } else {
+            if (PerlLIO_fstat(fd, &PL_statbuf) < 0) {	/* may be either wrapped or real suid */
+                Perl_croak(aTHX_ "Illegal suidscript");
+            }
+        }
+        if ((my_euid != my_uid && my_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
+            ||
+            (my_egid != my_gid && my_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
+            )
 	    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");
diff --git a/perlio.c b/perlio.c
index d4c43d0..4b98f6b 100644
--- a/perlio.c
+++ b/perlio.c
@@ -2923,6 +2923,10 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
     PerlIO *f = NULL;
     if (stdio) {
 	PerlIOStdio *s;
+        int fd0 = fileno(stdio);
+        if (fd0 < 0) {
+            return NULL;
+        }
 	if (!mode || !*mode) {
 	    /* We need to probe to see how we can open the stream
 	       so start with read/write and then try write and read
@@ -2931,8 +2935,12 @@ PerlIO_importFILE(FILE *stdio, const char *mode)
 	       Note that the errno value set by a failing fdopen
 	       varies between stdio implementations.
 	     */
-	    const int fd = PerlLIO_dup(fileno(stdio));
-	    FILE *f2 = PerlSIO_fdopen(fd, (mode = "r+"));
+            const int fd = PerlLIO_dup(fd0);
+	    FILE *f2;
+            if (fd < 0) {
+                return f;
+            }
+	    f2 = PerlSIO_fdopen(fd, (mode = "r+"));
 	    if (!f2) {
 		f2 = PerlSIO_fdopen(fd, (mode = "w"));
 	    }
@@ -3351,8 +3359,8 @@ PerlIOStdio_unread(pTHX_ PerlIO *f, const void *vbuf, Size_t count)
 	    }
 	    if ((STDCHAR*)PerlSIO_get_ptr(s) != --eptr || ((*eptr & 0xFF) != ch)) {
 		/* Did not change pointer as expected */
-		fgetc(s);  /* get char back again */
-		break;
+		if (fgetc(s) != EOF)  /* get char back again */
+                    break;
 	    }
 	    /* It worked ! */
 	    count--;
@@ -3668,6 +3676,10 @@ PerlIO_exportFILE(PerlIO * f, const char *mode)
     FILE *stdio = NULL;
     if (PerlIOValid(f)) {
 	char buf[8];
+        int fd = PerlIO_fileno(f);
+        if (fd < 0) {
+            return NULL;
+        }
 	PerlIO_flush(f);
 	if (!mode || !*mode) {
 	    mode = PerlIO_modestr(f, buf);
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index bca95e2..df23cd3 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2292,6 +2292,10 @@ The C<"+"> is valid only when followed by digits, indicating a
 capturing group.  See
 L<C<(?I<PARNO>)>|perlre/(?PARNO) (?-PARNO) (?+PARNO) (?R) (?0)>.
 
+=item Illegal suidscript
+
+(F) The script run under suidperl was somehow illegal.
+
 =item Illegal switch in PERL5OPT: -%c
 
 (X) The PERL5OPT environment variable may only be used to set the
diff --git a/pp_sys.c b/pp_sys.c
index 9f97177..672b77d 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -715,8 +715,10 @@ PP(pp_pipe_op)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0], F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1], F_SETFD,fd[1] > PL_maxsysfd) < 0))
+        goto badexit;
 #endif
     RETPUSHYES;
 
@@ -1627,8 +1629,9 @@ PP(pp_sysread)
     bool charstart = FALSE;
     STRLEN charskip = 0;
     STRLEN skip = 0;
-
     GV * const gv = MUTABLE_GV(*++MARK);
+    int fd;
+
     if ((PL_op->op_type == OP_READ || PL_op->op_type == OP_SYSREAD)
 	&& gv && (io = GvIO(gv)) )
     {
@@ -1659,6 +1662,10 @@ PP(pp_sysread)
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
+
+    /* Note that fd can here validly be -1, don't check it yet. */
+    fd = PerlIO_fileno(IoIFP(io));
+
     if ((fp_utf8 = PerlIO_isutf8(IoIFP(io))) && !IN_BYTES) {
 	buffer = SvPVutf8_force(bufsv, blen);
 	/* UTF-8 may not have been set if they are all low bytes */
@@ -1682,6 +1689,10 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_RECV) {
 	Sock_size_t bufsize;
 	char namebuf[MAXPATHLEN];
+        if (fd < 0) {
+            SETERRNO(EBADF,SS_IVCHAN);
+            RETPUSHUNDEF;
+        }
 #if (defined(VMS_DO_SOCKETS) && defined(DECCRTL_SOCKETS)) || defined(__QNXNTO__)
 	bufsize = sizeof (struct sockaddr_in);
 #else
@@ -1693,7 +1704,7 @@ PP(pp_sysread)
 #endif
 	buffer = SvGROW(bufsv, (STRLEN)(length+1));
 	/* 'offset' means 'flags' here */
-	count = PerlSock_recvfrom(PerlIO_fileno(IoIFP(io)), buffer, length, offset,
+	count = PerlSock_recvfrom(fd, buffer, length, offset,
 				  (struct sockaddr *)namebuf, &bufsize);
 	if (count < 0)
 	    RETPUSHUNDEF;
@@ -1735,7 +1746,11 @@ PP(pp_sysread)
 	else
 	    offset = utf8_hop((U8 *)buffer,offset) - (U8 *) buffer;
     }
+
  more_bytes:
+    /* Reestablish the fd in case it shifted from underneath us. */
+    fd = PerlIO_fileno(IoIFP(io));
+
     orig_size = SvCUR(bufsv);
     /* Allocating length + offset + 1 isn't perfect in the case of reading
        bytes from a byte file handle into a UTF8 buffer, but it won't harm us
@@ -1765,14 +1780,21 @@ PP(pp_sysread)
     if (PL_op->op_type == OP_SYSREAD) {
 #ifdef PERL_SOCK_SYSREAD_IS_RECV
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+            if (fd < 0) {
+                SETERRNO(EBADF,SS_IVCHAN);
+                count = -1;
+            } else
+                count = PerlSock_recv(fd, length, 0);
 	}
 	else
 #endif
 	{
-	    count = PerlLIO_read(PerlIO_fileno(IoIFP(io)),
-				  buffer, length);
+            if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+                count = -1;
+            }
+            else
+                count = PerlLIO_read(fd, buffer, length);
 	}
     }
     else
@@ -1856,6 +1878,7 @@ PP(pp_syswrite)
     U8 *tmpbuf = NULL;
     GV *const gv = MUTABLE_GV(*++MARK);
     IO *const io = GvIO(gv);
+    int fd;
 
     if (op_type == OP_SYSWRITE && io) {
 	const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
@@ -1886,6 +1909,12 @@ PP(pp_syswrite)
 	SETERRNO(EBADF,RMS_IFI);
 	goto say_undef;
     }
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0) {
+        SETERRNO(EBADF,SS_IVCHAN);
+        retval = -1;
+        goto say_undef;
+    }
 
     /* Do this first to trigger any overloading.  */
     buffer = SvPV_const(bufsv, blen);
@@ -1920,12 +1949,11 @@ PP(pp_syswrite)
 	if (SP > MARK) {
 	    STRLEN mlen;
 	    char * const sockbuf = SvPVx(*++MARK, mlen);
-	    retval = PerlSock_sendto(PerlIO_fileno(IoIFP(io)), buffer, blen,
+	    retval = PerlSock_sendto(fd, buffer, blen,
 				     flags, (struct sockaddr *)sockbuf, mlen);
 	}
 	else {
-	    retval
-		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
+	    retval = PerlSock_send(fd, buffer, blen, flags);
 	}
     }
     else
@@ -2008,15 +2036,13 @@ PP(pp_syswrite)
 	}
 #ifdef PERL_SOCK_SYSWRITE_IS_SEND
 	if (IoTYPE(io) == IoTYPE_SOCKET) {
-	    retval = PerlSock_send(PerlIO_fileno(IoIFP(io)),
-				   buffer, length, 0);
+	    retval = PerlSock_send(fd, buffer, length, 0);
 	}
 	else
 #endif
 	{
 	    /* See the note at doio.c:do_print about filesize limits. --jhi */
-	    retval = PerlLIO_write(PerlIO_fileno(IoIFP(io)),
-				   buffer, length);
+            retval = PerlLIO_write(fd, buffer, length);
 	}
     }
 
@@ -2224,13 +2250,19 @@ PP(pp_truncate)
 		    result = 0;
 		}
 		else {
-		    PerlIO_flush(fp);
+                    int fd = PerlIO_fileno(fp);
+                    if (fd < 0) {
+                        SETERRNO(EBADF,RMS_IFI);
+                        result = 0;
+                    } else {
+                        PerlIO_flush(fp);
 #ifdef HAS_TRUNCATE
-		    if (ftruncate(PerlIO_fileno(fp), len) < 0)
+                        if (ftruncate(fd, len) < 0)
 #else
-		    if (my_chsize(PerlIO_fileno(fp), len) < 0)
+                        if (my_chsize(fd, len) < 0)
 #endif
-			result = 0;
+                            result = 0;
+                    }
 		}
 	    }
 	}
@@ -2248,9 +2280,10 @@ PP(pp_truncate)
 	    {
 		const int tmpfd = PerlLIO_open(name, O_RDWR);
 
-		if (tmpfd < 0)
+		if (tmpfd < 0) {
+                    SETERRNO(EBADF,RMS_IFI);
 		    result = 0;
-		else {
+		} else {
 		    if (my_chsize(tmpfd, len) < 0)
 		        result = 0;
 		    PerlLIO_close(tmpfd);
@@ -2388,8 +2421,10 @@ PP(pp_socket)
 
     TAINT_PROPER("socket");
     fd = PerlSock_socket(domain, type, protocol);
-    if (fd < 0)
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
 	RETPUSHUNDEF;
+    }
     IoIFP(io) = PerlIO_fdopen(fd, "r"SOCKET_OPEN_MODE);	/* stdio gets confused about sockets */
     IoOFP(io) = PerlIO_fdopen(fd, "w"SOCKET_OPEN_MODE);
     IoTYPE(io) = IoTYPE_SOCKET;
@@ -2400,7 +2435,8 @@ PP(pp_socket)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2445,8 +2481,10 @@ PP(pp_sockpair)
 	RETPUSHUNDEF;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd);	/* ensure close-on-exec */
-    fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd);	/* ensure close-on-exec */
+    /* ensure close-on-exec */
+    if ((fcntl(fd[0],F_SETFD,fd[0] > PL_maxsysfd) < 0) ||
+        (fcntl(fd[1],F_SETFD,fd[1] > PL_maxsysfd) < 0))
+	RETPUSHUNDEF;
 #endif
 
     RETPUSHYES;
@@ -2467,16 +2505,20 @@ PP(pp_bind)
     IO * const io = GvIOn(gv);
     STRLEN len;
     int op_type;
+    int fd;
 
     if (!IoIFP(io))
 	goto nuts;
+    fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
 
     addr = SvPV_const(addrsv, len);
     op_type = PL_op->op_type;
     TAINT_PROPER(PL_op_desc[op_type]);
     if ((op_type == OP_BIND
-	 ? PerlSock_bind(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len)
-	 : PerlSock_connect(PerlIO_fileno(IoIFP(io)), (struct sockaddr *)addr, len))
+	 ? PerlSock_bind(fd, (struct sockaddr *)addr, len)
+	 : PerlSock_connect(fd, (struct sockaddr *)addr, len))
 	>= 0)
 	RETPUSHYES;
     else
@@ -2554,7 +2596,8 @@ PP(pp_accept)
 	goto badexit;
     }
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(fd, F_SETFD, fd > PL_maxsysfd);	/* ensure close-on-exec */
+    if (fcntl(fd, F_SETFD, fd > PL_maxsysfd) < 0)	/* ensure close-on-exec */
+        goto badexit;
 #endif
 
 #ifdef __SCO_VERSION__
@@ -2608,6 +2651,8 @@ PP(pp_ssockopt)
 	goto nuts;
 
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GSOCKOPT:
 	SvGROW(sv, 257);
@@ -2683,6 +2728,8 @@ PP(pp_getpeername)
     SvCUR_set(sv, len);
     *SvEND(sv) ='\0';
     fd = PerlIO_fileno(IoIFP(io));
+    if (fd < 0)
+        goto nuts;
     switch (optype) {
     case OP_GETSOCKNAME:
 	if (PerlSock_getsockname(fd, (struct sockaddr *)SvPVX(sv), &len) < 0)
@@ -2764,9 +2811,14 @@ PP(pp_stat)
 	    }
             if (io) {
                     if (IoIFP(io)) {
-                        PL_laststatval = 
-                            PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);   
-                        havefp = TRUE;
+                        int fd = PerlIO_fileno(IoIFP(io));
+                        if (fd < 0) {
+                            PL_laststatval = -1;
+                            SETERRNO(EBADF,RMS_IFI);
+                        } else {
+                            PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
+                            havefp = TRUE;
+                        }
                     } else if (IoDIRP(io)) {
                         PL_laststatval =
                             PerlLIO_fstat(my_dirfd(IoDIRP(io)), &PL_statcache);
@@ -3256,9 +3308,13 @@ PP(pp_fttty)
     if (GvIO(gv) && IoIFP(GvIOp(gv)))
 	fd = PerlIO_fileno(IoIFP(GvIOp(gv)));
     else if (name && isDIGIT(*name))
-	    fd = atoi(name);
+        fd = atoi(name);
     else
 	FT_RETURNUNDEF;
+    if (fd < 0) {
+        SETERRNO(EBADF,RMS_IFI);
+	FT_RETURNUNDEF;
+    }
     if (PerlLIO_isatty(fd))
 	FT_RETURNYES;
     FT_RETURNNO;
@@ -3307,9 +3363,15 @@ PP(pp_fttext)
 	PL_laststatval = -1;
 	PL_laststype = OP_STAT;
 	if (io && IoIFP(io)) {
+	    int fd;
 	    if (! PerlIO_has_base(IoIFP(io)))
 		DIE(aTHX_ "-T and -B not implemented on filehandles");
-	    PL_laststatval = PerlLIO_fstat(PerlIO_fileno(IoIFP(io)), &PL_statcache);
+	    fd = PerlIO_fileno(IoIFP(io));
+	    if (fd < 0) {
+                SETERRNO(EBADF,RMS_IFI);
+		FT_RETURNUNDEF;
+            }
+	    PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	    if (PL_laststatval < 0)
 		FT_RETURNUNDEF;
 	    if (S_ISDIR(PL_statcache.st_mode)) { /* handle NFS glitch */
@@ -3339,6 +3401,7 @@ PP(pp_fttext)
 	}
     }
     else {
+        int fd;
 	sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
       really_filename:
 	PL_statgv = NULL;
@@ -3358,9 +3421,16 @@ PP(pp_fttext)
 	    FT_RETURNUNDEF;
 	}
 	PL_laststype = OP_STAT;
-	PL_laststatval = PerlLIO_fstat(PerlIO_fileno(fp), &PL_statcache);
+        fd = PerlIO_fileno(fp);
+        if (fd < 0) {
+	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
+	    FT_RETURNUNDEF;
+        }
+	PL_laststatval = PerlLIO_fstat(fd, &PL_statcache);
 	if (PL_laststatval < 0)	{
 	    (void)PerlIO_close(fp);
+            SETERRNO(EBADF,RMS_IFI);
 	    FT_RETURNUNDEF;
 	}
 	PerlIO_binmode(aTHX_ fp, '<', O_BINARY, NULL);
@@ -3475,19 +3545,19 @@ PP(pp_chdir)
 	    if (IoDIRP(io)) {
 		PUSHi(fchdir(my_dirfd(IoDIRP(io))) >= 0);
 	    } else if (IoIFP(io)) {
-                PUSHi(fchdir(PerlIO_fileno(IoIFP(io))) >= 0);
+                int fd = PerlIO_fileno(IoIFP(io));
+                if (fd < 0) {
+                    goto nuts;
+                }
+                PUSHi(fchdir(fd) >= 0);
 	    }
 	    else {
-		report_evil_fh(gv);
-		SETERRNO(EBADF, RMS_IFI);
-		PUSHi(0);
+                goto nuts;
 	    }
+        } else {
+            goto nuts;
         }
-	else {
-	    report_evil_fh(gv);
-	    SETERRNO(EBADF,RMS_IFI);
-	    PUSHi(0);
-	}
+
 #else
 	DIE(aTHX_ PL_no_func, "fchdir");
 #endif
@@ -3500,6 +3570,12 @@ PP(pp_chdir)
     hv_delete(GvHVn(PL_envgv),"DEFAULT",7,G_DISCARD);
 #endif
     RETURN;
+
+ nuts:
+    report_evil_fh(gv);
+    SETERRNO(EBADF,RMS_IFI);
+    PUSHi(0);
+    RETURN;
 }
 
 PP(pp_chown)
@@ -4194,7 +4270,8 @@ PP(pp_system)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                RETPUSHUNDEF;
 #endif
 	}
 	if (PL_op->op_flags & OPf_STACKED) {
diff --git a/util.c b/util.c
index 0a0ee40..343bf72 100644
--- a/util.c
+++ b/util.c
@@ -1710,13 +1710,16 @@ void
 Perl_croak_no_mem(void)
 {
     dTHX;
-    int rc;
 
-    /* Can't use PerlIO to write as it allocates memory */
-    rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-		  PL_no_mem, sizeof(PL_no_mem)-1);
-    /* silently ignore failures */
-    PERL_UNUSED_VAR(rc);
+    int fd = PerlIO_fileno(Perl_error_log);
+    if (fd < 0)
+        SETERRNO(EBADF,RMS_IFI);
+    else {
+        /* Can't use PerlIO to write as it allocates memory */
+        int rc = PerlLIO_write(fd, PL_no_mem, sizeof(PL_no_mem)-1);
+        /* silently ignore failures */
+        PERL_UNUSED_VAR(rc);
+    }
     my_exit(1);
 }
 
@@ -2308,7 +2311,8 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	    /* Close error pipe automatically if exec works */
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+	    if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	/* Now dup our end of _the_ pipe to right position */
@@ -2453,7 +2457,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode)
 	if (did_pipes) {
 	    PerlLIO_close(pp[0]);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-	    fcntl(pp[1], F_SETFD, FD_CLOEXEC);
+            if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
+                return NULL;
 #endif
 	}
 	if (p[THIS] != (*mode == 'r')) {
-- 
1.9.2

@p5pRT
Copy link
Author

p5pRT commented May 10, 2014

From @bulk88

On Tue May 06 17​:37​:22 2014, jhi wrote​:

And here we go again, attaching...

Doesnt this need version number bumps?

--
bulk88 ~ bulk88 at hotmail.com

@p5pRT
Copy link
Author

p5pRT commented May 20, 2014

From @tonycoz

On Sat May 10 15​:26​:31 2014, bulk88 wrote​:

On Tue May 06 17​:37​:22 2014, jhi wrote​:

And here we go again, attaching...

Doesnt this need version number bumps?

I'll do version bumps, patches with the bumps run the risk of conflicts (see 121618 for example)

Tony

@p5pRT
Copy link
Author

p5pRT commented May 21, 2014

From @tonycoz

On Tue May 06 17​:37​:22 2014, jhi wrote​:

And here we go again, attaching...

Looks good to me.

It conflicts with another patch (from 121112), which I've fixed for my work branch.

Tony

@p5pRT
Copy link
Author

p5pRT commented May 21, 2014

From @jhi

On Tuesday-201405-20, 20​:36, Tony Cook via RT wrote​:

It conflicts with another patch (from 121112), which I've fixed for my work branch.

Hmm, okay. Which way you'd prefer me to fix my fix? Do you want to
push your fix for 121112 to blead?

(About 121112​: how about \r? I've been bitten too many times by
removing just the \n...)

@p5pRT
Copy link
Author

p5pRT commented May 21, 2014

From @jhi

On Tuesday-201405-20, 20​:47, Jarkko Hietaniemi wrote​:

(About 121112​: how about \r? I've been bitten too many times by
removing just the \n...)

That is, with \r\n (*) looking for the \n is of course enough... I was
thinking that if there's a user-friendly explanation of this warning
somewhere, mentioning that one chomp() might not be enough, when working
with mixed environments...

(*) There's also Mac OS Classic with just \r, but files with that are
rarer...

@p5pRT
Copy link
Author

p5pRT commented May 22, 2014

From @tonycoz

On Tue May 20 17​:47​:50 2014, jhi wrote​:

On Tuesday-201405-20, 20​:36, Tony Cook via RT wrote​:

It conflicts with another patch (from 121112), which I've fixed for
my work branch.

Hmm, okay. Which way you'd prefer me to fix my fix? Do you want to
push your fix for 121112 to blead?

(About 121112​: how about \r? I've been bitten too many times by
removing just the \n...)

The warning is intended to protect against a missing chomp(), which won't remove the \r anyway.

My fix won't go into blead until after 5.20 is released.

I have your work in my work branch (smoke-me/tonyc/5.21.1-blockers on perl5.git.perl.org) adjusted for the conflict.

Tony

@p5pRT
Copy link
Author

p5pRT commented May 22, 2014

From @tonycoz

On Tue May 06 17​:37​:22 2014, jhi wrote​:

And here we go again, attaching...

Picked up by building on Win32​:

@​@​ -1765,14 +1780,21 @​@​ PP(pp_sysread)
  if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
  if (IoTYPE(io) == IoTYPE_SOCKET) {
- count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ count = -1;
+ } else
+ count = PerlSock_recv(fd, length, 0);
  }
  else
#endif

lost the buffer parameter to PerlSock_recv().

Tony

@p5pRT
Copy link
Author

p5pRT commented May 22, 2014

From @tonycoz

On Wed May 21 17​:42​:52 2014, tonyc wrote​:

On Tue May 06 17​:37​:22 2014, jhi wrote​:

And here we go again, attaching...

Picked up by building on Win32​:

@​@​ -1765,14 +1780,21 @​@​ PP(pp_sysread)
if (PL_op->op_type == OP_SYSREAD) {
#ifdef PERL_SOCK_SYSREAD_IS_RECV
if (IoTYPE(io) == IoTYPE_SOCKET) {
- count = PerlSock_recv(PerlIO_fileno(IoIFP(io)),
- buffer, length, 0);
+ if (fd < 0) {
+ SETERRNO(EBADF,SS_IVCHAN);
+ count = -1;
+ } else
+ count = PerlSock_recv(fd, length, 0);
}
else
#endif

lost the buffer parameter to PerlSock_recv().

Some other issuess​:

This chunk​:

@​@​ -154,7 +160,7 @​@​ io_blocking(pTHX_ InputStream f, int block)
  if (block >= 0) {
  unsigned long flags = !block;
  /* ioctl claims to take char* but really needs a u_long sized buffer */
- const int ret = ioctl(PerlIO_fileno(f), FIONBIO, (char*)&flags);
+ const int ret = ioctl(fd, FIONBIO, (char*)&flags);
  if (ret != 0)
  return -1;
  /* Win32 has no way to get the current blocking status of a socket.

fd is only defined withing #if defined(HAS_FCNTL) (and the checks are only done there) and so isn't visible to this code.

This one​:

Inline Patch
diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index 8537165..90c61ff 100644
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -713,11 +713,13 @@ S_ithread_create(
     }
     PERL_SET_CONTEXT(aTHX);
     if (!thread) {
-        int rc;
         MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
-        rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
-                            PL_no_mem, strlen(PL_no_mem));
-        PERL_UNUSED_VAR(rc);
+        int fd = PerlIO_fileno(Perl_error_log);
+        if (fd >= 0) {
+          /* If there's no error_log, we cannot scream about it missing. */
+          int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+          PERL_UNUSED_VAR(rc);
+        }
         my_exit(1);
     }
     Zero(thread, 1, ithread);

moves the declaration of rc, but we need C89 support for Win32/Visual C and HP-UX, which requires declarations at the top of the block.

Tony

@p5pRT
Copy link
Author

p5pRT commented May 22, 2014

From @jhi

On Wednesday-201405-21, 22​:03, Tony Cook via RT wrote​:

fd is only defined withing #if defined(HAS_FCNTL) (and the checks are only done there) and so isn't visible to this code.

Well, (as long as f, being the source of fd, is not fiddled with) the fd
computation, and checks, should be as early as possible.

moves the declaration of rc, but we need C89 support for Win32/Visual
C and HP-UX, which requires declarations at the top of the block.

I'm confused, the declaration of rc was moved like this​:

+ if (fd >= 0) {
+ /* If there's no error_log, we cannot scream about it missing. */
+ int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+ PERL_UNUSED_VAR(rc);
+ }

so the rc declaration is at the top of the block?

Though, looking at that closer, why not just do​:
(void)PerlLIO_write(fd, ...)?

@p5pRT
Copy link
Author

p5pRT commented May 22, 2014

From @tonycoz

On Wed, May 21, 2014 at 10​:11​:59PM -0400, Jarkko Hietaniemi wrote​:

On Wednesday-201405-21, 22​:03, Tony Cook via RT wrote​:

fd is only defined withing #if defined(HAS_FCNTL) (and the checks are only done there) and so isn't visible to this code.

Well, (as long as f, being the source of fd, is not fiddled with)
the fd computation, and checks, should be as early as possible.

moves the declaration of rc, but we need C89 support for
Win32/Visual C and HP-UX, which requires declarations at the top of
the block.

I'm confused, the declaration of rc was moved like this​:

+ if (fd >= 0) {
+ /* If there's no error_log, we cannot scream about it missing. */
+ int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+ PERL_UNUSED_VAR(rc);
+ }

so the rc declaration is at the top of the block?

Though, looking at that closer, why not just do​:
(void)PerlLIO_write(fd, ...)?

See Dave's explanation​:

http​://perl5.git.perl.org/perl.git/commit/04783dc7025287c5d75ab531602c7ec786a1e787

Tony

@p5pRT
Copy link
Author

p5pRT commented May 22, 2014

From @jhi

On Thursday-201405-22, 0​:16, Tony Cook via RT wrote​:

See Dave's explanation​:

http​://perl5.git.perl.org/perl.git/commit/04783dc7025287c5d75ab531602c7ec786a1e787

Various system functions like write() are marked with the
__warn_unused_result__ attribute, which causes an 'ignoring return >
value'

Ah, this is the same issue as with Gconvert()... once the
PERL_UNUSED_RESULT is in, that can also be used to suppress these.

@p5pRT
Copy link
Author

p5pRT commented Jun 9, 2014

From @tonycoz

On Wed May 21 19​:12​:39 2014, jhi wrote​:

On Wednesday-201405-21, 22​:03, Tony Cook via RT wrote​:

fd is only defined withing #if defined(HAS_FCNTL) (and the checks are
only done there) and so isn't visible to this code.

Well, (as long as f, being the source of fd, is not fiddled with) the
fd
computation, and checks, should be as early as possible.

moves the declaration of rc, but we need C89 support for Win32/Visual
C and HP-UX, which requires declarations at the top of the block.

I'm confused, the declaration of rc was moved like this​:

+ if (fd >= 0) {
+ /* If there's no error_log, we cannot scream about it
missing. */
+ int rc = PerlLIO_write(fd, PL_no_mem, strlen(PL_no_mem));
+ PERL_UNUSED_VAR(rc);
+ }

so the rc declaration is at the top of the block?

Though, looking at that closer, why not just do​:
(void)PerlLIO_write(fd, ...)?

The changes in this ticket have been applied as part of 375ed12.

Tony

@p5pRT
Copy link
Author

p5pRT commented Jun 9, 2014

@tonycoz - Status changed from 'open' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Labels
Projects
None yet
Development

No branches or pull requests

1 participant