Merge branch 'master' into core-updates

3 files changed, 166 insertions, 99 deletions

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1c3209f905..31da773a53 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -24,6 +24,7 @@
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix profiles)
+  #:use-module (guix monads)
   #:use-module (guix utils)
   #:use-module (guix config)
   #:use-module (guix scripts build)
@@ -82,7 +83,8 @@ return PROFILE unchanged.  The goal is to treat '-p ~/.guix-profile' as if
 
 (define (link-to-empty-profile generation)
   "Link GENERATION, a string, to the empty profile."
-  (let* ((drv  (profile-derivation (%store) (manifest '())))
+  (let* ((drv  (run-with-store (%store)
+                 (profile-derivation (manifest '()))))
          (prof (derivation->output-path drv "out")))
     (when (not (build-derivations (%store) (list drv)))
           (leave (_ "failed to build the empty profile~%")))
@@ -205,10 +207,14 @@ packages that will/would be installed and removed."
                    remove))))
     (_ #f))
   (match install
-    ((($ <manifest-entry> name version output path _) ..1)
+    ((($ <manifest-entry> name version output item _) ..1)
      (let ((len     (length name))
-           (install (map (cut format #f "   ~a-~a\t~a\t~a" <> <> <> <>)
-                         name version output path)))
+           (install (map (lambda (name version output item)
+                           (format #f "   ~a-~a\t~a\t~a" name version output
+                                   (if (package? item)
+                                       (package-output (%store) item output)
+                                       item)))
+                         name version output item)))
        (if dry-run?
            (format (current-error-port)
                    (N_ "The following package would be installed:~%~{~a~%~}~%"
@@ -253,17 +259,6 @@ RX."
                 (package-name p2))))
    same-location?))
 
-(define (input->name+path input)
-  "Convert the name/package/sub-drv tuple INPUT to a name/store-path tuple."
-  (let loop ((input input))
-    (match input
-      ((name (? package? package))
-       (loop `(,name ,package "out")))
-      ((name (? package? package) sub-drv)
-       `(,name ,(package-output (%store) package sub-drv)))
-      (_
-       input))))
-
 (define %sigint-prompt
   ;; The prompt to jump to upon SIGINT.
   (make-prompt-tag "interruptible"))
@@ -517,6 +512,8 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
   (display (_ "
   -A, --list-available[=REGEXP]
                          list available packages matching REGEXP"))
+  (display (_ "
+  --show=PACKAGE         show details about PACKAGE"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -615,6 +612,11 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
                    (values (cons `(query list-available ,(or arg ""))
                                  result)
                            #f)))
+         (option '("show") #t #t
+                 (lambda (opt name arg result arg-handler)
+                   (values (cons `(query show ,arg)
+                                 result)
+                           #f)))
 
          %standard-build-options))
 
@@ -639,22 +641,11 @@ return the new list of manifest entries."
 
     (delete-duplicates deps same?))
 
-  (define (package->manifest-entry p output)
-    ;; Return a manifest entry for the OUTPUT of package P.
-    (check-package-freshness p)
+  (define (package->manifest-entry* package output)
+    (check-package-freshness package)
     ;; When given a package via `-e', install the first of its
     ;; outputs (XXX).
-    (let* ((output (or output (car (package-outputs p))))
-           (path   (package-output (%store) p output))
-           (deps   (deduplicate (package-transitive-propagated-inputs p))))
-      (manifest-entry
-       (name (package-name p))
-       (version (package-version p))
-       (output output)
-       (path path)
-       (dependencies (map input->name+path deps))
-       (inputs (cons (list (package-name p) p output)
-                     deps)))))
+    (package->manifest-entry package output))
 
   (define upgrade-regexps
     (filter-map (match-lambda
@@ -685,7 +676,7 @@ return the new list of manifest entries."
   (define to-upgrade
     (map (match-lambda
           ((package output)
-           (package->manifest-entry package output)))
+           (package->manifest-entry* package output)))
          packages-to-upgrade))
 
   (define packages-to-install
@@ -703,7 +694,7 @@ return the new list of manifest entries."
   (define to-install
     (append (map (match-lambda
                   ((package output)
-                   (package->manifest-entry package output)))
+                   (package->manifest-entry* package output)))
                  packages-to-install)
             (filter-map (match-lambda
                          (('install . (? package?))
@@ -716,7 +707,7 @@ return the new list of manifest entries."
                              (name name)
                              (version version)
                              (output #f)
-                             (path path))))
+                             (item path))))
                          (_ #f))
                         opts)))
 
@@ -743,6 +734,16 @@ removed from MANIFEST."
   (unless (string=? profile %current-profile)
     (add-indirect-root store (canonicalize-path profile))))
 
+(define (readlink* file)
+  "Call 'readlink' until the result is not a symlink."
+  (catch 'system-error
+    (lambda ()
+      (readlink* (readlink file)))
+    (lambda args
+      (if (= EINVAL (system-error-errno args))
+          file
+          (apply throw args)))))
+
 
 ;;;
 ;;; Entry point.
@@ -914,36 +915,41 @@ more information.~%"))
              (when (equal? profile %current-profile)
                (ensure-default-profile))
 
-             (if (manifest=? new manifest)
-                 (format (current-error-port) (_ "nothing to be done~%"))
-                 (let ((prof-drv (profile-derivation (%store) new))
-                       (remove   (manifest-matching-entries manifest remove)))
-                   (show-what-to-remove/install remove install dry-run?)
-                   (show-what-to-build (%store) (list prof-drv)
-                                       #:use-substitutes?
-                                       (assoc-ref opts 'substitutes?)
-                                       #:dry-run? dry-run?)
+             (unless (and (null? install) (null? remove))
+               (let* ((prof-drv (run-with-store (%store)
+                                  (profile-derivation new)))
+                      (prof     (derivation->output-path prof-drv))
+                      (remove   (manifest-matching-entries manifest remove)))
+                 (show-what-to-remove/install remove install dry-run?)
+                 (show-what-to-build (%store) (list prof-drv)
+                                     #:use-substitutes?
+                                     (assoc-ref opts 'substitutes?)
+                                     #:dry-run? dry-run?)
 
-                   (or dry-run?
-                       (let* ((prof   (derivation->output-path prof-drv))
-                              (number (generation-number profile))
+                 (cond
+                  (dry-run? #t)
+                  ((and (file-exists? profile)
+                        (and=> (readlink* profile) (cut string=? prof <>)))
+                   (format (current-error-port) (_ "nothing to be done~%")))
+                  (else
+                   (let* ((number (generation-number profile))
 
-                              ;; Always use NUMBER + 1 for the new profile,
-                              ;; possibly overwriting a "previous future
-                              ;; generation".
-                              (name   (generation-file-name profile
-                                                            (+ 1 number))))
-                         (and (build-derivations (%store) (list prof-drv))
-                              (let ((count (length entries)))
-                                (switch-symlinks name prof)
-                                (switch-symlinks profile name)
-                                (maybe-register-gc-root (%store) profile)
-                                (format #t (N_ "~a package in profile~%"
-                                               "~a packages in profile~%"
-                                               count)
-                                        count)
-                                (display-search-paths entries
-                                                      profile)))))))))))
+                          ;; Always use NUMBER + 1 for the new profile,
+                          ;; possibly overwriting a "previous future
+                          ;; generation".
+                          (name   (generation-file-name profile
+                                                        (+ 1 number))))
+                     (and (build-derivations (%store) (list prof-drv))
+                          (let ((count (length entries)))
+                            (switch-symlinks name prof)
+                            (switch-symlinks profile name)
+                            (maybe-register-gc-root (%store) profile)
+                            (format #t (N_ "~a package in profile~%"
+                                           "~a packages in profile~%"
+                                           count)
+                                    count)
+                            (display-search-paths entries
+                                                  profile))))))))))))
 
   (define (process-query opts)
     ;; Process any query specified by OPTS.  Return #t when a query was
@@ -1042,6 +1048,14 @@ more information.~%"))
                       (find-packages-by-description regexp)))
            #t))
 
+        (('show requested-name)
+         (let-values (((name version)
+                       (package-name->name+version requested-name)))
+           (leave-on-EPIPE
+            (for-each (cute package->recutils <> (current-output-port))
+                      (find-packages-by-name name version)))
+           #t))
+
         (('search-paths)
          (let* ((manifest (profile-manifest profile))
                 (entries  (manifest-entries manifest))
diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index af7beb748b..a91ea69b1f 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
+;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -29,6 +30,8 @@
   #:use-module ((gnu packages base) #:select (%final-inputs))
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
+  #:use-module (ice-9 vlist)
+  #:use-module (ice-9 format)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -59,6 +62,9 @@
                     (x
                      (leave (_ "~a: invalid selection; expected `core' or `non-core'")
                             arg)))))
+        (option '(#\l "list-dependent") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'list-dependent? #t result)))
 
         (option '("key-server") #t #f
                 (lambda (opt name arg result)
@@ -96,6 +102,9 @@ specified with `--select'.\n"))
   (display (_ "
   -s, --select=SUBSET    select all the packages in SUBSET, one of
                          `core' or `non-core'"))
+  (display (_ "
+  -l, --list-dependent   list top-level dependent packages that would need to
+                         be rebuilt as a result of upgrading PACKAGE..."))
   (newline)
   (display (_ "
       --key-server=HOST  use HOST as the OpenPGP key server"))
@@ -193,9 +202,10 @@ update would trigger a complete rebuild."
         ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
         (member (package-name package) names))))
 
-  (let* ((opts         (parse-options))
-         (update?      (assoc-ref opts 'update?))
-         (key-download (assoc-ref opts 'key-download))
+  (let* ((opts            (parse-options))
+         (update?         (assoc-ref opts 'update?))
+         (list-dependent? (assoc-ref opts 'list-dependent?))
+         (key-download    (assoc-ref opts 'key-download))
          (packages
           (match (concatenate
                   (filter-map (match-lambda
@@ -220,26 +230,48 @@ update would trigger a complete rebuild."
                  (some                        ; user-specified packages
                   some))))
     (with-error-handling
-      (if update?
-          (let ((store (open-connection)))
-            (parameterize ((%openpgp-key-server
-                            (or (assoc-ref opts 'key-server)
-                                (%openpgp-key-server)))
-                           (%gpg-command
-                            (or (assoc-ref opts 'gpg-command)
-                                (%gpg-command))))
-              (for-each
-               (cut update-package store <> #:key-download key-download)
-               packages)))
-          (for-each (lambda (package)
-                      (match (false-if-exception (package-update-path package))
-                        ((new-version . directory)
-                         (let ((loc (or (package-field-location package 'version)
-                                        (package-location package))))
-                           (format (current-error-port)
-                                   (_ "~a: ~a would be upgraded from ~a to ~a~%")
-                                   (location->string loc)
-                                   (package-name package) (package-version package)
-                                   new-version)))
-                        (_ #f)))
-                    packages)))))
+      (cond
+       (list-dependent?
+        (let* ((rebuilds (map package-full-name
+                              (package-covering-dependents packages)))
+               (total-dependents
+                (length (package-transitive-dependents packages))))
+          (if (= total-dependents 0)
+              (format (current-output-port)
+                      (N_ "No dependents other than itself: ~{~a~}~%"
+                          "No dependents other than themselves: ~{~a~^ ~}~%"
+                          (length packages))
+                      (map package-full-name packages))
+              (format (current-output-port)
+                      (N_ (N_ "A single dependent package: ~2*~{~a~}~%"
+                              "Building the following package would ensure ~d \
+dependent packages are rebuilt; ~*~{~a~^ ~}~%"
+                              total-dependents)
+                          "Building the following ~d packages would ensure ~d \
+dependent packages are rebuilt: ~{~a~^ ~}~%"
+                          (length rebuilds))
+                      (length rebuilds) total-dependents rebuilds))))
+       (update?
+        (let ((store (open-connection)))
+          (parameterize ((%openpgp-key-server
+                          (or (assoc-ref opts 'key-server)
+                              (%openpgp-key-server)))
+                         (%gpg-command
+                          (or (assoc-ref opts 'gpg-command)
+                              (%gpg-command))))
+            (for-each
+             (cut update-package store <> #:key-download key-download)
+             packages))))
+       (else
+        (for-each (lambda (package)
+                    (match (false-if-exception (package-update-path package))
+                      ((new-version . directory)
+                       (let ((loc (or (package-field-location package 'version)
+                                      (package-location package))))
+                         (format (current-error-port)
+                                 (_ "~a: ~a would be upgraded from ~a to ~a~%")
+                                 (location->string loc)
+                                 (package-name package) (package-version package)
+                                 new-version)))
+                      (_ #f)))
+                  packages))))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 66ad9192c1..4f1869af38 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -95,8 +95,8 @@
   (store-lift show-what-to-build))
 
 
-(define* (copy-closure item target
-                       #:key (log-port (current-error-port)))
+(define* (copy-item item target
+                    #:key (log-port (current-error-port)))
   "Copy ITEM to the store under root directory TARGET and register it."
   (mlet* %store-monad ((refs (references* item)))
     (let ((dest  (string-append target item))
@@ -118,6 +118,18 @@
 
       (return #t))))
 
+(define* (copy-closure item target
+                       #:key (log-port (current-error-port)))
+  "Copy ITEM and all its dependencies to the store under root directory
+TARGET, and register them."
+  (mlet* %store-monad ((refs    (references* item))
+                       (to-copy (topologically-sorted*
+                                 (delete-duplicates (cons item refs)
+                                                    string=?))))
+    (sequence %store-monad
+              (map (cut copy-item <> target #:log-port log-port)
+                   to-copy))))
+
 (define* (install os-drv target
                   #:key (log-port (current-output-port))
                   grub? grub.cfg device)
@@ -136,16 +148,10 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
             (mkdir-p (string-append target (%store-prefix)))
 
             ;; Copy items to the new store.
-            (sequence %store-monad
-                      (map (cut copy-closure <> target #:log-port log-port)
-                           to-copy))))))
+            (copy-closure to-copy target #:log-port log-port)))))
 
   (mlet* %store-monad ((os-dir -> (derivation->output-path os-drv))
-                       (refs      (references* os-dir))
-                       (lst    -> (delete-duplicates (cons os-dir refs)
-                                                     string=?))
-                       (to-copy   (topologically-sorted* lst))
-                       (%         (maybe-copy to-copy)))
+                       (%         (maybe-copy os-dir)))
 
     ;; Create a bunch of additional files.
     (format log-port "populating '~a'...~%" target)
@@ -166,6 +172,16 @@ When GRUB? is true, install GRUB on DEVICE, using GRUB.CFG."
   ;; The system profile.
   (string-append %state-directory "/profiles/system"))
 
+(define-syntax-rule (save-environment-excursion body ...)
+  "Save the current environment variables, run BODY..., and restore them."
+  (let ((env (environ)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        body ...)
+      (lambda ()
+        (environ env)))))
+
 (define* (switch-to-system os
                            #:optional (profile %system-profile))
   "Make a new generation of PROFILE pointing to the directory of OS, switch to
@@ -179,7 +195,11 @@ it atomically, and then run OS's activation script."
       (switch-symlinks profile generation)
 
       (format #t (_ "activating system...~%"))
-      (return (primitive-load (derivation->output-path script)))
+
+      ;; The activation script may change $PATH, among others, so protect
+      ;; against that.
+      (return (save-environment-excursion
+               (primitive-load (derivation->output-path script))))
 
       ;; TODO: Run 'deco reload ...'.
       )))
@@ -293,7 +313,8 @@ actions."
              (mlet %store-monad ((% (switch-to-system os)))
                (when grub?
                  (unless (false-if-exception
-                          (install-grub grub.cfg device "/"))
+                          (install-grub (derivation->output-path grub.cfg)
+                                        device "/"))
                    (leave (_ "failed to install GRUB on device '~a'~%")
                           device)))
                (return #t)))