Merge branch 'master' into core-updates

3 files changed, 49 insertions, 29 deletions

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 475fc96490..b68c48a05a 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -21,6 +21,7 @@
 (define-module (guix build syscalls)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
+  #:autoload   (ice-9 binary-ports) (get-bytevector-n)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
@@ -142,7 +143,8 @@
             utmpx-time
             utmpx-address
             login-type
-            utmpx-entries))
+            utmpx-entries
+            (read-utmpx-from-port . read-utmpx)))
 
 ;;; Commentary:
 ;;;
@@ -1598,4 +1600,13 @@ always a positive integer."
       ((? utmpx? entry)
        (loop (cons entry entries))))))
 
+(define (read-utmpx-from-port port)
+  "Read a utmpx entry from PORT.  Return either the EOF object or a utmpx
+entry."
+  (match (get-bytevector-n port sizeof-utmpx)
+    ((? eof-object? eof)
+     eof)
+    ((? bytevector? bv)
+     (read-utmpx bv))))
+
 ;;; syscalls.scm ends here
diff --git a/guix/grafts.scm b/guix/grafts.scm
index e14a40f8d1..11885db226 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -78,11 +78,12 @@
 (define* (graft-derivation/shallow store drv grafts
                                    #:key
                                    (name (derivation-name drv))
+                                   (outputs (derivation-output-names drv))
                                    (guile (%guile-for-build))
                                    (system (%current-system)))
-  "Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied.  This procedure performs \"shallow\" grafting in that GRAFTS are not
-recursively applied to dependencies of DRV."
+  "Return a derivation called NAME, which applies GRAFTS to the specified
+OUTPUTS of DRV.  This procedure performs \"shallow\" grafting in that GRAFTS
+are not recursively applied to dependencies of DRV."
   ;; XXX: Someday rewrite using gexps.
   (define mapping
     ;; List of store item pairs.
@@ -96,14 +97,12 @@ recursively applied to dependencies of DRV."
                      target))))
          grafts))
 
-  (define outputs
-    (map (match-lambda
-           ((name . output)
-            (cons name (derivation-output-path output))))
-         (derivation-outputs drv)))
-
-  (define output-names
-    (derivation-output-names drv))
+  (define output-pairs
+    (map (lambda (output)
+           (cons output
+                 (derivation-output-path
+                  (assoc-ref (derivation-outputs drv) output))))
+         outputs))
 
   (define build
     `(begin
@@ -111,7 +110,7 @@ recursively applied to dependencies of DRV."
                     (guix build utils)
                     (ice-9 match))
 
-       (let* ((old-outputs ',outputs)
+       (let* ((old-outputs ',output-pairs)
               (mapping (append ',mapping
                                (map (match-lambda
                                       ((name . file)
@@ -143,10 +142,10 @@ recursively applied to dependencies of DRV."
                                                  (guix build utils))
                                      #:inputs `(,@(map (lambda (out)
                                                          `("x" ,drv ,out))
-                                                       output-names)
+                                                       outputs)
                                                 ,@(append (map add-label sources)
                                                           (map add-label targets)))
-                                     #:outputs output-names
+                                     #:outputs outputs
                                      #:local-build? #t)))))
 (define (item->deriver store item)
   "Return two values: the derivation that led to ITEM (a store item), and the
@@ -217,14 +216,14 @@ available."
 (define-syntax-rule (with-cache key exp ...)
   "Cache the value of monadic expression EXP under KEY."
   (mlet %state-monad ((cache (current-state)))
-    (match (vhash-assq key cache)
+    (match (vhash-assoc key cache)
       ((_ . result)                               ;cache hit
        (return result))
       (#f                                         ;cache miss
        (mlet %state-monad ((result (begin exp ...))
                            (cache  (current-state)))
          (mbegin %state-monad
-           (set-current-state (vhash-consq key result cache))
+           (set-current-state (vhash-cons key result cache))
            (return result)))))))
 
 (define* (cumulative-grafts store drv grafts
@@ -265,7 +264,7 @@ derivations to the corresponding set of grafts."
                                  #:system system))
           (state-return grafts))))
 
-  (with-cache drv
+  (with-cache (cons (derivation-file-name drv) outputs)
     (match (non-self-references references drv outputs)
       (()                                         ;no dependencies
        (return grafts))
@@ -282,29 +281,27 @@ derivations to the corresponding set of grafts."
               ;; applicable to DRV, to avoid creating several identical
               ;; grafted variants of DRV.
               (let* ((new    (graft-derivation/shallow store drv applicable
+                                                       #:outputs outputs
                                                        #:guile guile
                                                        #:system system))
-
-                     ;; Replace references to any of the outputs of DRV,
-                     ;; even if that's more than needed.  This is so that
-                     ;; the result refers only to the outputs of NEW and
-                     ;; not to those of DRV.
                      (grafts (append (map (lambda (output)
                                             (graft
                                               (origin drv)
                                               (origin-output output)
                                               (replacement new)
                                               (replacement-output output)))
-                                          (derivation-output-names drv))
+                                          outputs)
                                      grafts)))
                 (return grafts))))))))))
 
 (define* (graft-derivation store drv grafts
-                           #:key (guile (%guile-for-build))
+                           #:key
+                           (guile (%guile-for-build))
+                           (outputs (derivation-output-names drv))
                            (system (%current-system)))
-  "Applied GRAFTS to DRV and all its dependencies, recursively.  That is, if
-GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
-DRV itself to refer to those grafted dependencies."
+  "Apply GRAFTS to the OUTPUTS of DRV and all their dependencies, recursively.
+That is, if GRAFTS apply only indirectly to DRV, graft the dependencies of
+DRV, and graft DRV itself to refer to those grafted dependencies."
 
   ;; First, pre-compute the dependency tree of the outputs of DRV.  Do this
   ;; upfront to have as much parallelism as possible when querying substitute
@@ -314,6 +311,7 @@ DRV itself to refer to those grafted dependencies."
 
   (match (run-with-state
              (cumulative-grafts store drv grafts references
+                                #:outputs outputs
                                 #:guile guile #:system system)
            vlist-null)                            ;the initial cache
     ((first . rest)
diff --git a/guix/scripts/container/exec.scm b/guix/scripts/container/exec.scm
index 10e70568cc..d6d267daff 100644
--- a/guix/scripts/container/exec.scm
+++ b/guix/scripts/container/exec.scm
@@ -74,7 +74,14 @@ and the other containing arguments for the command to be executed."
       (let* ((opts (parse-command-line args %options '(())
                                        #:argument-handler
                                        handle-argument))
-             (pid  (assoc-ref opts 'pid)))
+             (pid  (assoc-ref opts 'pid))
+             (environment (filter-map (lambda (name)
+                                        (let ((value (getenv name)))
+                                          (and value (cons name value))))
+                                      ;; Pass through the TERM environment
+                                      ;; variable to inform processes about
+                                      ;; the capabilities of the terminal.
+                                      '("TERM"))))
 
         (unless pid
           (leave (_ "no pid specified~%")))
@@ -89,6 +96,10 @@ and the other containing arguments for the command to be executed."
                         (lambda ()
                           (match command
                             ((program . program-args)
+                             (for-each (match-lambda
+                                         ((name . value)
+                                          (setenv name value)))
+                                       environment)
                              (apply execlp program program program-args)))))))
           (unless (zero? result)
             (leave (_ "exec failed with status ~d~%") result)))))))