[elpa] elpa-admin d5001e6: * elpa-admin.el: Keep the number of old tarballs under check

[Stefan Monnier]

branch: elpa-admin
commit d5001e6b724c6963281027dddb6b7216ca1f8c42
Author: Stefan Monnier <monnier@iro.umontreal.ca>
Commit: Stefan Monnier <monnier@iro.umontreal.ca>

    * elpa-admin.el: Keep the number of old tarballs under check
    
    (elpaa--keep-max): New var.
    (elpaa--keep-old, elpaa--prune-old-tarballs): New functions.
    (elpaa--make-one-tarball): Use them.
---
 elpa-admin.el | 88 +++++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 79 insertions(+), 9 deletions(-)

diff --git a/elpa-admin.el b/elpa-admin.el
index c7bcbd1..2fd9042 100644
--- a/elpa-admin.el
+++ b/elpa-admin.el
@@ -318,6 +318,83 @@ Do it without leaving the current branch."
                (elpaa--call t "git" "checkout" "--" "."))
              (elpaa--message "%s" (buffer-string)))))))))
 
+(defconst elpaa--keep-max 20)
+
+(defun elpaa--keep-old (vers oldtarballs n)
+  (cl-assert (and (integerp n) (> n 0)))
+  (cl-assert (not (assoc vers oldtarballs)))
+  (if (not (nthcdr n oldtarballs))
+      ;; We can keep them all.
+      oldtarballs
+    (let ((buckets ())
+          (buckets2 ())
+          (kept ()))
+      (dolist (oldtarball oldtarballs)
+        (let* ((tvers (car oldtarball))
+               (common-prefix (try-completion "" (list vers tvers)))
+               (len (length (if (stringp common-prefix) common-prefix vers))))
+          (push oldtarball (alist-get len buckets))
+          (push oldtarball
+                (alist-get (substring tvers 0 (min (length tvers) (1+ len)))
+                           buckets2 nil nil #'equal))))
+      (when (<= (length buckets2) n)
+        (setq buckets buckets2))
+      (while
+          (let ((bucket-size (/ n (length buckets)))
+                repeat)
+            (dolist (bucket buckets)
+              (when (<= (1- (length bucket)) bucket-size)
+                (setq kept (nconc (cdr bucket) kept))
+                (setq n (- n (1- (length bucket))))
+                (setq buckets (delq bucket buckets))
+                (setq repeat t)))
+            repeat))
+      (let ((bucket-size (/ n (length buckets))))
+        (dolist (bucket buckets)
+          (setq bucket (sort (cdr bucket)
+                             (lambda (t1 t2)
+                               (version<= (car t1) (car t2)))))
+          (let ((last (last bucket)))
+            (push (car last) kept)
+            (cond
+             ;; If there's only room for 2 elements, keep the first and
+             ;; the last.
+             ((and (cdr bucket) (= bucket-size 2))
+              (push (car bucket) kept))
+             ((> bucket-size 2)
+              (setq kept (nconc (elpaa--keep-old (caar last)
+                                                 (butlast bucket)
+                                                 (1- bucket-size))
+                                kept)))))))
+      kept)))
+
+(defun elpaa--prune-old-tarballs (vers tarball oldtarballs destdir)
+  ;; Make sure we don't count ourselves among the "old" tarballs.
+  (let ((self (rassoc (file-name-nondirectory tarball) oldtarballs)))
+    (when self
+      (setq oldtarballs (delq self oldtarballs))))
+  (when (nthcdr elpaa--keep-max oldtarballs)
+    (let* ((keep (elpaa--keep-old vers oldtarballs elpaa--keep-max))
+           (skeep (nreverse (sort keep
+                                  (lambda (t1 t2)
+                                    (version<= (car t1) (car t2)))))))
+      (message "Keeping: %s" (mapcar #'cdr skeep))
+      (dolist (oldtarball oldtarballs)
+        (unless (memq oldtarball keep)
+          (cl-assert (not (equal (cdr oldtarball)
+                                 (file-name-nondirectory tarball))))
+          (message "Deleting %s" (cdr oldtarball))))
+      (setq oldtarballs skeep)))
+  (dolist (oldtarball oldtarballs)
+    ;; Compress oldtarballs.
+    (let ((file (cdr oldtarball)))
+      (when (string-match "\\.\\(tar\\|el\\)\\'" file)
+        ;; Make sure we don't compress the file we just created.
+        (cl-assert (not (equal file (file-name-nondirectory tarball))))
+        ;; (elpaa--message "not equal %s and %s" file tarball)
+        (elpaa--call nil "lzip" (expand-file-name file destdir))
+        (setf (cdr oldtarball) (concat file ".lz"))))))
+
 (defun elpaa--make-one-tarball ( tarball dir pkg-spec metadata
                                  &optional revision-function one-tarball)
   "Create file TARBALL for PKGNAME if not done yet.
@@ -400,15 +477,8 @@ Return non-nil if a new tarball was created."
             (let ((link (expand-file-name (format "%s.tar" pkgname) destdir)))
               (when (file-symlink-p link) (delete-file link))
               (make-symbolic-link (file-name-nondirectory tarball) link))
-            (dolist (oldtarball oldtarballs)
-              ;; Compress oldtarballs.
-              (let ((file (cdr oldtarball)))
-                (when (string-match "\\.\\(tar\\|el\\)\\'" file)
-                  ;; Don't compress the file we just created.
-                  (unless (equal file (file-name-nondirectory tarball))
-                    ;; (elpaa--message "not equal %s and %s" file tarball)
-                    (elpaa--call nil "lzip" (expand-file-name file destdir))
-                    (setf (cdr oldtarball) (concat file ".lz"))))))
+            (setq oldtarballs
+                  (elpaa--prune-old-tarballs vers tarball oldtarballs destdir))
             (let* ((default-directory (expand-file-name destdir)))
               ;; Apparently this also creates the <pkg>-readme.txt file.
               (elpaa--html-make-pkg pkgdesc pkg-spec