summaryrefslogtreecommitdiff
path: root/nix
diff options
context:
space:
mode:
Diffstat (limited to 'nix')
-rw-r--r--nix/scripts/list-runtime-roots.in36
1 files changed, 33 insertions, 3 deletions
diff --git a/nix/scripts/list-runtime-roots.in b/nix/scripts/list-runtime-roots.in
index 45fa0733d5..4d329c5ff5 100644
--- a/nix/scripts/list-runtime-roots.in
+++ b/nix/scripts/list-runtime-roots.in
@@ -1,7 +1,7 @@
#!@GUILE@ -ds
!#
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -28,12 +28,17 @@
(ice-9 rdelim)
(ice-9 popen)
(srfi srfi-1)
- (srfi srfi-26))
+ (srfi srfi-26)
+ (rnrs io ports))
(define %proc-directory
;; Mount point of Linuxish /proc file system.
"/proc")
+(define %store-directory
+ (or (getenv "NIX_STORE_DIR")
+ "@storedir@"))
+
(define (proc-file-roots dir file)
"Return a one-element list containing the file pointed to by DIR/FILE,
or the empty list."
@@ -78,6 +83,30 @@ or the empty list."
(else
(loop (read-line maps) roots)))))))
+(define (proc-environ-roots dir)
+ "Return the list of store files referenced by DIR/environ, where DIR is a
+/proc/XYZ directory."
+ (define split-on-nul
+ (cute string-tokenize <>
+ (char-set-complement (char-set #\nul))))
+
+ (define (rhs-file-names str)
+ (let ((equal (string-index str #\=)))
+ (if equal
+ (let* ((str (substring str (+ 1 equal)))
+ (rx (string-append (regexp-quote %store-directory)
+ "/[0-9a-z]{32}-[a-zA-Z0-9\\._+-]+")))
+ (map match:substring (list-matches rx str)))
+ '())))
+
+ (define environ
+ (string-append dir "/environ"))
+
+ (append-map rhs-file-names
+ (split-on-nul
+ (call-with-input-file environ
+ get-string-all))))
+
(define (lsof-roots)
"Return the list of roots as found by calling `lsof'."
(catch 'system
@@ -111,6 +140,7 @@ or the empty list."
(append (proc-exe-roots proc)
(proc-cwd-roots proc)
(proc-fd-roots proc)
- (proc-maps-roots proc))
+ (proc-maps-roots proc)
+ (proc-environ-roots proc))
'())))
(append proc-roots (lsof-roots))))))