Re: [Gnu-arch-users] Re: patch: automatic cacherev and smarter get

[Stefan Monnier]

> Yes, this is a good idea.  I never used these wrappers and I do not know
> if many people have used these wrappers.  Would any satisfactory users of
> such wrappers come forward to share your experience with the revsion
> library management of, say, FAI?  Good strategies would be a great
> addition into the tla proper...

The ones I tried at first all used recency to decide what to delete.
I found it to not do what I wanted (I still sometimes needed some of the
revs it had thrown out, so it caused massive re-building (especially due to
the lack of back-builder), so I tried a different approach, shown in the
elisp code below.  Basically the idea is to not use age but instead to
remove revisions that are near another revision (based on the idea that
rebuilding it would be cheap anyway).  So it ends up with a set of remaining
revisions that are more-or-less equally spaced.

I like this behavior, although I think it should be mixed in with the
age-based trimming to get the best of both worlds.


        Stefan


(defun vc-arch-find-least-useful-rev (revs)
  (let* ((first (pop revs))
         (second (pop revs))
         (third (pop revs))
         ;; We try to give more importance to recent revisions.  The idea is
         ;; that it's OK if checking out a revision 1000-patch-old is ten
         ;; times slower than checking out a revision 100-patch-old.  But at
         ;; the same time a 2-patch-old rev isn't really ten times more
         ;; important than a 20-patch-old, so we use an arbitrary constant
         ;; "100" to reduce this effect for recent revisions.  Making this
         ;; constant a float has the side effect of causing the subsequent
         ;; computations to be done as floats as well.
         (max (+ 100.0 (car (or (car (last revs)) third))))
         (cost (lambda () (/ (- (car third) (car first)) (- max (car second)))))
         (minrev second)
         (mincost (funcall cost)))
    (while revs
      (setq first second)
      (setq second third)
      (setq third (pop revs))
      (when (< (funcall cost) mincost)
        (setq minrev second)
        (setq mincost (funcall cost))))
    minrev))

(defun vc-arch-trim-make-sentinel (revs)
  (if (null revs) (lambda (proc msg) (message "VC-Arch trimming ... done"))
    `(lambda (proc msg)
       (message "VC-Arch trimming %s..." ',(file-name-nondirectory (car revs)))
       (setq proc (start-process "vc-arch-trim" nil "rm" "-rf" ',(car revs)))
       (set-process-sentinel proc (vc-arch-trim-make-sentinel ',(cdr revs))))))

(defun vc-arch-trim-one-revlib (dir)
  "Delete half of the revisions in the revision library."
  (interactive "Ddirectory: ")
  (let ((revs
         (sort (delq nil
                     (mapcar
                      (lambda (f)
                        (when (string-match "-\\([0-9]+\\)\\'" f)
                          (cons (string-to-number (match-string 1 f)) f)))
                      (directory-files dir nil nil 'nosort)))
               'car-less-than-car))
        (subdirs nil))
    (when (cddr revs)
      (dotimes (i (/ (length revs) 2))
        (let ((minrev (vc-arch-find-least-useful-rev revs)))
          (setq revs (delq minrev revs))
          (push minrev subdirs)))
      (funcall (vc-arch-trim-make-sentinel
                (mapcar (lambda (x) (expand-file-name (cdr x) dir)) subdirs))
               nil nil))))

(defun vc-arch-trim-revlib ()
  "Delete half of the revisions in the revision library."
  (interactive)
  (let ((rl-dir (with-output-to-string
                  (call-process vc-arch-command nil standard-output nil
                                "my-revision-library"))))
    (while (string-match "\\(.*\\)\n" rl-dir)
      (let ((dir (match-string 1 rl-dir)))
        (setq rl-dir
              (if (and (file-directory-p dir) (file-writable-p dir))
                  dir
                (substring rl-dir (match-end 0))))))
    (unless (file-writable-p rl-dir)
      (error "No writable revlib directory found"))
    (message "Revlib at %s" rl-dir)
    (let* ((archives (directory-files rl-dir 'full "[^.]\\|..."))
           (categories
            (apply 'append
                   (mapcar (lambda (dir)
                             (when (file-directory-p dir)
                               (directory-files dir 'full "[^.]\\|...")))
                           archives)))
           (branches
            (apply 'append
                   (mapcar (lambda (dir)
                             (when (file-directory-p dir)
                               (directory-files dir 'full "[^.]\\|...")))
                           categories)))
           (versions
            (apply 'append
                   (mapcar (lambda (dir)
                             (when (file-directory-p dir)
                               (directory-files dir 'full "--.*--")))
                           branches))))
      (mapc 'vc-arch-trim-one-revlib versions))
    ))