diff options
| -rw-r--r-- | nix/scripts/list-runtime-roots.in | 79 |
1 files changed, 21 insertions, 58 deletions
diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in index a6938087b5..6f0e7f5b6a 100644 --- a/nix/scripts/list-runtime-roots.in +++ b/nix/scripts/list-runtime-roots.in @@ -26,7 +26,6 @@ (use-modules (ice-9 ftw) (ice-9 regex) (ice-9 rdelim) - (ice-9 popen) (srfi srfi-1) (srfi srfi-26) (rnrs io ports)) @@ -59,7 +58,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 +106,25 @@ 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)))))) + ;; There's a TOCTTOU race that we need to handle. + (if (= ENOENT (system-error-errno args)) + '() + (apply throw args)))))) + (scandir %proc-directory string->number + (lambda (a b) + (< (string->number a) (string->number b)))))) + +(for-each (cut simple-format #t "~a~%" <>) + (delete-duplicates (referenced-files))) |