Merge branch 'master' into core-updates

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))))))