From 65d428d8f4bd6bf05dde428ce51a3ce04bd3aad3 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 6 Apr 2015 20:02:22 +0200
Subject: guix package: Move generation deletion to its own procedure.

* guix/scripts/package.scm (delete-matching-generations): New procedure,
  with code formerly found...
  (guix-package)[process-actions]: ... here.  Use it.
  Remove 'current-generation-number'.
---
 guix/scripts/package.scm | 56 +++++++++++++++++++++++++-----------------------
 1 file changed, 29 insertions(+), 27 deletions(-)

(limited to 'guix')

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 3cc7ae760f..7074243ed9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -232,6 +232,34 @@ 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))
+           (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)))))
+
 
 ;;;
 ;;; Package specifications.
@@ -751,9 +779,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 +807,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)))
-- 
cgit v1.2.3