summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/package.scm357
1 files changed, 189 insertions, 168 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 84a33782da..c71cf8e76c 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -421,41 +421,43 @@ VERSION."
((_ version pkgs ...) pkgs)
(#f '()))))
-(define* (find-package name #:optional (output "out"))
- "Find the package NAME; NAME may contain a version number and a
-sub-derivation name. If the version number is not present, return the
-preferred newest version. If the sub-derivation name is not present, use
-OUTPUT."
- (define request name)
+(define* (specification->package+output spec #:optional (output "out"))
+ "Find the package and output specified by SPEC, or #f and #f; SPEC may
+optionally contain a version number and an output name, as in these examples:
+ guile
+ guile-2.0.9
+ guile:debug
+ guile-2.0.9:debug
+
+If SPEC does not specify a version number, return the preferred newest
+version; if SPEC does not specify an output, return OUTPUT."
(define (ensure-output p sub-drv)
(if (member sub-drv (package-outputs p))
- p
+ sub-drv
(leave (_ "package `~a' lacks output `~a'~%")
(package-full-name p)
sub-drv)))
(let*-values (((name sub-drv)
- (match (string-rindex name #\:)
- (#f (values name output))
- (colon (values (substring name 0 colon)
- (substring name (+ 1 colon))))))
+ (match (string-rindex spec #\:)
+ (#f (values spec output))
+ (colon (values (substring spec 0 colon)
+ (substring spec (+ 1 colon))))))
((name version)
(package-name->name+version name)))
(match (find-best-packages-by-name name version)
((p)
- (list name (package-version p) sub-drv (ensure-output p sub-drv)
- (package-transitive-propagated-inputs p)))
+ (values p (ensure-output p sub-drv)))
((p p* ...)
(warning (_ "ambiguous package specification `~a'~%")
- request)
+ spec)
(warning (_ "choosing ~a from ~a~%")
(package-full-name p)
(location->string (package-location p)))
- (list name (package-version p) sub-drv (ensure-output p sub-drv)
- (package-transitive-propagated-inputs p)))
+ (values p (ensure-output p sub-drv)))
(()
- (leave (_ "~a: package not found~%") request)))))
+ (leave (_ "~a: package not found~%") spec)))))
(define (upgradeable? name current-version current-path)
"Return #t if there's a version of package NAME newer than CURRENT-VERSION,
@@ -707,6 +709,112 @@ Install, remove, or upgrade PACKAGES in a single transaction.\n"))
(cons `(query list-available ,(or arg ""))
result)))))
+(define (options->installable opts installed)
+ "Given INSTALLED, the set of currently installed packages, and OPTS, the
+result of 'args-fold', return two values: the new list of manifest entries,
+and the list of derivations that need to be built."
+ (define (canonicalize-deps deps)
+ ;; Remove duplicate entries from DEPS, a list of propagated inputs,
+ ;; where each input is a name/path tuple.
+ (define (same? d1 d2)
+ (match d1
+ ((_ p1)
+ (match d2
+ ((_ p2) (eq? p1 p2))
+ (_ #f)))
+ ((_ p1 out1)
+ (match d2
+ ((_ p2 out2)
+ (and (string=? out1 out2)
+ (eq? p1 p2)))
+ (_ #f)))))
+
+ (delete-duplicates deps same?))
+
+ (define* (package->tuple p #:optional output)
+ ;; Convert package P to a manifest tuple.
+ ;; When given a package via `-e', install the first of its
+ ;; outputs (XXX).
+ (check-package-freshness p)
+ (let* ((output (or output (car (package-outputs p))))
+ (path (package-output (%store) p output))
+ (deps (package-transitive-propagated-inputs p)))
+ `(,(package-name p)
+ ,(package-version p)
+ ,output
+ ,path
+ ,(canonicalize-deps deps))))
+
+ (define upgrade-regexps
+ (filter-map (match-lambda
+ (('upgrade . regexp)
+ (make-regexp (or regexp "")))
+ (_ #f))
+ opts))
+
+ (define packages-to-upgrade
+ (match upgrade-regexps
+ (()
+ '())
+ ((_ ...)
+ (let ((newest (find-newest-available-packages)))
+ (filter-map (match-lambda
+ ((name version output path _)
+ (and (any (cut regexp-exec <> name)
+ upgrade-regexps)
+ (upgradeable? name version path)
+ (let ((output (or output "out")))
+ (call-with-values
+ (lambda ()
+ (specification->package+output name output))
+ list))))
+ (_ #f))
+ installed)))))
+
+ (define to-upgrade
+ (map (match-lambda
+ ((package output)
+ (package->tuple package output)))
+ packages-to-upgrade))
+
+ (define packages-to-install
+ (filter-map (match-lambda
+ (('install . (? package? p))
+ (list p "out"))
+ (('install . (? string? spec))
+ (and (not (store-path? spec))
+ (let-values (((package output)
+ (specification->package+output spec)))
+ (and package (list package output)))))
+ (_ #f))
+ opts))
+
+ (define to-install
+ (append (map (match-lambda
+ ((package output)
+ (package->tuple package output)))
+ packages-to-install)
+ (filter-map (match-lambda
+ (('install . (? package?))
+ #f)
+ (('install . (? store-path? path))
+ (let-values (((name version)
+ (package-name->name+version
+ (store-path-package-name path))))
+ `(,name ,version #f ,path ())))
+ (_ #f))
+ opts)))
+
+ (define derivations
+ (map (match-lambda
+ ((package output)
+ ;; FIXME: We should really depend on just OUTPUT rather than on all
+ ;; the outputs of PACKAGE.
+ (package-derivation (%store) package)))
+ (append packages-to-install packages-to-upgrade)))
+
+ (values (append to-upgrade to-install) derivations))
+
;;;
;;; Entry point.
@@ -780,43 +888,12 @@ more information.~%"))
(define verbose? (assoc-ref opts 'verbose?))
(define profile (assoc-ref opts 'profile))
- (define (canonicalize-deps deps)
- ;; Remove duplicate entries from DEPS, a list of propagated inputs,
- ;; where each input is a name/path tuple.
- (define (same? d1 d2)
- (match d1
- ((_ p1)
- (match d2
- ((_ p2) (eq? p1 p2))
- (_ #f)))
- ((_ p1 out1)
- (match d2
- ((_ p2 out2)
- (and (string=? out1 out2)
- (eq? p1 p2)))
- (_ #f)))))
-
- (delete-duplicates deps same?))
-
(define (same-package? tuple name out)
(match tuple
((tuple-name _ tuple-output _ ...)
(and (equal? name tuple-name)
(equal? out tuple-output)))))
- (define (package->tuple p)
- ;; Convert package P to a tuple.
- ;; When given a package via `-e', install the first of its
- ;; outputs (XXX).
- (let* ((out (car (package-outputs p)))
- (path (package-output (%store) p out))
- (deps (package-transitive-propagated-inputs p)))
- `(,(package-name p)
- ,(package-version p)
- ,out
- ,p
- ,(canonicalize-deps deps))))
-
(define (show-what-to-remove/install remove install dry-run?)
;; Tell the user what's going to happen in high-level terms.
;; TODO: Report upgrades more clearly.
@@ -922,127 +999,71 @@ more information.~%"))
(_ #f))
opts))
(else
- (let* ((installed (manifest-packages (profile-manifest profile)))
- (upgrade-regexps (filter-map (match-lambda
- (('upgrade . regexp)
- (make-regexp (or regexp "")))
- (_ #f))
- opts))
- (upgrade (if (null? upgrade-regexps)
- '()
- (let ((newest (find-newest-available-packages)))
- (filter-map
- (match-lambda
- ((name version output path _)
- (and (any (cut regexp-exec <> name)
- upgrade-regexps)
- (upgradeable? name version path)
- (find-package name
- (or output "out"))))
- (_ #f))
- installed))))
- (install (append
- upgrade
- (filter-map (match-lambda
- (('install . (? package? p))
- (package->tuple p))
- (('install . (? store-path?))
- #f)
- (('install . package)
- (find-package package))
+ (let*-values (((installed)
+ (manifest-packages (profile-manifest profile)))
+ ((install* drv)
+ (options->installable opts installed)))
+ (let* ((remove (filter-map (match-lambda
+ (('remove . package)
+ package)
(_ #f))
- opts)))
- (drv (filter-map (match-lambda
- ((name version sub-drv
- (? package? package)
- (deps ...))
- (check-package-freshness package)
- (package-derivation (%store) package))
- (_ #f))
- install))
- (install*
- (append
- (filter-map (match-lambda
- (('install . (? package? p))
- #f)
- (('install . (? store-path? path))
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name
- path))))
- `(,name ,version #f ,path ())))
- (_ #f))
- opts)
- (map (lambda (tuple drv)
- (match tuple
- ((name version sub-drv _ (deps ...))
- (let ((output-path
- (derivation->output-path
- drv sub-drv)))
- `(,name ,version ,sub-drv ,output-path
- ,(canonicalize-deps deps))))))
- install drv)))
- (remove (filter-map (match-lambda
- (('remove . package)
- package)
- (_ #f))
- opts))
- (remove* (filter-map (cut assoc <> installed) remove))
- (packages
- (append install*
- (fold (lambda (package result)
- (match package
- ((name _ out _ ...)
- (filter (negate
- (cut same-package? <>
- name out))
- result))))
- (fold alist-delete installed remove)
- install*))))
-
- (when (equal? profile %current-profile)
- (ensure-default-profile))
-
- (show-what-to-remove/install remove* install* dry-run?)
- (show-what-to-build (%store) drv
- #:use-substitutes? (assoc-ref opts 'substitutes?)
- #:dry-run? dry-run?)
-
- (or dry-run?
- (and (build-derivations (%store) drv)
- (let* ((prof-drv (profile-derivation (%store) packages))
- (prof (derivation->output-path prof-drv))
- (old-drv (profile-derivation
- (%store) (manifest-packages
- (profile-manifest profile))))
- (old-prof (derivation->output-path old-drv))
- (number (generation-number profile))
-
- ;; Always use NUMBER + 1 for the new profile,
- ;; possibly overwriting a "previous future
- ;; generation".
- (name (format #f "~a-~a-link"
- profile (+ 1 number))))
- (if (string=? old-prof prof)
- (when (or (pair? install) (pair? remove))
- (format (current-error-port)
- (_ "nothing to be done~%")))
- (and (parameterize ((current-build-output-port
- ;; Output something when Guile
- ;; needs to be built.
- (if (or verbose? (guile-missing?))
- (current-error-port)
- (%make-void-port "w"))))
- (build-derivations (%store) (list prof-drv)))
- (let ((count (length packages)))
- (switch-symlinks name prof)
- (switch-symlinks profile name)
- (format #t (N_ "~a package in profile~%"
- "~a packages in profile~%"
- count)
- count)
- (display-search-paths packages
- profile)))))))))))
+ opts))
+ (remove* (filter-map (cut assoc <> installed) remove))
+ (packages
+ (append install*
+ (fold (lambda (package result)
+ (match package
+ ((name _ out _ ...)
+ (filter (negate
+ (cut same-package? <>
+ name out))
+ result))))
+ (fold alist-delete installed remove)
+ install*))))
+
+ (when (equal? profile %current-profile)
+ (ensure-default-profile))
+
+ (show-what-to-remove/install remove* install* dry-run?)
+ (show-what-to-build (%store) drv
+ #:use-substitutes? (assoc-ref opts 'substitutes?)
+ #:dry-run? dry-run?)
+
+ (or dry-run?
+ (and (build-derivations (%store) drv)
+ (let* ((prof-drv (profile-derivation (%store) packages))
+ (prof (derivation->output-path prof-drv))
+ (old-drv (profile-derivation
+ (%store) (manifest-packages
+ (profile-manifest profile))))
+ (old-prof (derivation->output-path old-drv))
+ (number (generation-number profile))
+
+ ;; Always use NUMBER + 1 for the new profile,
+ ;; possibly overwriting a "previous future
+ ;; generation".
+ (name (format #f "~a-~a-link"
+ profile (+ 1 number))))
+ (if (string=? old-prof prof)
+ (when (or (pair? install*) (pair? remove))
+ (format (current-error-port)
+ (_ "nothing to be done~%")))
+ (and (parameterize ((current-build-output-port
+ ;; Output something when Guile
+ ;; needs to be built.
+ (if (or verbose? (guile-missing?))
+ (current-error-port)
+ (%make-void-port "w"))))
+ (build-derivations (%store) (list prof-drv)))
+ (let ((count (length packages)))
+ (switch-symlinks name prof)
+ (switch-symlinks profile name)
+ (format #t (N_ "~a package in profile~%"
+ "~a packages in profile~%"
+ count)
+ count)
+ (display-search-paths packages
+ profile))))))))))))
(define (process-query opts)
;; Process any query specified by OPTS. Return #t when a query was
generated by cgit v1.2.3 (git 2.46.2) at 2024-11-11 21:05:38 +0000