master 8bc85d4: Manually limit file descriptors that we select on to FD_SETSIZE.

[Philipp Stephani]

branch: master
commit 8bc85d46cc9214a531f2d2ecb3f5fb48af8105a6
Author: Philipp Stephani <phst@google.com>
Commit: Philipp Stephani <phst@google.com>

    Manually limit file descriptors that we select on to FD_SETSIZE.
    
    This works even if another thread or process resets the resource limit
    for open file descriptors, e.g., using 'prlimit' on GNU/Linux.
    
    * src/process.c (create_process, create_pty, Fmake_pipe_process)
    (Fmake_serial_process, connect_network_socket)
    (server_accept_connection): Limit file descriptors to FD_SETSIZE.
    * test/src/process-tests.el (process-tests--with-raised-rlimit): New
    helper macro.
    (process-tests--fd-setsize-test): Rename from
    'process-tests--with-many-pipes'.  Increase resource limit during test
    if possible.
    (process-tests/fd-setsize-no-crash/make-process)
    (process-tests/fd-setsize-no-crash/make-pipe-process)
    (process-tests/fd-setsize-no-crash/make-network-process)
    (process-tests--new-pty): Rename callers.
---
 src/process.c             |  25 ++++++++++++
 test/src/process-tests.el | 100 ++++++++++++++++++++++++++++++++--------------
 2 files changed, 96 insertions(+), 29 deletions(-)

diff --git a/src/process.c b/src/process.c
index 7c56366..ba2bb3c 100644
--- a/src/process.c
+++ b/src/process.c
@@ -2114,6 +2114,9 @@ create_process (Lisp_Object process, char **new_argv, 
Lisp_Object current_dir)
        }
     }
 
+  if (FD_SETSIZE <= inchannel || FD_SETSIZE <= outchannel)
+    report_file_errno ("Creating pipe", Qnil, EMFILE);
+
 #ifndef WINDOWSNT
   if (emacs_pipe (p->open_fd + READ_FROM_EXEC_MONITOR) != 0)
     report_file_error ("Creating pipe", Qnil);
@@ -2210,6 +2213,8 @@ create_pty (Lisp_Object process)
   if (pty_fd >= 0)
     {
       p->open_fd[SUBPROCESS_STDIN] = pty_fd;
+      if (FD_SETSIZE <= pty_fd)
+       report_file_errno ("Opening pty", Qnil, EMFILE);
 #if ! defined (USG) || defined (USG_SUBTTY_WORKS)
       /* On most USG systems it does not work to open the pty's tty here,
         then close it and reopen it in the child.  */
@@ -2317,6 +2322,9 @@ usage:  (make-pipe-process &rest ARGS)  */)
   outchannel = p->open_fd[WRITE_TO_SUBPROCESS];
   inchannel = p->open_fd[READ_FROM_SUBPROCESS];
 
+  if (FD_SETSIZE <= inchannel || FD_SETSIZE <= outchannel)
+    report_file_errno ("Creating pipe", Qnil, EMFILE);
+
   fcntl (inchannel, F_SETFL, O_NONBLOCK);
   fcntl (outchannel, F_SETFL, O_NONBLOCK);
 
@@ -3059,6 +3067,8 @@ usage:  (make-serial-process &rest ARGS)  */)
 
   fd = serial_open (port);
   p->open_fd[SUBPROCESS_STDIN] = fd;
+  if (FD_SETSIZE <= fd)
+    report_file_errno ("Opening serial port", Qnil, EMFILE);
   p->infd = fd;
   p->outfd = fd;
   if (fd > max_desc)
@@ -3280,6 +3290,7 @@ connect_network_socket (Lisp_Object proc, Lisp_Object 
addrinfos,
   if (!NILP (use_external_socket_p))
     {
       socket_to_use = external_sock_fd;
+      eassert (socket_to_use < FD_SETSIZE);
 
       /* Ensure we don't consume the external socket twice.  */
       external_sock_fd = -1;
@@ -3321,6 +3332,13 @@ connect_network_socket (Lisp_Object proc, Lisp_Object 
addrinfos,
              xerrno = errno;
              continue;
            }
+         if (FD_SETSIZE <= s)
+           {
+             emacs_close (s);
+             s = -1;
+             xerrno = EMFILE;
+             continue;
+           }
        }
 
       if (p->is_non_blocking_client && ! (SOCK_NONBLOCK && socket_to_use < 0))
@@ -4782,6 +4800,13 @@ server_accept_connection (Lisp_Object server, int 
channel)
 
   s = accept4 (channel, &saddr.sa, &len, SOCK_CLOEXEC);
 
+  if (FD_SETSIZE <= s)
+    {
+      emacs_close (s);
+      s = -1;
+      errno = EMFILE;
+    }
+
   if (s < 0)
     {
       int code = errno;
diff --git a/test/src/process-tests.el b/test/src/process-tests.el
index 590f72f..eee8636 100644
--- a/test/src/process-tests.el
+++ b/test/src/process-tests.el
@@ -426,11 +426,52 @@ add some process objects to VAR."
          ,(macroexp-progn body)
        (mapc #'delete-process ,var))))
 
-(defmacro process-tests--with-many-pipes (&rest body)
-  "Generate lots of pipe processes.
+(defmacro process-tests--with-raised-rlimit (&rest body)
+  "Evaluate BODY using a higher limit for the number of open files.
+Attempt to set the resource limit for the number of open files
+temporarily to the highest possible value."
+  (declare (indent 0) (debug t))
+  (let ((prlimit (make-symbol "prlimit"))
+        (soft (make-symbol "soft"))
+        (hard (make-symbol "hard"))
+        (pid-arg (make-symbol "pid-arg")))
+    `(let ((,prlimit (executable-find "prlimit"))
+           (,pid-arg (format "--pid=%d" (emacs-pid)))
+           (,soft nil) (,hard nil))
+       (cl-flet ((set-limit
+                  (value)
+                  (cl-check-type value natnum)
+                  (when ,prlimit
+                    (call-process ,prlimit nil nil nil
+                                  ,pid-arg
+                                  (format "--nofile=%d:" value)))))
+         (when ,prlimit
+           (with-temp-buffer
+             (when (eql (call-process ,prlimit nil t nil
+                                      ,pid-arg "--nofile"
+                                      "--raw" "--noheadings"
+                                      "--output=SOFT,HARD")
+                        0)
+               (goto-char (point-min))
+               (when (looking-at (rx (group (+ digit)) (+ blank)
+                                     (group (+ digit)) ?\n))
+                 (setq ,soft (string-to-number
+                              (match-string-no-properties 1))
+                       ,hard (string-to-number
+                              (match-string-no-properties 2))))))
+           (and ,soft ,hard (< ,soft ,hard)
+                (set-limit ,hard)))
+         (unwind-protect
+             ,(macroexp-progn body)
+           (when ,soft (set-limit ,soft)))))))
+
+(defmacro process-tests--fd-setsize-test (&rest body)
+  "Run BODY as a test for FD_SETSIZE overflow.
 Try to generate pipe processes until we are close to the
 FD_SETSIZE limit.  Within BODY, only a small number of file
-descriptors should still be available."
+descriptors should still be available.  Furthermore, raise the
+maximum number of open files in the Emacs process above
+FD_SETSIZE."
   (declare (indent 0) (debug t))
   (let ((process (make-symbol "process"))
         (processes (make-symbol "processes"))
@@ -440,28 +481,29 @@ descriptors should still be available."
         ;; MS-Windows we artificially limit FD_SETSIZE to 64, see the
         ;; commentary in w32proc.c.
         (fd-setsize (if (eq system-type 'windows-nt) 64 1024)))
-    `(process-tests--with-buffers ,buffers
-       (process-tests--with-processes ,processes
-         ;; First, allocate enough pipes to definitely exceed the
-         ;; FD_SETSIZE limit.
-         (cl-loop for i from 1 to ,(1+ fd-setsize)
-                  for ,buffer = (generate-new-buffer
-                                 (format " *pipe %d*" i))
-                  do (push ,buffer ,buffers)
-                  for ,process = (process-tests--ignore-EMFILE
-                                   (make-pipe-process
-                                    :name (format "pipe %d" i)
-                                    :buffer ,buffer
-                                    :coding 'no-conversion
-                                    :noquery t))
-                  while ,process
-                  do (push ,process ,processes))
-         (unless (cddr ,processes)
-           (ert-fail "Couldn't allocate enough pipes"))
-         ;; Delete two pipes to test more edge cases.
-         (delete-process (pop ,processes))
-         (delete-process (pop ,processes))
-         ,@body))))
+    `(process-tests--with-raised-rlimit
+       (process-tests--with-buffers ,buffers
+         (process-tests--with-processes ,processes
+           ;; First, allocate enough pipes to definitely exceed the
+           ;; FD_SETSIZE limit.
+           (cl-loop for i from 1 to ,(1+ fd-setsize)
+                    for ,buffer = (generate-new-buffer
+                                   (format " *pipe %d*" i))
+                    do (push ,buffer ,buffers)
+                    for ,process = (process-tests--ignore-EMFILE
+                                     (make-pipe-process
+                                      :name (format "pipe %d" i)
+                                      :buffer ,buffer
+                                      :coding 'no-conversion
+                                      :noquery t))
+                    while ,process
+                    do (push ,process ,processes))
+           (unless (cddr ,processes)
+             (ert-fail "Couldn't allocate enough pipes"))
+           ;; Delete two pipes to test more edge cases.
+           (delete-process (pop ,processes))
+           (delete-process (pop ,processes))
+           ,@body)))))
 
 (defmacro process-tests--with-temp-file (var &rest body)
   "Bind VAR to the name of a new regular file and evaluate BODY.
@@ -502,7 +544,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
       (skip-unless sleep)
       (dolist (conn-type '(pipe pty))
         (ert-info ((format "Connection type `%s'" conn-type))
-          (process-tests--with-many-pipes
+          (process-tests--fd-setsize-test
             (process-tests--with-processes processes
               ;; Start processes until we exhaust the file descriptor
               ;; set size.  We assume that each process requires at
@@ -538,7 +580,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
   "Check that Emacs doesn't crash when trying to use more than
 FD_SETSIZE file descriptors (Bug#24325)."
   (with-timeout (60 (ert-fail "Test timed out"))
-    (process-tests--with-many-pipes
+    (process-tests--fd-setsize-test
       (process-tests--with-buffers buffers
         (process-tests--with-processes processes
           ;; Start processes until we exhaust the file descriptor set
@@ -580,7 +622,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
                                              :coding 'no-conversion
                                              :noquery t)))
           (push server processes)
-          (process-tests--with-many-pipes
+          (process-tests--fd-setsize-test
             ;; Start processes until we exhaust the file descriptor
             ;; set size.  We assume that each process requires at
             ;; least one file descriptor.
@@ -627,7 +669,7 @@ FD_SETSIZE file descriptors (Bug#24325)."
             (should tty-name)
             (should (file-exists-p tty-name))
             (push tty-name tty-names)))
-        (process-tests--with-many-pipes
+        (process-tests--fd-setsize-test
           (process-tests--with-processes processes
             (process-tests--with-buffers buffers
               (dolist (tty-name tty-names)