1;;; vc-arch.el --- VC backend for the Arch version-control system 2 3;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 4 5;; Author: FSF (see vc.el for full credits) 6;; Maintainer: Stefan Monnier <monnier@gnu.org> 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; Boston, MA 02110-1301, USA. 24 25;;; Commentary: 26 27;; The home page of the Arch version control system is at 28;; 29;; http://www.gnuarch.org/ 30;; 31;; This is derived from vc-mcvs.el as follows: 32;; - cp vc-mcvs.el vc-arch.el and then M-% mcvs RET arch RET 33;; 34;; Then of course started the hacking. 35;; 36;; What has been partly tested: 37;; - Open a file. 38;; - C-x v = without any prefix arg. 39;; - C-x v v to commit a change to a single file. 40 41;; Bugs: 42 43;; - *VC-log*'s initial content lacks the `Summary:' lines. 44;; - All files under the tree are considered as "under Arch's control" 45;; without regards to =tagging-method and such. 46;; - Files are always considered as `edited'. 47;; - C-x v l does not work. 48;; - C-x v i does not work. 49;; - C-x v ~ does not work. 50;; - C-x v u does not work. 51;; - C-x v s does not work. 52;; - C-x v r does not work. 53;; - VC-dired does not work. 54;; - And more... 55 56;;; Code: 57 58(eval-when-compile (require 'vc) (require 'cl)) 59 60;;; 61;;; Customization options 62;;; 63 64(defvar vc-arch-command 65 (let ((candidates '("tla"))) 66 (while (and candidates (not (executable-find (car candidates)))) 67 (setq candidates (cdr candidates))) 68 (or (car candidates) "tla"))) 69 70;; Clear up the cache to force vc-call to check again and discover 71;; new functions when we reload this file. 72(put 'Arch 'vc-functions nil) 73 74;;;###autoload (defun vc-arch-registered (file) 75;;;###autoload (if (vc-find-root file "{arch}/=tagging-method") 76;;;###autoload (progn 77;;;###autoload (load "vc-arch") 78;;;###autoload (vc-arch-registered file)))) 79 80(defun vc-arch-add-tagline () 81 "Add an `arch-tag' to the end of the current file." 82 (interactive) 83 (comment-normalize-vars) 84 (goto-char (point-max)) 85 (forward-comment -1) 86 (unless (bolp) (insert "\n")) 87 (let ((beg (point)) 88 (idfile (and buffer-file-name 89 (expand-file-name 90 (concat ".arch-ids/" 91 (file-name-nondirectory buffer-file-name) 92 ".id") 93 (file-name-directory buffer-file-name))))) 94 (insert "arch-tag: ") 95 (if (and idfile (file-exists-p idfile)) 96 ;; If the file is unreadable, we do want to get an error here. 97 (progn 98 (insert-file-contents idfile) 99 (forward-line 1) 100 (delete-file idfile)) 101 (condition-case nil 102 (call-process "uuidgen" nil t) 103 (file-error (insert (format "%s <%s> %s" 104 (current-time-string) 105 user-mail-address 106 (+ (nth 2 (current-time)) 107 (buffer-size))))))) 108 (comment-region beg (point)))) 109 110(defconst vc-arch-tagline-re "^\\W*arch-tag:[ \t]*\\(.*[^ \t\n]\\)") 111 112(defmacro vc-with-current-file-buffer (file &rest body) 113 (declare (indent 2) (debug t)) 114 `(let ((-kill-buf- nil) 115 (-file- ,file)) 116 (with-current-buffer (or (find-buffer-visiting -file-) 117 (setq -kill-buf- (generate-new-buffer " temp"))) 118 ;; Avoid find-file-literally since it can do many undesirable extra 119 ;; things (among which, call us back into an infinite loop). 120 (if -kill-buf- (insert-file-contents -file-)) 121 (unwind-protect 122 (progn ,@body) 123 (if (buffer-live-p -kill-buf-) (kill-buffer -kill-buf-)))))) 124 125(defun vc-arch-file-source-p (file) 126 "Can return nil, `maybe' or a non-nil value. 127Only the value `maybe' can be trusted :-(." 128 ;; FIXME: Check the tag and name of parent dirs. 129 (unless (string-match "\\`[,+]" (file-name-nondirectory file)) 130 (or (string-match "\\`{arch}/" 131 (file-relative-name file (vc-arch-root file))) 132 (file-exists-p 133 ;; Check the presence of an ID file. 134 (expand-file-name 135 (concat ".arch-ids/" (file-name-nondirectory file) ".id") 136 (file-name-directory file))) 137 ;; Check the presence of a tagline. 138 (vc-with-current-file-buffer file 139 (save-excursion 140 (goto-char (point-max)) 141 (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t) 142 (progn 143 (goto-char (point-min)) 144 (re-search-forward vc-arch-tagline-re (+ (point) 1000) t))))) 145 ;; FIXME: check =tagging-method to see whether untagged files might 146 ;; be source or not. 147 (with-current-buffer 148 (find-file-noselect (expand-file-name "{arch}/=tagging-method" 149 (vc-arch-root file))) 150 (let ((untagged-source t)) ;Default is `names'. 151 (save-excursion 152 (goto-char (point-min)) 153 (if (re-search-forward "^[ \t]*\\(\\(tagline\\|implicit\\|names\\)\\|explicit\\)" nil t) 154 (setq untagged-source (match-end 2))) 155 (if (re-search-forward "^[ \t]*untagged-source[ \t]+\\(\\(source\\)\\|precious\\|backup\\|junk\\|unrecognized\\)" nil t) 156 (setq untagged-source (match-end 2)))) 157 (if untagged-source 'maybe)))))) 158 159(defun vc-arch-file-id (file) 160 ;; Don't include the kind of ID this is because it seems to be too messy. 161 (let ((idfile (expand-file-name 162 (concat ".arch-ids/" (file-name-nondirectory file) ".id") 163 (file-name-directory file)))) 164 (if (file-exists-p idfile) 165 (with-temp-buffer 166 (insert-file-contents idfile) 167 (looking-at ".*[^ \n\t]") 168 (match-string 0)) 169 (with-current-buffer (find-file-noselect file) 170 (save-excursion 171 (goto-char (point-max)) 172 (if (or (re-search-backward vc-arch-tagline-re (- (point) 1000) t) 173 (progn 174 (goto-char (point-min)) 175 (re-search-forward vc-arch-tagline-re (+ (point) 1000) t))) 176 (match-string 1) 177 (concat "./" (file-relative-name file (vc-arch-root file))))))))) 178 179(defun vc-arch-tagging-method (file) 180 (with-current-buffer 181 (find-file-noselect 182 (expand-file-name "{arch}/=tagging-method" (vc-arch-root file))) 183 (save-excursion 184 (goto-char (point-min)) 185 (if (re-search-forward 186 "^[ \t]*\\(tagline\\|implicit\\|names\\|explicit\\)" nil t) 187 (intern (match-string 1)) 188 'names)))) 189 190(defun vc-arch-root (file) 191 "Return the root directory of a Arch project, if any." 192 (or (vc-file-getprop file 'arch-root) 193 (vc-file-setprop 194 ;; Check the =tagging-method, in case someone naively manually 195 ;; creates a {arch} directory somewhere. 196 file 'arch-root (vc-find-root file "{arch}/=tagging-method")))) 197 198(defun vc-arch-register (file &optional rev comment) 199 (if rev (error "Explicit initial revision not supported for Arch")) 200 (let ((tagmet (vc-arch-tagging-method file))) 201 (if (and (memq tagmet '(tagline implicit)) comment-start) 202 (with-current-buffer (find-file-noselect file) 203 (if (buffer-modified-p) 204 (error "Save %s first" (buffer-name))) 205 (vc-arch-add-tagline) 206 (save-buffer)) 207 (vc-arch-command nil 0 file "add")))) 208 209(defun vc-arch-registered (file) 210 ;; Don't seriously check whether it's source or not. Checking would 211 ;; require running TLA, so it's better to not do it, so it also works if 212 ;; TLA is not installed. 213 (and (vc-arch-root file) 214 (vc-arch-file-source-p file))) 215 216(defun vc-arch-default-version (file) 217 (or (vc-file-getprop (vc-arch-root file) 'arch-default-version) 218 (let* ((root (vc-arch-root file)) 219 (f (expand-file-name "{arch}/++default-version" root))) 220 (if (file-readable-p f) 221 (vc-file-setprop 222 root 'arch-default-version 223 (with-temp-buffer 224 (insert-file-contents f) 225 ;; Strip the terminating newline. 226 (buffer-substring (point-min) (1- (point-max))))))))) 227 228(defun vc-arch-workfile-unchanged-p (file) 229 "Check if FILE is unchanged by diffing against the master version. 230Return non-nil if FILE is unchanged." 231 nil) 232 233(defun vc-arch-state (file) 234 ;; There's no checkout operation and merging is not done from VC 235 ;; so the only operation that's state dependent that VC supports is commit 236 ;; which is only activated if the file is `edited'. 237 (let* ((root (vc-arch-root file)) 238 (ver (vc-arch-default-version file)) 239 (pat (concat "\\`" (subst-char-in-string ?/ ?% ver))) 240 (dir (expand-file-name ",,inode-sigs/" 241 (expand-file-name "{arch}" root))) 242 (sigfile nil)) 243 (dolist (f (if (file-directory-p dir) (directory-files dir t pat))) 244 (if (or (not sigfile) (file-newer-than-file-p f sigfile)) 245 (setq sigfile f))) 246 (if (not sigfile) 247 'edited ;We know nothing. 248 (let ((id (vc-arch-file-id file))) 249 (setq id (replace-regexp-in-string "[ \t]" "_" id)) 250 (with-current-buffer (find-file-noselect sigfile) 251 (goto-char (point-min)) 252 (while (and (search-forward id nil 'move) 253 (save-excursion 254 (goto-char (- (match-beginning 0) 2)) 255 ;; For `names', the lines start with `?./foo/bar'. 256 ;; For others there's 2 chars before the ./foo/bar. 257 (or (not (or (bolp) (looking-at "\n?"))) 258 ;; Ignore E_ entries used for foo.id files. 259 (looking-at "E_"))))) 260 (if (eobp) 261 ;; ID not found. 262 (if (equal (file-name-nondirectory sigfile) 263 (subst-char-in-string 264 ?/ ?% (vc-arch-workfile-version file))) 265 'added 266 ;; Might be `added' or `up-to-date' as well. 267 ;; FIXME: Check in the patch logs to find out. 268 'edited) 269 ;; Found the ID, let's check the inode. 270 (if (not (re-search-forward 271 "\t.*mtime=\\([0-9]+\\):size=\\([0-9]+\\)" 272 (line-end-position) t)) 273 ;; Buh? Unexpected format. 274 'edited 275 (let ((ats (file-attributes file))) 276 (if (and (eq (nth 7 ats) (string-to-number (match-string 2))) 277 (equal (format-time-string "%s" (nth 5 ats)) 278 (match-string 1))) 279 'up-to-date 280 'edited))))))))) 281 282(defun vc-arch-workfile-version (file) 283 (let* ((root (expand-file-name "{arch}" (vc-arch-root file))) 284 (defbranch (vc-arch-default-version file))) 285 (when (and defbranch (string-match "\\`\\(.+@[^/\n]+\\)/\\(\\(\\(.*?\\)\\(?:--.*\\)?\\)--.*\\)\\'" defbranch)) 286 (let* ((archive (match-string 1 defbranch)) 287 (category (match-string 4 defbranch)) 288 (branch (match-string 3 defbranch)) 289 (version (match-string 2 defbranch)) 290 (sealed nil) (rev-nb 0) 291 (rev nil) 292 logdir tmp) 293 (setq logdir (expand-file-name category root)) 294 (setq logdir (expand-file-name branch logdir)) 295 (setq logdir (expand-file-name version logdir)) 296 (setq logdir (expand-file-name archive logdir)) 297 (setq logdir (expand-file-name "patch-log" logdir)) 298 (dolist (file (if (file-directory-p logdir) (directory-files logdir))) 299 ;; Revision names go: base-0, patch-N, version-0, versionfix-M. 300 (when (and (eq (aref file 0) ?v) (not sealed)) 301 (setq sealed t rev-nb 0)) 302 (if (and (string-match "-\\([0-9]+\\)\\'" file) 303 (setq tmp (string-to-number (match-string 1 file))) 304 (or (not sealed) (eq (aref file 0) ?v)) 305 (>= tmp rev-nb)) 306 (setq rev-nb tmp rev file))) 307 ;; Use "none-000" if the tree hasn't yet been committed on the 308 ;; default branch. We'll then get "Arch:000[branch]" on the mode-line. 309 (concat defbranch "--" (or rev "none-000")))))) 310 311 312(defcustom vc-arch-mode-line-rewrite 313 '(("\\`.*--\\(.*--.*\\)--\\(v?\\).*-\\([0-9]+\\)\\'" . "\\2\\3[\\1]")) 314 "Rewrite rules to shorten Arch's revision names on the mode-line." 315 :type '(repeat (cons regexp string)) 316 :group 'vc) 317 318(defun vc-arch-mode-line-string (file) 319 "Return string for placement in modeline by `vc-mode-line' for FILE." 320 (let ((rev (vc-workfile-version file))) 321 (dolist (rule vc-arch-mode-line-rewrite) 322 (if (string-match (car rule) rev) 323 (setq rev (replace-match (cdr rule) t nil rev)))) 324 (format "Arch%c%s" 325 (case (vc-state file) 326 ((up-to-date needs-patch) ?-) 327 (added ?@) 328 (t ?:)) 329 rev))) 330 331(defun vc-arch-diff3-rej-p (rej) 332 (let ((attrs (file-attributes rej))) 333 (and attrs (< (nth 7 attrs) 60) 334 (with-temp-buffer 335 (insert-file-contents rej) 336 (goto-char (point-min)) 337 (looking-at "Conflicts occured, diff3 conflict markers left in file\\."))))) 338 339(defun vc-arch-delete-rej-if-obsolete () 340 "For use in `after-save-hook'." 341 (save-excursion 342 (let ((rej (concat buffer-file-name ".rej"))) 343 (when (and buffer-file-name (vc-arch-diff3-rej-p rej)) 344 (if (not (re-search-forward "^<<<<<<< " nil t)) 345 ;; The .rej file is obsolete. 346 (condition-case nil (delete-file rej) (error nil))))))) 347 348(defun vc-arch-find-file-hook () 349 (let ((rej (concat buffer-file-name ".rej"))) 350 (when (and buffer-file-name (file-exists-p rej)) 351 (if (vc-arch-diff3-rej-p rej) 352 (save-excursion 353 (goto-char (point-min)) 354 (if (not (re-search-forward "^<<<<<<< " nil t)) 355 ;; The .rej file is obsolete. 356 (condition-case nil (delete-file rej) (error nil)) 357 (smerge-mode 1) 358 (add-hook 'after-save-hook 359 'vc-arch-delete-rej-if-obsolete nil t) 360 (message "There are unresolved conflicts in this file"))) 361 (message "There are unresolved conflicts in %s" 362 (file-name-nondirectory rej)))))) 363 364(defun vc-arch-find-file-not-found-hook () 365 ;; Do nothing. We are not sure whether the file is `source' or not, 366 ;; so we shouldn't ask the user whether she wants to check it out. 367 ) 368 369(defun vc-arch-checkout-model (file) 'implicit) 370 371(defun vc-arch-checkin (file rev comment) 372 (if rev (error "Committing to a specific revision is unsupported")) 373 (let ((summary (file-relative-name file (vc-arch-root file)))) 374 ;; Extract a summary from the comment. 375 (when (or (string-match "\\`Summary:[ \t]*\\(.*[^ \t\n]\\)\\([ \t]*\n\\)*" comment) 376 (string-match "\\`[ \t]*\\(.*[^ \t\n]\\)[ \t]*\\(\n?\\'\\|\n\\([ \t]*\n\\)+\\)" comment)) 377 (setq summary (match-string 1 comment)) 378 (setq comment (substring comment (match-end 0)))) 379 (vc-arch-command nil 0 file "commit" "-s" summary "-L" comment "--" 380 (vc-switches 'Arch 'checkin)))) 381 382(defun vc-arch-diff (file &optional oldvers newvers buffer) 383 "Get a difference report using Arch between two versions of FILE." 384 (if (and newvers 385 (vc-up-to-date-p file) 386 (equal newvers (vc-workfile-version file))) 387 ;; Newvers is the base revision and the current file is unchanged, 388 ;; so we can diff with the current file. 389 (setq newvers nil)) 390 (if newvers 391 (error "Diffing specific revisions not implemented") 392 (let* ((async (and (not vc-disable-async-diff) (fboundp 'start-process))) 393 ;; Run the command from the root dir. 394 (default-directory (vc-arch-root file)) 395 (status 396 (vc-arch-command 397 (or buffer "*vc-diff*") 398 (if async 'async 1) 399 nil "file-diffs" 400 ;; Arch does not support the typical flags. 401 ;; (vc-switches 'Arch 'diff) 402 (file-relative-name file) 403 (if (equal oldvers (vc-workfile-version file)) 404 nil 405 oldvers)))) 406 (if async 1 status)))) ; async diff, pessimistic assumption. 407 408(defun vc-arch-delete-file (file) 409 (vc-arch-command nil 0 file "rm")) 410 411(defun vc-arch-rename-file (old new) 412 (vc-arch-command nil 0 new "mv" (file-relative-name old))) 413 414(defalias 'vc-arch-responsible-p 'vc-arch-root) 415 416(defun vc-arch-command (buffer okstatus file &rest flags) 417 "A wrapper around `vc-do-command' for use in vc-arch.el." 418 (apply 'vc-do-command buffer okstatus vc-arch-command file flags)) 419 420(defun vc-arch-init-version () nil) 421 422;;; Less obvious implementations. 423 424(defun vc-arch-find-version (file rev buffer) 425 (let ((out (make-temp-file "vc-out"))) 426 (unwind-protect 427 (progn 428 (with-temp-buffer 429 (vc-arch-command (current-buffer) 1 nil "file-diffs" file rev) 430 (call-process-region (point-min) (point-max) 431 "patch" nil nil nil "-R" "-o" out file)) 432 (with-current-buffer buffer 433 (insert-file-contents out))) 434 (delete-file out)))) 435 436(provide 'vc-arch) 437 438;; arch-tag: a35c7c1c-5237-429d-88ef-3d718fd2e704 439;;; vc-arch.el ends here 440