1 files changed, 36 insertions, 27 deletions
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3cc7ae760f..6190f3286d 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -232,6 +232,41 @@ DURATION-RELATION with the current time."
          filter-by-duration)
         (else #f)))
 
+(define (delete-matching-generations store profile pattern)
+  "Delete from PROFILE all the generations matching PATTERN.  PATTERN must be
+a string denoting a set of generations: the empty list means \"all generations
+but the current one\", a number designates a generation, and other patterns
+denote ranges as interpreted by 'matching-derivations'."
+  (let ((current (generation-number profile)))
+    (cond ((not (file-exists? profile))            ; XXX: race condition
+           (raise (condition (&profile-not-found-error
+                              (profile profile)))))
+          ((string-null? pattern)
+           (delete-generations (%store) profile
+                               (delv current (profile-generations profile))))
+          ;; Do not delete the zeroth generation.
+          ((equal? 0 (string->number pattern))
+           #t)
+
+          ;; If PATTERN is a duration, match generations that are
+          ;; older than the specified duration.
+          ((matching-generations pattern profile
+                                 #:duration-relation >)
+           =>
+           (lambda (numbers)
+             (when (memv current numbers)
+               (warning (_ "not removing generation ~a, which is current~%")
+                        current))
+
+             ;; Make sure we don't inadvertently remove the current
+             ;; generation.
+             (let ((numbers (delv current numbers)))
+               (when (null-list? numbers)
+                 (leave (_ "no matching generation~%")))
+               (delete-generations (%store) profile numbers))))
+          (else
+           (leave (_ "invalid syntax: ~a~%") pattern)))))
+
 
 ;;;
 ;;; Package specifications.
@@ -751,9 +786,6 @@ more information.~%"))
     (define dry-run? (assoc-ref opts 'dry-run?))
     (define profile  (assoc-ref opts 'profile))
 
-    (define current-generation-number
-      (generation-number profile))
-
     ;; First roll back if asked to.
     (cond ((and (assoc-ref opts 'roll-back?)
                 (not dry-run?))
@@ -782,30 +814,7 @@ more information.~%"))
            (for-each
             (match-lambda
              (('delete-generations . pattern)
-              (cond ((not (file-exists? profile)) ; XXX: race condition
-                     (raise (condition (&profile-not-found-error
-                                        (profile profile)))))
-                    ((string-null? pattern)
-                     (delete-generations
-                      (%store) profile
-                      (delete current-generation-number
-                              (profile-generations profile))))
-                    ;; Do not delete the zeroth generation.
-                    ((equal? 0 (string->number pattern))
-                     (exit 0))
-
-                    ;; If PATTERN is a duration, match generations that are
-                    ;; older than the specified duration.
-                    ((matching-generations pattern profile
-                                           #:duration-relation >)
-                     =>
-                     (lambda (numbers)
-                       (if (null-list? numbers)
-                           (exit 1)
-                           (delete-generations (%store) profile numbers))))
-                    (else
-                     (leave (_ "invalid syntax: ~a~%")
-                            pattern)))
+              (delete-matching-generations (%store) profile pattern)
 
               (process-actions
                (alist-delete 'delete-generations opts)))