diff options
author | Ludovic Courtès <ludo@gnu.org> | 2019-07-10 19:58:30 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2019-07-11 23:13:26 +0200 |
commit | 5c3d44303e1bb75d45334af5cf86cde723da0371 (patch) | |
tree | c9827bb70c4d12c792bf24042a38ffdd36f879af | |
parent | 878a6baa4c705f4d551b60c5aa254246e0abc922 (diff) | |
download | patches-5c3d44303e1bb75d45334af5cf86cde723da0371.tar patches-5c3d44303e1bb75d45334af5cf86cde723da0371.tar.gz |
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.
-rw-r--r-- | guix/scripts/gc.scm | 18 | ||||
-rw-r--r-- | guix/scripts/package.scm | 17 | ||||
-rw-r--r-- | guix/scripts/pull.scm | 4 | ||||
-rw-r--r-- | guix/scripts/system.scm | 10 | ||||
-rw-r--r-- | guix/ui.scm | 6 |
5 files changed, 27 insertions, 28 deletions
diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 9a57e5fd1e..31657326b6 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -104,11 +104,14 @@ Invoke the garbage collector.\n")) '())))) (define (delete-old-generations store profile pattern) - "Remove the generations of PROFILE that match PATTERN, a duration pattern. -Do nothing if none matches." + "Remove the generations of PROFILE that match PATTERN, a duration pattern; +do nothing if none matches. If PATTERN is #f, delete all generations but the +current one." (let* ((current (generation-number profile)) - (numbers (matching-generations pattern profile - #:duration-relation >))) + (numbers (if (not pattern) + (profile-generations profile) + (matching-generations pattern profile + #:duration-relation >)))) ;; Make sure we don't inadvertently remove the current generation. (delete-generations store profile (delv current numbers)))) @@ -155,8 +158,7 @@ is deprecated; use '-D'~%")) (when (and arg (not (string->duration arg))) (leave (G_ "~s does not denote a duration~%") arg)) - (alist-cons 'delete-generations (or arg "") - result))))) + (alist-cons 'delete-generations arg result))))) (option '("optimize") #f #f (lambda (opt name arg result) (alist-cons 'action 'optimize @@ -287,9 +289,9 @@ is deprecated; use '-D'~%")) (assert-no-extra-arguments) (let ((min-freed (assoc-ref opts 'min-freed)) (free-space (assoc-ref opts 'free-space))) - (match (assoc-ref opts 'delete-generations) + (match (assq 'delete-generations opts) (#f #t) - ((? string? pattern) + ((_ . pattern) (delete-generations store pattern))) (cond (free-space diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 7b277b63f1..a43c96516f 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -98,7 +98,7 @@ denote ranges as interpreted by 'matching-generations'." (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (delete-generations store profile (delv current (profile-generations profile)))) ;; Do not delete the zeroth generation. @@ -120,9 +120,7 @@ denote ranges as interpreted by 'matching-generations'." (let ((numbers (delv current numbers))) (when (null-list? numbers) (leave (G_ "no matching generation~%"))) - (delete-generations store profile numbers)))) - (else - (leave (G_ "invalid syntax: ~a~%") pattern))))) + (delete-generations store profile numbers))))))) (define* (build-and-use-profile store profile manifest #:key @@ -457,12 +455,12 @@ command-line option~%") arg-handler))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result arg-handler) - (values (cons `(query list-generations ,(or arg "")) + (values (cons `(query list-generations ,arg) result) #f))) (option '(#\d "delete-generations") #f #t (lambda (opt name arg result arg-handler) - (values (alist-cons 'delete-generations (or arg "") + (values (alist-cons 'delete-generations arg result) #f))) (option '(#\S "switch-generation") #t #f @@ -683,7 +681,7 @@ processed, #f otherwise." (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (match (profile-generations profile) (() #t) @@ -697,10 +695,7 @@ processed, #f otherwise." (exit 1) (begin (list-generation display-profile-content (car numbers)) - (diff-profiles profile numbers))))) - (else - (leave (G_ "invalid syntax: ~a~%") - pattern)))) + (diff-profiles profile numbers))))))) #t) (('list-installed regexp) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 2d428546c9..7895c19914 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -117,7 +117,7 @@ Download and deploy the latest version of Guix.\n")) (alist-cons 'channel-file arg result))) (option '(#\l "list-generations") #f #t (lambda (opt name arg result) - (cons `(query list-generations ,(or arg "")) + (cons `(query list-generations ,arg) result))) (option '(#\N "news") #f #f (lambda (opt name arg result) @@ -486,7 +486,7 @@ list of package changes."))))) (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (list-generations profile (profile-generations profile))) ((matching-generations pattern profile) => diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 60c1ca5c9a..67a4071684 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -614,7 +614,7 @@ PATTERN, a string. When PATTERN is #f, display all the system generations." (cond ((not (file-exists? profile)) ; XXX: race condition (raise (condition (&profile-not-found-error (profile profile))))) - ((string-null? pattern) + ((not pattern) (for-each display-system-generation (profile-generations 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) (exit 1) (leave-on-EPIPE - (for-each display-system-generation numbers))))) - (else - (leave (G_ "invalid syntax: ~a~%") pattern)))) + (for-each display-system-generation numbers))))))) ;;; @@ -1232,7 +1230,7 @@ argument list and OPTS is the option alist." ;; an operating system configuration file. ((list-generations) (let ((pattern (match args - (() "") + (() #f) ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) (list-generations pattern))) @@ -1242,7 +1240,7 @@ argument list and OPTS is the option alist." ;; operating system configuration file. ((delete-generations) (let ((pattern (match args - (() "") + (() #f) ((pattern) pattern) (x (leave (G_ "wrong number of arguments~%")))))) (with-store store diff --git a/guix/ui.scm b/guix/ui.scm index 7d6ab9a2a7..76f6fc8eed 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -1484,7 +1484,11 @@ DURATION-RELATION with the current time." ((string->duration str) => filter-by-duration) - (else #f))) + (else + (raise + (condition (&message + (message (format #f (G_ "invalid syntax: ~a~%") + str)))))))) (define (display-generation profile number) "Display a one-line summary of generation NUMBER of PROFILE." |