nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

guix gc: Correctly handle '--delete-generations' with no arguments. 

Previously, 'guix gc --delete-generations' would crash: the "" pattern
would be passed to 'matching-generations', which would return #f instead
of returning a list.

Reported by Raghav Gururajan <rvgn@disroot.org>
in <https://bugs.gnu.org/36466>.

* guix/ui.scm (matching-generations): Raise an error when passed an
invalid pattern.
* guix/scripts/gc.scm (delete-old-generations): Check if PATTERN is
true.
(%options): Leave ARG as-is for 'delete-generations'.
(guix-gc): Use 'assq' instead of 'assoc-ref' for 'delete-generations'.
* guix/scripts/package.scm (delete-matching-generations):
Replace (string-null? pattern) with (not pattern).  Remove 'else'
clause.
(%options): Leave ARG as-is for 'delete-generations'.
* guix/scripts/pull.scm (%options): Leave ARG as-is for
'list-generations'.
(process-query): Replace (string-null? pattern) with (not pattern).
* guix/scripts/system.scm (list-generations): Likewise, and remove
'else' clause.
(process-command): Use #f instead of "" when no pattern is given.
This commit is contained in:
Ludovic Courtès 2019-07-10 19:58:30 +02:00
parent 878a6baa4c
commit 5c3d44303e
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 27 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
guix/scripts/gc.scm
View File

@ -104,11 +104,14 @@ Invoke the garbage collector.\n"))
'())))) '()))))
(define (delete-old-generations store profile pattern) (define (delete-old-generations store profile pattern)
"Remove the generations of PROFILE that match PATTERN, a duration pattern. "Remove the generations of PROFILE that match PATTERN, a duration pattern;
Do nothing if none matches." do nothing if none matches. If PATTERN is #f, delete all generations but the
current one."
(let* ((current (generation-number profile)) (let* ((current (generation-number profile))
(numbers (matching-generations pattern profile (numbers (if (not pattern)
#:duration-relation >))) (profile-generations profile)
(matching-generations pattern profile
#:duration-relation >))))
;; Make sure we don't inadvertently remove the current generation. ;; Make sure we don't inadvertently remove the current generation.
(delete-generations store profile (delv current numbers)))) (delete-generations store profile (delv current numbers))))
@ -155,8 +158,7 @@ is deprecated; use '-D'~%"))
(when (and arg (not (string->duration arg))) (when (and arg (not (string->duration arg)))
(leave (G_ "~s does not denote a duration~%") (leave (G_ "~s does not denote a duration~%")
arg)) arg))
(alist-cons 'delete-generations (or arg "") (alist-cons 'delete-generations arg result)))))
result)))))
(option '("optimize") #f #f (option '("optimize") #f #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'action 'optimize (alist-cons 'action 'optimize
@ -287,9 +289,9 @@ is deprecated; use '-D'~%"))
(assert-no-extra-arguments) (assert-no-extra-arguments)
(let ((min-freed (assoc-ref opts 'min-freed)) (let ((min-freed (assoc-ref opts 'min-freed))
(free-space (assoc-ref opts 'free-space))) (free-space (assoc-ref opts 'free-space)))
(match (assoc-ref opts 'delete-generations) (match (assq 'delete-generations opts)
(#f #t) (#f #t)
((? string? pattern) ((_ . pattern)
(delete-generations store pattern))) (delete-generations store pattern)))
(cond (cond
(free-space (free-space

17
guix/scripts/package.scm
View File

@ -98,7 +98,7 @@ denote ranges as interpreted by 'matching-generations'."
(cond ((not (file-exists? profile)) ; XXX: race condition (cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error (raise (condition (&profile-not-found-error
(profile profile))))) (profile profile)))))
((string-null? pattern) ((not pattern)
(delete-generations store profile (delete-generations store profile
(delv current (profile-generations profile)))) (delv current (profile-generations profile))))
;; Do not delete the zeroth generation. ;; Do not delete the zeroth generation.
@ -120,9 +120,7 @@ denote ranges as interpreted by 'matching-generations'."
(let ((numbers (delv current numbers))) (let ((numbers (delv current numbers)))
(when (null-list? numbers) (when (null-list? numbers)
(leave (G_ "no matching generation~%"))) (leave (G_ "no matching generation~%")))
(delete-generations store profile numbers)))) (delete-generations store profile numbers)))))))
(else
(leave (G_ "invalid syntax: ~a~%") pattern)))))
(define* (build-and-use-profile store profile manifest (define* (build-and-use-profile store profile manifest
#:key #:key
@ -457,12 +455,12 @@ command-line option~%")
arg-handler))) arg-handler)))
(option '(#\l "list-generations") #f #t (option '(#\l "list-generations") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (cons `(query list-generations ,(or arg "")) (values (cons `(query list-generations ,arg)
result) result)
#f))) #f)))
(option '(#\d "delete-generations") #f #t (option '(#\d "delete-generations") #f #t
(lambda (opt name arg result arg-handler) (lambda (opt name arg result arg-handler)
(values (alist-cons 'delete-generations (or arg "") (values (alist-cons 'delete-generations arg
result) result)
#f))) #f)))
(option '(#\S "switch-generation") #t #f (option '(#\S "switch-generation") #t #f
@ -683,7 +681,7 @@ processed, #f otherwise."
(cond ((not (file-exists? profile)) ; XXX: race condition (cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error (raise (condition (&profile-not-found-error
(profile profile))))) (profile profile)))))
((string-null? pattern) ((not pattern)
(match (profile-generations profile) (match (profile-generations profile)
(() (()
#t) #t)
@ -697,10 +695,7 @@ processed, #f otherwise."
(exit 1) (exit 1)
(begin (begin
(list-generation display-profile-content (car numbers)) (list-generation display-profile-content (car numbers))
(diff-profiles profile numbers))))) (diff-profiles profile numbers)))))))
(else
(leave (G_ "invalid syntax: ~a~%")
pattern))))
#t) #t)
(('list-installed regexp) (('list-installed regexp)

4
guix/scripts/pull.scm
View File

@ -117,7 +117,7 @@ Download and deploy the latest version of Guix.\n"))
(alist-cons 'channel-file arg result))) (alist-cons 'channel-file arg result)))
(option '(#\l "list-generations") #f #t (option '(#\l "list-generations") #f #t
(lambda (opt name arg result) (lambda (opt name arg result)
(cons `(query list-generations ,(or arg "")) (cons `(query list-generations ,arg)
result))) result)))
(option '(#\N "news") #f #f (option '(#\N "news") #f #f
(lambda (opt name arg result) (lambda (opt name arg result)
@ -486,7 +486,7 @@ list of package changes.")))))
(cond ((not (file-exists? profile)) ; XXX: race condition (cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error (raise (condition (&profile-not-found-error
(profile profile))))) (profile profile)))))
((string-null? pattern) ((not pattern)
(list-generations profile (profile-generations profile))) (list-generations profile (profile-generations profile)))
((matching-generations pattern profile) ((matching-generations pattern profile)
=> =>

10
guix/scripts/system.scm
View File

@ -614,7 +614,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations."
(cond ((not (file-exists? profile)) ; XXX: race condition (cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error (raise (condition (&profile-not-found-error
(profile profile))))) (profile profile)))))
((string-null? pattern) ((not pattern)
(for-each display-system-generation (profile-generations profile))) (for-each display-system-generation (profile-generations profile)))
((matching-generations pattern profile) ((matching-generations pattern profile)
=> =>
@ -622,9 +622,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations."
(if (null-list? numbers) (if (null-list? numbers)
(exit 1) (exit 1)
(leave-on-EPIPE (leave-on-EPIPE
(for-each display-system-generation numbers))))) (for-each display-system-generation numbers)))))))
(else
(leave (G_ "invalid syntax: ~a~%") pattern))))
;;; ;;;
@ -1232,7 +1230,7 @@ argument list and OPTS is the option alist."
;; an operating system configuration file. ;; an operating system configuration file.
((list-generations) ((list-generations)
(let ((pattern (match args (let ((pattern (match args
(() "") (() #f)
((pattern) pattern) ((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%")))))) (x (leave (G_ "wrong number of arguments~%"))))))
(list-generations pattern))) (list-generations pattern)))
@ -1242,7 +1240,7 @@ argument list and OPTS is the option alist."
;; operating system configuration file. ;; operating system configuration file.
((delete-generations) ((delete-generations)
(let ((pattern (match args (let ((pattern (match args
(() "") (() #f)
((pattern) pattern) ((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%")))))) (x (leave (G_ "wrong number of arguments~%"))))))
(with-store store (with-store store

6
guix/ui.scm
View File

@ -1484,7 +1484,11 @@ DURATION-RELATION with the current time."
((string->duration str) ((string->duration str)
=> =>
filter-by-duration) filter-by-duration)
(else #f))) (else
(raise
(condition (&message
(message (format #f (G_ "invalid syntax: ~a~%")
str))))))))
(define (display-generation profile number) (define (display-generation profile number)
"Display a one-line summary of generation NUMBER of PROFILE." "Display a one-line summary of generation NUMBER of PROFILE."