vc-arch.el 21.8 KB
Newer Older
Stefan Monnier's avatar
Stefan Monnier committed
1 2
;;; vc-arch.el --- VC backend for the Arch version-control system

Glenn Morris's avatar
Glenn Morris committed
3
;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
Stefan Monnier's avatar
Stefan Monnier committed
4 5 6 7 8 9 10 11

;; Author:      FSF (see vc.el for full credits)
;; Maintainer:  Stefan Monnier <monnier@gnu.org>

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
12
;; the Free Software Foundation; either version 3, or (at your option)
Stefan Monnier's avatar
Stefan Monnier committed
13 14 15 16 17 18 19 20 21
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
Lute Kamstra's avatar
Lute Kamstra committed
22 23
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Stefan Monnier's avatar
Stefan Monnier committed
24 25 26 27

;;; Commentary:

;; The home page of the Arch version control system is at
28
;;
Stefan Monnier's avatar
Stefan Monnier committed
29
;;      http://www.gnuarch.org/
30
;;
Stefan Monnier's avatar
Stefan Monnier committed
31 32 33 34 35 36
;; This is derived from vc-mcvs.el as follows:
;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET
;;
;; Then of course started the hacking.
;;
;; What has been partly tested:
37 38 39
;; - Open a file.
;; - C-x v =  without any prefix arg.
;; - C-x v v  to commit a change to a single file.
Stefan Monnier's avatar
Stefan Monnier committed
40 41 42

;; Bugs:

43
;; - *VC-log*'s initial content lacks the `Summary:' lines.
Stefan Monnier's avatar
Stefan Monnier committed
44 45 46
;; - All files under the tree are considered as "under Arch's control"
;;   without regards to =tagging-method and such.
;; - Files are always considered as `edited'.
47
;; - C-x v l does not work.
Stefan Monnier's avatar
Stefan Monnier committed
48
;; - C-x v i does not work.
49 50 51 52
;; - C-x v ~ does not work.
;; - C-x v u does not work.
;; - C-x v s does not work.
;; - C-x v r does not work.
53
;; - VC directory listings do not work.
Stefan Monnier's avatar
Stefan Monnier committed
54 55 56 57
;; - And more...

;;; Code:

Stefan Monnier's avatar
Stefan Monnier committed
58
(eval-when-compile (require 'vc) (require 'cl))
Stefan Monnier's avatar
Stefan Monnier committed
59 60 61 62 63 64

;;;
;;; Customization options
;;;

(defvar vc-arch-command
65
  (let ((candidates '("tla" "baz")))
Stefan Monnier's avatar
Stefan Monnier committed
66 67 68 69 70 71 72 73 74
    (while (and candidates (not (executable-find (car candidates))))
      (setq candidates (cdr candidates)))
    (or (car candidates) "tla")))

;; Clear up the cache to force vc-call to check again and discover
;; new functions when we reload this file.
(put 'Arch 'vc-functions nil)

;;;###autoload (defun vc-arch-registered (file)
75 76 77 78
;;;###autoload   (if (vc-find-root file "{arch}/=tagging-method")
;;;###autoload       (progn
;;;###autoload         (load "vc-arch")
;;;###autoload         (vc-arch-registered file))))
Stefan Monnier's avatar
Stefan Monnier committed
79

80
(defun vc-arch-add-tagline ()
Stefan Monnier's avatar
Stefan Monnier committed
81 82
  "Add an `arch-tag' to the end of the current file."
  (interactive)
83
  (comment-normalize-vars)
Stefan Monnier's avatar
Stefan Monnier committed
84 85
  (goto-char (point-max))
  (forward-comment -1)
86 87 88 89
  (skip-chars-forward " \t\n")
  (cond
   ((not (bolp)) (insert "\n\n"))
   ((not (eq ?\n (char-before (1- (point))))) (insert "\n")))
90 91 92 93 94 95 96
  (let ((beg (point))
	(idfile (and buffer-file-name
		     (expand-file-name
		      (concat ".arch-ids/"
			      (file-name-nondirectory buffer-file-name)
			      ".id")
		      (file-name-directory buffer-file-name)))))
Stefan Monnier's avatar
Stefan Monnier committed
97
    (insert "arch-tag: ")
98 99 100 101 102 103 104 105 106 107 108 109 110
    (if (and idfile (file-exists-p idfile))
	;; If the file is unreadable, we do want to get an error here.
	(progn
	  (insert-file-contents idfile)
	  (forward-line 1)
	  (delete-file idfile))
      (condition-case nil
	  (call-process "uuidgen" nil t)
	(file-error (insert (format "%s <%s> %s"
				    (current-time-string)
				    user-mail-address
				    (+ (nth 2 (current-time))
				       (buffer-size)))))))
Stefan Monnier's avatar
Stefan Monnier committed
111 112
    (comment-region beg (point))))

113 114
(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)")

115 116 117 118 119 120 121 122 123 124 125 126 127
(defmacro vc-with-current-file-buffer (file &rest body)
  (declare (indent 2) (debug t))
  `(let ((-kill-buf- nil)
         (-file- ,file))
     (with-current-buffer (or (find-buffer-visiting -file-)
                              (setq -kill-buf- (generate-new-buffer " temp")))
       ;; Avoid find-file-literally since it can do many undesirable extra
       ;; things (among which, call us back into an infinite loop).
       (if -kill-buf- (insert-file-contents -file-))
       (unwind-protect
           (progn ,@body)
         (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-))))))

128 129 130 131 132 133 134 135 136 137 138 139 140
(defun vc-arch-file-source-p (file)
  "Can return nil, `maybe' or a non-nil value.
Only the value `maybe' can be trusted :-(."
  ;; FIXME: Check the tag and name of parent dirs.
  (unless (string-match "\\`[,+]" (file-name-nondirectory file))
    (or (string-match "\\`{arch}/"
		      (file-relative-name file (vc-arch-root file)))
	(file-exists-p
	 ;; Check the presence of an ID file.
	 (expand-file-name
	  (concat ".arch-ids/" (file-name-nondirectory file) ".id")
	  (file-name-directory file)))
	;; Check the presence of a tagline.
141
	(vc-with-current-file-buffer file
142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170
	  (save-excursion
	    (goto-char (point-max))
	    (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
		(progn
		  (goto-char (point-min))
		  (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))))
	;; FIXME: check =tagging-method to see whether untagged files might
	;; be source or not.
	(with-current-buffer
	    (find-file-noselect (expand-file-name "{arch}/=tagging-method"
						  (vc-arch-root file)))
	  (let ((untagged-source t))	;Default is `names'.
	    (save-excursion
	      (goto-char (point-min))
	      (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t)
		  (setq untagged-source (match-end 2)))
	      (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t)
		  (setq untagged-source (match-end 2))))
	    (if untagged-source 'maybe))))))

(defun vc-arch-file-id (file)
  ;; Don't include the kind of ID this is because it seems to be too messy.
  (let ((idfile (expand-file-name
		 (concat ".arch-ids/" (file-name-nondirectory file) ".id")
		 (file-name-directory file))))
    (if (file-exists-p idfile)
	(with-temp-buffer
	  (insert-file-contents idfile)
	  (looking-at ".*[^ \n\t]")
171
	  (match-string 0))
172 173 174 175 176 177 178 179
      (with-current-buffer (find-file-noselect file)
	(save-excursion
	  (goto-char (point-max))
	  (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t)
		  (progn
		    (goto-char (point-min))
		    (re-search-forward vc-arch-tagline-re (+ (point) 1000) t)))
	      (match-string 1)
180
	    (concat "./" (file-relative-name file (vc-arch-root file)))))))))
181 182 183 184 185 186 187 188 189 190 191 192

(defun vc-arch-tagging-method (file)
  (with-current-buffer
      (find-file-noselect
       (expand-file-name "{arch}/=tagging-method" (vc-arch-root file)))
    (save-excursion
      (goto-char (point-min))
      (if (re-search-forward
	   "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t)
	  (intern (match-string 1))
	'names))))

Stefan Monnier's avatar
Stefan Monnier committed
193 194 195
(defun vc-arch-root (file)
  "Return the root directory of a Arch project, if any."
  (or (vc-file-getprop file 'arch-root)
196 197 198 199 200 201
      ;; Check the =tagging-method, in case someone naively manually
      ;; creates a {arch} directory somewhere.
      (let ((root (vc-find-root file "{arch}/=tagging-method")))
	(when root
	  (vc-file-setprop
	   file 'arch-root root)))))
Stefan Monnier's avatar
Stefan Monnier committed
202

203
(defun vc-arch-register (files &optional rev comment)
204
  (if rev (error "Explicit initial revision not supported for Arch"))
205 206 207 208 209 210 211 212 213
  (dolist (file files)
    (let ((tagmet (vc-arch-tagging-method file)))
      (if (and (memq tagmet '(tagline implicit)) comment-start)
	  (with-current-buffer (find-file-noselect file)
	    (if (buffer-modified-p)
		(error "Save %s first" (buffer-name)))
	    (vc-arch-add-tagline)
	    (save-buffer)))))
  (vc-arch-command nil 0 files "add"))
214

Stefan Monnier's avatar
Stefan Monnier committed
215
(defun vc-arch-registered (file)
216 217 218 219 220
  ;; Don't seriously check whether it's source or not.  Checking would
  ;; require running TLA, so it's better to not do it, so it also works if
  ;; TLA is not installed.
  (and (vc-arch-root file)
       (vc-arch-file-source-p file)))
Stefan Monnier's avatar
Stefan Monnier committed
221 222 223 224 225 226 227 228 229 230 231 232 233

(defun vc-arch-default-version (file)
  (or (vc-file-getprop (vc-arch-root file) 'arch-default-version)
      (let* ((root (vc-arch-root file))
	     (f (expand-file-name "{arch}/++default-version" root)))
	(if (file-readable-p f)
	    (vc-file-setprop
	     root 'arch-default-version
	     (with-temp-buffer
	       (insert-file-contents f)
	       ;; Strip the terminating newline.
	       (buffer-substring (point-min) (1- (point-max)))))))))

234 235 236 237 238
(defun vc-arch-workfile-unchanged-p (file)
  "Check if FILE is unchanged by diffing against the master version.
Return non-nil if FILE is unchanged."
  nil)

Stefan Monnier's avatar
Stefan Monnier committed
239 240 241 242
(defun vc-arch-state (file)
  ;; There's no checkout operation and merging is not done from VC
  ;; so the only operation that's state dependent that VC supports is commit
  ;; which is only activated if the file is `edited'.
243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258
  (let* ((root (vc-arch-root file))
	 (ver (vc-arch-default-version file))
	 (pat (concat "\\`" (subst-char-in-string ?/ ?% ver)))
	 (dir (expand-file-name ",,inode-sigs/"
				(expand-file-name "{arch}" root)))
	 (sigfile nil))
    (dolist (f (if (file-directory-p dir) (directory-files dir t pat)))
      (if (or (not sigfile) (file-newer-than-file-p f sigfile))
	  (setq sigfile f)))
    (if (not sigfile)
	'edited				;We know nothing.
      (let ((id (vc-arch-file-id file)))
	(setq id (replace-regexp-in-string "[ \t]" "_" id))
	(with-current-buffer (find-file-noselect sigfile)
	  (goto-char (point-min))
	  (while (and (search-forward id nil 'move)
259 260 261 262 263 264 265
		      (save-excursion
			(goto-char (- (match-beginning 0) 2))
			;; For `names', the lines start with `?./foo/bar'.
			;; For others there's 2 chars before the ./foo/bar.
			(or (not (or (bolp) (looking-at "\n?")))
			    ;; Ignore E_ entries used for foo.id files.
			    (looking-at "E_")))))
266 267 268 269
	  (if (eobp)
	      ;; ID not found.
	      (if (equal (file-name-nondirectory sigfile)
			 (subst-char-in-string
Eric S. Raymond's avatar
Eric S. Raymond committed
270
			  ?/ ?% (vc-arch-working-revision file)))
271 272 273 274 275 276 277 278 279 280 281
		  'added
		;; Might be `added' or `up-to-date' as well.
		;; FIXME: Check in the patch logs to find out.
		'edited)
	    ;; Found the ID, let's check the inode.
	    (if (not (re-search-forward
		      "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)"
		      (line-end-position) t))
		;; Buh?  Unexpected format.
		'edited
	      (let ((ats (file-attributes file)))
282
		(if (and (eq (nth 7 ats) (string-to-number (match-string 2)))
283 284 285 286
			 (equal (format-time-string "%s" (nth 5 ats))
				(match-string 1)))
		    'up-to-date
		  'edited)))))))))
287

Eric S. Raymond's avatar
Eric S. Raymond committed
288
(defun vc-arch-working-revision (file)
Stefan Monnier's avatar
Stefan Monnier committed
289 290
  (let* ((root (expand-file-name "{arch}" (vc-arch-root file)))
	 (defbranch (vc-arch-default-version file)))
291
    (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch))
Stefan Monnier's avatar
Stefan Monnier committed
292 293 294 295
      (let* ((archive (match-string 1 defbranch))
	     (category (match-string 4 defbranch))
	     (branch (match-string 3 defbranch))
	     (version (match-string 2 defbranch))
296
	     (sealed nil) (rev-nb 0)
Stefan Monnier's avatar
Stefan Monnier committed
297 298 299 300 301 302 303
	     (rev nil)
	     logdir tmp)
	(setq logdir (expand-file-name category root))
	(setq logdir (expand-file-name branch logdir))
	(setq logdir (expand-file-name version logdir))
	(setq logdir (expand-file-name archive logdir))
	(setq logdir (expand-file-name "patch-log" logdir))
304 305
	(dolist (file (if (file-directory-p logdir) (directory-files logdir)))
	  ;; Revision names go: base-0, patch-N, version-0, versionfix-M.
306 307
	  (when (and (eq (aref file 0) ?v) (not sealed))
	    (setq sealed t rev-nb 0))
Stefan Monnier's avatar
Stefan Monnier committed
308 309
	  (if (and (string-match "-\\([0-9]+\\)\\'" file)
		   (setq tmp (string-to-number (match-string 1 file)))
310
		   (or (not sealed) (eq (aref file 0) ?v))
Stefan Monnier's avatar
Stefan Monnier committed
311 312
		   (>= tmp rev-nb))
	      (setq rev-nb tmp rev file)))
313 314 315
	;; Use "none-000" if the tree hasn't yet been committed on the
	;; default branch.  We'll then get "Arch:000[branch]" on the mode-line.
	(concat defbranch "--" (or rev "none-000"))))))
Stefan Monnier's avatar
Stefan Monnier committed
316 317 318


(defcustom vc-arch-mode-line-rewrite
319
  '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]"))
Stefan Monnier's avatar
Stefan Monnier committed
320
  "Rewrite rules to shorten Arch's revision names on the mode-line."
321 322
  :type '(repeat (cons regexp string))
  :group 'vc)
Stefan Monnier's avatar
Stefan Monnier committed
323 324 325

(defun vc-arch-mode-line-string (file)
  "Return string for placement in modeline by `vc-mode-line' for FILE."
Eric S. Raymond's avatar
Eric S. Raymond committed
326
  (let ((rev (vc-working-revision file)))
Stefan Monnier's avatar
Stefan Monnier committed
327 328 329 330
    (dolist (rule vc-arch-mode-line-rewrite)
      (if (string-match (car rule) rev)
	  (setq rev (replace-match (cdr rule) t nil rev))))
    (format "Arch%c%s"
331
	    (case (vc-state file)
332
	      ((up-to-date needs-update) ?-)
333 334
	      (added ?@)
	      (t ?:))
Stefan Monnier's avatar
Stefan Monnier committed
335 336 337
	    rev)))

(defun vc-arch-diff3-rej-p (rej)
338 339 340 341 342 343
  (let ((attrs (file-attributes rej)))
    (and attrs (< (nth 7 attrs) 60)
	 (with-temp-buffer
	   (insert-file-contents rej)
	   (goto-char (point-min))
	   (looking-at "Conflicts occured, diff3 conflict markers left in file\\.")))))
Stefan Monnier's avatar
Stefan Monnier committed
344 345

(defun vc-arch-delete-rej-if-obsolete ()
346 347 348 349
  "For use in `after-save-hook'."
  (save-excursion
    (let ((rej (concat buffer-file-name ".rej")))
      (when (and buffer-file-name (vc-arch-diff3-rej-p rej))
350 351 352 353 354
	(unless (re-search-forward "^<<<<<<< " nil t)
	  ;; The .rej file is obsolete.
	  (condition-case nil (delete-file rej) (error nil))
	  ;; Remove the hook so that it is not called multiple times.
	  (remove-hook 'after-save-hook 'vc-arch-delete-rej-if-obsolete t))))))
Stefan Monnier's avatar
Stefan Monnier committed
355 356 357 358 359 360 361

(defun vc-arch-find-file-hook ()
  (let ((rej (concat buffer-file-name ".rej")))
    (when (and buffer-file-name (file-exists-p rej))
      (if (vc-arch-diff3-rej-p rej)
	  (save-excursion
	    (goto-char (point-min))
362
	    (if (not (re-search-forward "^<<<<<<< " nil t))
Stefan Monnier's avatar
Stefan Monnier committed
363 364
		;; The .rej file is obsolete.
		(condition-case nil (delete-file rej) (error nil))
365
	      (smerge-mode 1)
366
	      (add-hook 'after-save-hook
Stefan Monnier's avatar
Stefan Monnier committed
367 368 369 370 371 372 373
			'vc-arch-delete-rej-if-obsolete nil t)
	      (message "There are unresolved conflicts in this file")))
	(message "There are unresolved conflicts in %s"
		 (file-name-nondirectory rej))))))

(defun vc-arch-checkout-model (file) 'implicit)

374
(defun vc-arch-checkin (files rev comment)
375
  (if rev (error "Committing to a specific revision is unsupported"))
376
  ;; FIXME: This implementation probably only works for singleton filesets
Stefan Monnier's avatar
Stefan Monnier committed
377
  (let ((summary (file-relative-name (car files) (vc-arch-root (car files)))))
378 379 380 381 382
    ;; Extract a summary from the comment.
    (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment)
	      (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment))
      (setq summary (match-string 1 comment))
      (setq comment (substring comment (match-end 0))))
383
    (vc-arch-command nil 0 files "commit" "-s" summary "-L" comment "--"
384
		     (vc-switches 'Arch 'checkin))))
Stefan Monnier's avatar
Stefan Monnier committed
385

386 387
(defun vc-arch-diff (files &optional oldvers newvers buffer)
  "Get a difference report using Arch between two versions of FILES."
388 389 390 391 392 393 394 395
  ;; FIXME: This implementation only works for singleton filesets.  To make
  ;; it work for more cases, we have to either call `file-diffs' manually on
  ;; each and every `file' in the fileset, or use `changes --diffs' (and
  ;; variants) and maybe filter the output with `filterdiff' to only include
  ;; the files in which we're interested.
  (let ((file (car files)))
    (if (and newvers
             (vc-up-to-date-p file)
Eric S. Raymond's avatar
Eric S. Raymond committed
396
             (equal newvers (vc-working-revision file)))
397 398 399 400 401
        ;; Newvers is the base revision and the current file is unchanged,
        ;; so we can diff with the current file.
        (setq newvers nil))
    (if newvers
        (error "Diffing specific revisions not implemented")
402
      (let* ((async (not vc-disable-async-diff))
403 404 405 406 407 408 409 410 411 412
             ;; Run the command from the root dir.
             (default-directory (vc-arch-root file))
             (status
              (vc-arch-command
               (or buffer "*vc-diff*")
               (if async 'async 1)
               nil "file-diffs"
               ;; Arch does not support the typical flags.
               ;; (vc-switches 'Arch 'diff)
               (file-relative-name file)
Eric S. Raymond's avatar
Eric S. Raymond committed
413
               (if (equal oldvers (vc-working-revision file))
414 415 416
                   nil
                 oldvers))))
        (if async 1 status)))))	       ; async diff, pessimistic assumption.
Stefan Monnier's avatar
Stefan Monnier committed
417 418 419 420 421 422 423

(defun vc-arch-delete-file (file)
  (vc-arch-command nil 0 file "rm"))

(defun vc-arch-rename-file (old new)
  (vc-arch-command nil 0 new "mv" (file-relative-name old)))

424 425
(defalias 'vc-arch-responsible-p 'vc-arch-root)

Stefan Monnier's avatar
Stefan Monnier committed
426 427 428 429
(defun vc-arch-command (buffer okstatus file &rest flags)
  "A wrapper around `vc-do-command' for use in vc-arch.el."
  (apply 'vc-do-command buffer okstatus vc-arch-command file flags))

Eric S. Raymond's avatar
Eric S. Raymond committed
430
(defun vc-arch-init-revision () nil)
431

432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
;;; Completion of versions and revisions.

(defun vc-arch--version-completion-table (root string)
  (delq nil
	(mapcar
	 (lambda (d)
	   (when (string-match "/\\([^/]+\\)/\\([^/]+\\)\\'" d)
	     (concat (match-string 2 d) "/" (match-string 1 d))))
	 (let ((default-directory root))
	   (file-expand-wildcards
	    (concat "*/*/"
		    (if (string-match "/" string)
			(concat (substring string (match-end 0))
				"*/" (substring string 0 (match-beginning 0)))
		      (concat "*/" string))
		    "*"))))))

449 450
(defun vc-arch-revision-completion-table (files)
  (lexical-let ((files files))
451 452
    (lambda (string pred action)
      ;; FIXME: complete revision patches as well.
453
      (let* ((root (expand-file-name "{arch}" (vc-arch-root (car files))))
Stefan Monnier's avatar
Stefan Monnier committed
454 455
             (table (vc-arch--version-completion-table root string)))
	(complete-with-action action table string pred)))))
456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553

;;; Trimming revision libraries.

;; This code is not directly related to VC and there are many variants of
;; this functionality available as scripts, but I like this version better,
;; so maybe others will like it too.

(defun vc-arch-trim-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)))
       (rename-file ,(car revs) ,(concat (car revs) "*rm*"))
       (setq proc (start-process "vc-arch-trim" nil
                                 "rm" "-rf" ',(concat (car revs) "*rm*")))
       (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-trim-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))
    ))
554 555 556 557 558 559 560 561 562 563

(defvar vc-arch-extra-menu-map
  (let ((map (make-sparse-keymap)))
    (define-key map [add-tagline]
      '(menu-item "Add tagline" vc-arch-add-tagline))
    map))

(defun vc-arch-extra-menu () vc-arch-extra-menu-map)
  

564 565
;;; Less obvious implementations.

Eric S. Raymond's avatar
Eric S. Raymond committed
566
(defun vc-arch-find-revision (file rev buffer)
567 568 569 570 571 572 573 574 575 576 577
  (let ((out (make-temp-file "vc-out")))
    (unwind-protect
        (progn
          (with-temp-buffer
            (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev)
            (call-process-region (point-min) (point-max)
                                 "patch" nil nil nil "-R" "-o" out file))
          (with-current-buffer buffer
            (insert-file-contents out)))
      (delete-file out))))

Stefan Monnier's avatar
Stefan Monnier committed
578 579
(provide 'vc-arch)

580
;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704
Stefan Monnier's avatar
Stefan Monnier committed
581
;;; vc-arch.el ends here