Merge branch 'master' into core-updates

1 files changed, 36 insertions, 58 deletions

diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in
index a6938087b5..511789a539 100644
--- a/nix/scripts/list-runtime-roots.in
+++ b/nix/scripts/list-runtime-roots.in
@@ -26,7 +26,7 @@
 (use-modules (ice-9 ftw)
              (ice-9 regex)
              (ice-9 rdelim)
-             (ice-9 popen)
+             (ice-9 match)
              (srfi srfi-1)
              (srfi srfi-26)
              (rnrs io ports))
@@ -59,7 +59,7 @@ or the empty list."
                     (and target
                          (string-prefix? "/" target)
                          target)))
-                (scandir dir string->number))))
+                (or (scandir dir string->number) '()))))
 
 (define (proc-maps-roots dir)
   "Return the list of store files referenced by DIR, which is a
@@ -107,61 +107,39 @@ or the empty list."
                (call-with-input-file environ
                  get-string-all))))
 
-(define (lsof-roots)
-  "Return the list of roots as found by calling `lsof'."
-  (define parent (getpid))
-
-  (catch 'system-error
-    (lambda ()
-      (let ((pipe (catch 'system-error
+(define (referenced-files)
+  "Return the list of referenced store items."
+  (append-map (lambda (pid)
+                (let ((proc (string-append %proc-directory "/" pid)))
+                  (catch 'system-error
                     (lambda ()
-                      (open-pipe* OPEN_READ "lsof" "-n" "-w" "-F" "n"))
+                      (append (proc-exe-roots proc)
+                              (proc-cwd-roots proc)
+                              (proc-fd-roots proc)
+                              (proc-maps-roots proc)
+                              (proc-environ-roots proc)))
                     (lambda args
-                      ;; In Guile 2.0.5, when (ice-9 popen) was still written
-                      ;; in Scheme, 'open-pipe*' would leave the child process
-                      ;; behind it when 'execlp' failed (that was mostly
-                      ;; harmless though, because the uncaught exception would
-                      ;; cause it to terminate after printing a backtrace.)
-                      ;; Make sure that doesn't happen.
-                      (if (= (getpid) parent)
-                          (apply throw args)
-                          (begin
-                            (format (current-error-port)
-                                    "failed to execute 'lsof': ~a~%"
-                                    (strerror (system-error-errno args)))
-                            (primitive-exit 1)))))))
-        (define %file-rx
-          (make-regexp "^n/(.*)$"))
-
-        ;; We're going to read it all.
-        (setvbuf pipe _IOFBF 16384)
-
-        (let loop ((line  (read-line pipe))
-                   (roots '()))
-          (cond ((eof-object? line)
-                 (begin
-                   (close-pipe pipe)
-                   roots))
-                ((regexp-exec %file-rx line)
-                 =>
-                 (lambda (match)
-                   (loop (read-line pipe)
-                         (cons (string-append "/"
-                                              (match:substring match 1))
-                               roots))))
-                (else
-                 (loop (read-line pipe) roots))))))
-    (lambda _
-      '())))
-
-(let ((proc (format #f "~a/~a" %proc-directory (getpid))))
-  (for-each (cut simple-format #t "~a~%" <>)
-            (delete-duplicates
-             (let ((proc-roots (if (file-exists? proc)
-                                   (append (proc-exe-roots proc)
-                                           (proc-cwd-roots proc)
-                                           (proc-fd-roots proc)
-                                           (proc-maps-roots proc)
-                                           (proc-environ-roots proc))
-                                   '())))
-               (append proc-roots (lsof-roots))))))
+                      (let ((err (system-error-errno args)))
+                        (if (or (= ENOENT err)    ;TOCTTOU race
+                                (= EACCES err))   ;not running as root
+                            '()
+                            (apply throw args)))))))
+              (scandir %proc-directory string->number
+                       (lambda (a b)
+                         (< (string->number a) (string->number b))))))
+
+(define canonicalize-store-item
+  (let ((prefix (+ 1 (string-length %store-directory))))
+    (lambda (file)
+      "Return #f if FILE is not a store item; otherwise, return the store file
+name without any sub-directory components."
+      (and (string-prefix? %store-directory file)
+           (string-append %store-directory "/"
+                          (let ((base (string-drop file prefix)))
+                            (match (string-index base #\/)
+                              (#f    base)
+                              (slash (string-take base slash)))))))))
+
+(for-each (cut simple-format #t "~a~%" <>)
+          (delete-duplicates
+           (filter-map canonicalize-store-item (referenced-files))))