X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/b201b9880e01120b7e64f82c98464c5bea630b0d..0fb1193d6c3923cb3b2033e75f81a769ff2860f2:/lisp/vc-arch.el diff --git a/lisp/vc-arch.el b/lisp/vc-arch.el index ecaee28c6d..a723f98b8a 100644 --- a/lisp/vc-arch.el +++ b/lisp/vc-arch.el @@ -1,16 +1,17 @@ ;;; vc-arch.el --- VC backend for the Arch version-control system -;; Copyright (C) 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Stefan Monnier ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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 -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) 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 @@ -18,9 +19,7 @@ ;; 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 -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: @@ -50,22 +49,45 @@ ;; - C-x v u does not work. ;; - C-x v s does not work. ;; - C-x v r does not work. -;; - VC-dired does not work. +;; - VC directory listings do not work. ;; - And more... ;;; Code: (eval-when-compile (require 'vc) (require 'cl)) +;;; Properties of the backend + +(defun vc-arch-revision-granularity () 'repository) +(defun vc-arch-checkout-model (files) 'implicit) + ;;; ;;; Customization options ;;; -(defvar vc-arch-command +;; It seems Arch diff does not accept many options, so this is not +;; very useful. It exists mainly so that the VC backends are all +;; consistent with regards to their treatment of diff switches. +(defcustom vc-arch-diff-switches t + "String or list of strings specifying switches for Arch diff under VC. +If nil, use the value of `vc-diff-switches'. If t, use no switches." + :type '(choice (const :tag "Unspecified" nil) + (const :tag "None" t) + (string :tag "Argument String") + (repeat :tag "Argument List" :value ("") string)) + :version "23.1" + :group 'vc) + +(define-obsolete-variable-alias 'vc-arch-command 'vc-arch-program "23.1") + +(defcustom vc-arch-program (let ((candidates '("tla" "baz"))) (while (and candidates (not (executable-find (car candidates)))) (setq candidates (cdr candidates))) - (or (car candidates) "tla"))) + (or (car candidates) "tla")) + "Name of the Arch executable." + :type 'string + :group 'vc) ;; Clear up the cache to force vc-call to check again and discover ;; new functions when we reload this file. @@ -191,12 +213,14 @@ Only the value `maybe' can be trusted :-(." 'names)))) (defun vc-arch-root (file) - "Return the root directory of a Arch project, if any." + "Return the root directory of an Arch project, if any." (or (vc-file-getprop file 'arch-root) - (vc-file-setprop - ;; Check the =tagging-method, in case someone naively manually - ;; creates a {arch} directory somewhere. - file 'arch-root (vc-find-root file "{arch}/=tagging-method")))) + ;; 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))))) (defun vc-arch-register (files &optional rev comment) (if rev (error "Explicit initial revision not supported for Arch")) @@ -230,8 +254,7 @@ Only the value `maybe' can be trusted :-(." (buffer-substring (point-min) (1- (point-max))))))))) (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." + "Stub: arch workfiles are always considered to be in a changed state," nil) (defun vc-arch-state (file) @@ -283,6 +306,43 @@ Return non-nil if FILE is unchanged." 'up-to-date 'edited))))))))) +(defun vc-arch-dir-status (dir callback) + "Run 'tla inventory' for DIR and pass results to CALLBACK. +CALLBACK expects (ENTRIES &optional MORE-TO-COME); see +`vc-dir-refresh'." + (let ((default-directory dir)) + (vc-arch-command t 'async nil "changes")) + ;; The updating could be done asynchronously. + (vc-exec-after + `(vc-arch-after-dir-status ',callback))) + +(defun vc-arch-after-dir-status (callback) + (let* ((state-map '(("M " . edited) + ("Mb" . edited) ;binary + ("D " . removed) + ("D/" . removed) ;directory + ("A " . added) + ("A/" . added) ;directory + ("=>" . renamed) + ("/>" . renamed) ;directory + ("lf" . symlink-to-file) + ("fl" . file-to-symlink) + ("--" . permissions-changed) + ("-/" . permissions-changed) ;directory + )) + (state-map-regexp (regexp-opt (mapcar 'car state-map) t)) + (entry-regexp (concat "^" state-map-regexp " \\(.*\\)$")) + result) + (goto-char (point-min)) + ;;(message "Got %s" (buffer-string)) + (while (re-search-forward entry-regexp nil t) + (let* ((state-string (match-string 1)) + (state (cdr (assoc state-string state-map))) + (filename (match-string 2))) + (push (list filename state) result))) + + (funcall callback result nil))) + (defun vc-arch-working-revision (file) (let* ((root (expand-file-name "{arch}" (vc-arch-root file))) (defbranch (vc-arch-default-version file))) @@ -327,7 +387,7 @@ Return non-nil if FILE is unchanged." (setq rev (replace-match (cdr rule) t nil rev)))) (format "Arch%c%s" (case (vc-state file) - ((up-to-date needs-patch) ?-) + ((up-to-date needs-update) ?-) (added ?@) (t ?:)) rev))) @@ -345,9 +405,11 @@ Return non-nil if FILE is unchanged." (save-excursion (let ((rej (concat buffer-file-name ".rej"))) (when (and buffer-file-name (vc-arch-diff3-rej-p rej)) - (if (not (re-search-forward "^<<<<<<< " nil t)) - ;; The .rej file is obsolete. - (condition-case nil (delete-file rej) (error nil))))))) + (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)))))) (defun vc-arch-find-file-hook () (let ((rej (concat buffer-file-name ".rej"))) @@ -365,9 +427,7 @@ Return non-nil if FILE is unchanged." (message "There are unresolved conflicts in %s" (file-name-nondirectory rej)))))) -(defun vc-arch-checkout-model (file) 'implicit) - -(defun vc-arch-checkin (files rev comment) +(defun vc-arch-checkin (files rev comment &optional extra-args-ignored) (if rev (error "Committing to a specific revision is unsupported")) ;; FIXME: This implementation probably only works for singleton filesets (let ((summary (file-relative-name (car files) (vc-arch-root (car files))))) @@ -395,7 +455,8 @@ Return non-nil if FILE is unchanged." (setq newvers nil)) (if newvers (error "Diffing specific revisions not implemented") - (let* ((async (not vc-disable-async-diff)) + (let* (process-file-side-effects + (async (not vc-disable-async-diff)) ;; Run the command from the root dir. (default-directory (vc-arch-root file)) (status @@ -403,8 +464,7 @@ Return non-nil if FILE is unchanged." (or buffer "*vc-diff*") (if async 'async 1) nil "file-diffs" - ;; Arch does not support the typical flags. - ;; (vc-switches 'Arch 'diff) + (vc-switches 'Arch 'diff) (file-relative-name file) (if (equal oldvers (vc-working-revision file)) nil @@ -421,7 +481,7 @@ Return non-nil if FILE is unchanged." (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)) + (apply 'vc-do-command (or buffer "*vc*") okstatus vc-arch-program file flags)) (defun vc-arch-init-revision () nil) @@ -483,16 +543,20 @@ Return non-nil if FILE is unchanged." (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*")) + (lexical-let ((revs revs)) + (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)))))) + "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 ((garbage (directory-files dir 'full "\\`,," 'nosort))) + (when garbage + (funcall (vc-arch-trim-make-sentinel garbage) nil nil))) (let ((revs (sort (delq nil (mapcar @@ -515,7 +579,7 @@ Return non-nil if FILE is unchanged." "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 + (call-process vc-arch-program nil standard-output nil "my-revision-library")))) (while (string-match "\\(.*\\)\n" rl-dir) (let ((dir (match-string 1 rl-dir))) @@ -555,7 +619,7 @@ Return non-nil if FILE is unchanged." map)) (defun vc-arch-extra-menu () vc-arch-extra-menu-map) - + ;;; Less obvious implementations.