mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 13:58:15 -05:00
refresh: Add `--select'.
* guix/scripts/refresh.scm (%options): Add `--select'. (show-help): Likewise. Augment initial help text. (guix-refresh)[core-package?]: New procedure. Use it when selecting packages.
This commit is contained in:
parent
1c9e7d65d4
commit
37a5340262
1 changed files with 82 additions and 37 deletions
|
@ -23,6 +23,7 @@ (define-module (guix scripts refresh)
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix gnu-maintenance)
|
#:use-module (guix gnu-maintenance)
|
||||||
#:use-module (gnu packages)
|
#:use-module (gnu packages)
|
||||||
|
#:use-module ((gnu packages base) #:select (%final-inputs))
|
||||||
#:use-module (ice-9 match)
|
#:use-module (ice-9 match)
|
||||||
#:use-module (ice-9 regex)
|
#:use-module (ice-9 regex)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
@ -46,6 +47,15 @@ (define %options
|
||||||
(list (option '(#\n "dry-run") #f #f
|
(list (option '(#\n "dry-run") #f #f
|
||||||
(lambda (opt name arg result)
|
(lambda (opt name arg result)
|
||||||
(alist-cons 'dry-run? #t result)))
|
(alist-cons 'dry-run? #t result)))
|
||||||
|
(option '(#\s "select") #t #f
|
||||||
|
(lambda (opt name arg result)
|
||||||
|
(match arg
|
||||||
|
((or "core" "non-core")
|
||||||
|
(alist-cons 'select (string->symbol arg)
|
||||||
|
result))
|
||||||
|
(x
|
||||||
|
(leave (_ "~a: invalid selection; expected `core' or `non-core'")
|
||||||
|
arg)))))
|
||||||
|
|
||||||
(option '(#\h "help") #f #f
|
(option '(#\h "help") #f #f
|
||||||
(lambda args
|
(lambda args
|
||||||
|
@ -57,9 +67,16 @@ (define %options
|
||||||
|
|
||||||
(define (show-help)
|
(define (show-help)
|
||||||
(display (_ "Usage: guix refresh [OPTION]... PACKAGE...
|
(display (_ "Usage: guix refresh [OPTION]... PACKAGE...
|
||||||
Update package definitions to match the latest upstream version.\n"))
|
Update package definitions to match the latest upstream version.
|
||||||
|
|
||||||
|
When PACKAGE... is given, update only the specified packages. Otherwise
|
||||||
|
update all the packages of the distribution, or the subset thereof
|
||||||
|
specified with `--select'.\n"))
|
||||||
(display (_ "
|
(display (_ "
|
||||||
-n, --dry-run do not build the derivations"))
|
-n, --dry-run do not build the derivations"))
|
||||||
|
(display (_ "
|
||||||
|
-s, --select=SUBSET select all the packages in SUBSET, one of
|
||||||
|
`core' or `non-core'"))
|
||||||
(newline)
|
(newline)
|
||||||
(display (_ "
|
(display (_ "
|
||||||
-h, --help display this help and exit"))
|
-h, --help display this help and exit"))
|
||||||
|
@ -83,6 +100,26 @@ (define (parse-options)
|
||||||
(alist-cons 'argument arg result))
|
(alist-cons 'argument arg result))
|
||||||
%default-options))
|
%default-options))
|
||||||
|
|
||||||
|
(define core-package?
|
||||||
|
(let* ((input->package (match-lambda
|
||||||
|
((name (? package? package) _ ...) package)
|
||||||
|
(_ #f)))
|
||||||
|
(final-inputs (map input->package %final-inputs))
|
||||||
|
(core (append final-inputs
|
||||||
|
(append-map (compose (cut filter-map input->package <>)
|
||||||
|
package-transitive-inputs)
|
||||||
|
final-inputs)))
|
||||||
|
(names (delete-duplicates (map package-name core))))
|
||||||
|
(lambda (package)
|
||||||
|
"Return true if PACKAGE is likely a \"core package\"---i.e., one whose
|
||||||
|
update would trigger a complete rebuild."
|
||||||
|
;; Compare by name because packages in base.scm basically inherit
|
||||||
|
;; other packages. So, even if those packages are not core packages
|
||||||
|
;; themselves, updating them would also update those who inherit from
|
||||||
|
;; them.
|
||||||
|
;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
|
||||||
|
(member (package-name package) names))))
|
||||||
|
|
||||||
(let* ((opts (parse-options))
|
(let* ((opts (parse-options))
|
||||||
(dry-run? (assoc-ref opts 'dry-run?))
|
(dry-run? (assoc-ref opts 'dry-run?))
|
||||||
(packages (match (concatenate
|
(packages (match (concatenate
|
||||||
|
@ -96,42 +133,50 @@ (define (parse-options)
|
||||||
(_ #f))
|
(_ #f))
|
||||||
opts))
|
opts))
|
||||||
(() ; default to all packages
|
(() ; default to all packages
|
||||||
;; TODO: Keep only the newest of each package.
|
(let ((select? (match (assoc-ref opts 'select)
|
||||||
(fold-packages cons '()))
|
('core core-package?)
|
||||||
|
('non-core (negate core-package?))
|
||||||
|
(_ (const #t)))))
|
||||||
|
;; TODO: Keep only the newest of each package.
|
||||||
|
(fold-packages (lambda (package result)
|
||||||
|
(if (select? package)
|
||||||
|
(cons package result)
|
||||||
|
result))
|
||||||
|
'())))
|
||||||
(some ; user-specified packages
|
(some ; user-specified packages
|
||||||
some))))
|
some))))
|
||||||
(with-error-handling
|
(with-error-handling
|
||||||
(if dry-run?
|
(if dry-run?
|
||||||
(for-each (lambda (package)
|
(for-each (lambda (package)
|
||||||
(match (false-if-exception (package-update-path package))
|
(match (false-if-exception (package-update-path package))
|
||||||
((new-version . directory)
|
((new-version . directory)
|
||||||
(let ((loc (or (package-field-location package 'version)
|
(let ((loc (or (package-field-location package 'version)
|
||||||
(package-location package))))
|
(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)
|
|
||||||
(let ((store (open-connection)))
|
|
||||||
(for-each (lambda (package)
|
|
||||||
(let-values (((version tarball)
|
|
||||||
(catch #t
|
|
||||||
(lambda ()
|
|
||||||
(package-update store package))
|
|
||||||
(lambda _
|
|
||||||
(values #f #f))))
|
|
||||||
((loc)
|
|
||||||
(or (package-field-location package
|
|
||||||
'version)
|
|
||||||
(package-location package))))
|
|
||||||
(when version
|
|
||||||
(format (current-error-port)
|
(format (current-error-port)
|
||||||
(_ "~a: ~a: updating from version ~a to version ~a...~%")
|
(_ "~a: ~a would be upgraded from ~a to ~a~%")
|
||||||
(location->string loc) (package-name package)
|
(location->string loc)
|
||||||
(package-version package) version)
|
(package-name package) (package-version package)
|
||||||
(let ((hash (call-with-input-file tarball
|
new-version)))
|
||||||
(compose sha256 get-bytevector-all))))
|
(_ #f)))
|
||||||
(update-package-source package version hash)))))
|
packages)
|
||||||
packages))))))
|
(let ((store (open-connection)))
|
||||||
|
(for-each (lambda (package)
|
||||||
|
(let-values (((version tarball)
|
||||||
|
(catch #t
|
||||||
|
(lambda ()
|
||||||
|
(package-update store package))
|
||||||
|
(lambda _
|
||||||
|
(values #f #f))))
|
||||||
|
((loc)
|
||||||
|
(or (package-field-location package
|
||||||
|
'version)
|
||||||
|
(package-location package))))
|
||||||
|
(when version
|
||||||
|
(format (current-error-port)
|
||||||
|
(_ "~a: ~a: updating from version ~a to version ~a...~%")
|
||||||
|
(location->string loc) (package-name package)
|
||||||
|
(package-version package) version)
|
||||||
|
(let ((hash (call-with-input-file tarball
|
||||||
|
(compose sha256 get-bytevector-all))))
|
||||||
|
(update-package-source package version hash)))))
|
||||||
|
packages))))))
|
||||||
|
|
Loading…
Reference in a new issue