aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2019-07-10 19:58:30 +0200
committerLudovic Courtès <ludo@gnu.org>2019-07-11 23:13:26 +0200
commit5c3d44303e1bb75d45334af5cf86cde723da0371 (patch)
treec9827bb70c4d12c792bf24042a38ffdd36f879af
parent878a6baa4c705f4d551b60c5aa254246e0abc922 (diff)
downloadpatches-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.scm18
-rw-r--r--guix/scripts/package.scm17
-rw-r--r--guix/scripts/pull.scm4
-rw-r--r--guix/scripts/system.scm10
-rw-r--r--guix/ui.scm6
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."