X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/3928b9a693901b9f25515307d5e20a0b952f6eef..f3f4e600399fdd8bf0a23e50b7704825145fddc4:/lisp/vc-mcvs.el diff --git a/lisp/vc-mcvs.el b/lisp/vc-mcvs.el index 6adfee7920..4075ffc364 100644 --- a/lisp/vc-mcvs.el +++ b/lisp/vc-mcvs.el @@ -1,6 +1,6 @@ ;;; vc-mcvs.el --- VC backend for the Meta-CVS version-control system -;; Copyright (C) 1995,98,99,2000,01,02,2003 Free Software Foundation, Inc. +;; Copyright (C) 2003, 2004, 2005, 2006 Free Software Foundation, Inc. ;; Author: FSF (see vc.el for full credits) ;; Maintainer: Stefan Monnier @@ -19,11 +19,15 @@ ;; 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, USA. +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. ;;; Commentary: +;; The home page of the Meta-CVS version control system is at +;; +;; http://users.footprints.net/~kaz/mcvs.html +;; ;; This is derived from vc-cvs.el as follows: ;; - cp vc-cvs.el vc-mcvs.el ;; - Replace CVS/ with MCVS/CVS/ @@ -42,12 +46,12 @@ ;; - C-x v l ;; - C-x v i ;; - C-x v g +;; - M-x vc-rename-file RET ;;; Bugs: -;; - Both the diff and log output contain Meta-CVS inode names so that -;; several operations in those buffers don't work as advertised. -;; - VC-dired doesn't work. +;; - Retrieving snapshots doesn't filter `cvs update' output and thus +;; parses bogus filenames. Don't know if it harms. ;;; Code: @@ -65,7 +69,7 @@ (repeat :tag "Argument List" :value ("") string)) - :version "21.4" + :version "22.1" :group 'vc) (defcustom vc-mcvs-register-switches nil @@ -77,7 +81,7 @@ A string or list of strings passed to the checkin program by (repeat :tag "Argument List" :value ("") string)) - :version "21.4" + :version "22.1" :group 'vc) (defcustom vc-mcvs-diff-switches nil @@ -87,13 +91,13 @@ A string or list of strings passed to the checkin program by (repeat :tag "Argument List" :value ("") string)) - :version "21.4" + :version "22.1" :group 'vc) (defcustom vc-mcvs-header (or (cdr (assoc 'MCVS vc-header-alist)) vc-cvs-header) "*Header keywords to be inserted by `vc-insert-headers'." - :version "21.4" + :version "22.1" :type '(repeat string) :group 'vc) @@ -102,19 +106,7 @@ A string or list of strings passed to the checkin program by This is only meaningful if you don't use the implicit checkout model \(i.e. if you have $CVSREAD set)." :type 'boolean - :version "21.4" - :group 'vc) - -(defcustom vc-mcvs-stay-local vc-cvs-stay-local - "*Non-nil means use local operations when possible for remote repositories. -This avoids slow queries over the network and instead uses heuristics -and past information to determine the current status of a file. -The value can also be a regular expression to match against the host name -of a repository; then VC only stays local for hosts that match it." - :type '(choice (const :tag "Always stay local" t) - (string :tag "Host regexp") - (const :tag "Don't stay local" nil)) - :version "21.4" + :version "22.1" :group 'vc) ;;; @@ -122,31 +114,22 @@ of a repository; then VC only stays local for hosts that match it." ;;; ;;;###autoload (defun vc-mcvs-registered (file) -;;;###autoload (let ((dir file)) -;;;###autoload (while (and (stringp dir) -;;;###autoload (not (equal dir (setq dir (file-name-directory dir))))) -;;;###autoload (setq dir (if (file-directory-p -;;;###autoload (expand-file-name "MCVS/CVS" dir)) -;;;###autoload t (directory-file-name dir)))) -;;;###autoload (if (eq dir t) -;;;###autoload (progn -;;;###autoload (load "vc-mcvs") -;;;###autoload (vc-mcvs-registered file))))) +;;;###autoload (if (vc-find-root file "MCVS/CVS") +;;;###autoload (progn +;;;###autoload (load "vc-mcvs") +;;;###autoload (vc-mcvs-registered file)))) (defun vc-mcvs-root (file) "Return the root directory of a Meta-CVS project, if any." - (let ((root nil)) - (while (not (or root (equal file (setq file (file-name-directory file))))) - (if (file-directory-p (expand-file-name "MCVS/CVS" file)) - (setq root file) - (setq file (directory-file-name file)))) - root)) + (or (vc-file-getprop file 'mcvs-root) + (vc-file-setprop file 'mcvs-root (vc-find-root file "MCVS/CVS")))) (defun vc-mcvs-read (file) - (with-temp-buffer - (insert-file-contents file) - (goto-char (point-min)) - (read (current-buffer)))) + (if (file-readable-p file) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (read (current-buffer))))) (defun vc-mcvs-map-file (dir file) (let ((map (vc-mcvs-read (expand-file-name "MCVS/MAP" dir))) @@ -158,9 +141,8 @@ of a repository; then VC only stays local for hosts that match it." (let (root inode cvsfile) (when (and (setq root (vc-mcvs-root file)) (setq inode (vc-mcvs-map-file - root (substring file (length root))))) + root (file-relative-name file root)))) (vc-file-setprop file 'mcvs-inode inode) - (vc-file-setprop file 'mcvs-root root) ;; Avoid calling `mcvs diff' in vc-workfile-unchanged-p. (vc-file-setprop file 'vc-checkout-time (if (vc-cvs-registered @@ -171,18 +153,11 @@ of a repository; then VC only stays local for hosts that match it." 0)) t))) -(defmacro vc-mcvs-cvs (op file &rest args) - (declare (debug t)) - `(,(intern (concat "vc-cvs-" (symbol-name op))) - (expand-file-name (vc-file-getprop ,file 'mcvs-inode) - (vc-file-getprop ,file 'mcvs-root)) - ,@args)) - (defun vc-mcvs-state (file) ;; This would assume the Meta-CVS sandbox is synchronized. ;; (vc-mcvs-cvs state file)) "Meta-CVS-specific version of `vc-state'." - (if (vc-mcvs-stay-local-p file) + (if (vc-stay-local-p file) (let ((state (vc-file-getprop file 'vc-state))) ;; If we should stay local, use the heuristic but only if ;; we don't have a more precise state already available. @@ -190,7 +165,7 @@ of a repository; then VC only stays local for hosts that match it." (vc-mcvs-state-heuristic file) state)) (with-temp-buffer - (cd (file-name-directory file)) + (setq default-directory (vc-mcvs-root file)) (vc-mcvs-command t 0 file "status") (vc-cvs-parse-status t)))) @@ -201,12 +176,13 @@ of a repository; then VC only stays local for hosts that match it." "Find the Meta-CVS state of all files in DIR." ;; if DIR is not under Meta-CVS control, don't do anything. (when (file-readable-p (expand-file-name "MCVS/CVS/Entries" dir)) - (if (vc-mcvs-stay-local-p dir) + (if (vc-stay-local-p dir) (vc-mcvs-dir-state-heuristic dir) (let ((default-directory dir)) ;; Don't specify DIR in this command, the default-directory is ;; enough. Otherwise it might fail with remote repositories. (with-temp-buffer + (setq default-directory (vc-mcvs-root dir)) (vc-mcvs-command t 0 nil "status" "-l") (goto-char (point-min)) (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t) @@ -215,12 +191,13 @@ of a repository; then VC only stays local for hosts that match it." (goto-char (point-max)) (widen))))))) -(defun vc-mcvs-workfile-version (file) (vc-mcvs-cvs workfile-version file)) +(defun vc-mcvs-workfile-version (file) + (vc-cvs-workfile-version + (expand-file-name (vc-file-getprop file 'mcvs-inode) + (vc-file-getprop file 'mcvs-root)))) (defalias 'vc-mcvs-checkout-model 'vc-cvs-checkout-model) -(defun vc-mcvs-mode-line-string (file) (vc-mcvs-cvs mode-line-string file)) - ;;; ;;; State-changing functions ;;; @@ -243,44 +220,35 @@ the Meta-CVS command (in that order)." ;; belly-up. (unless (file-writable-p map-file) (vc-checkout map-file t)) - (unless (file-writable-p types-file) + (unless (or (file-writable-p types-file) (not (file-exists-p types-file))) (vc-checkout types-file t)) ;; Make sure the `mcvs add' will not fire up the CVSEDITOR ;; to add a rule for the given file's extension. (when (and ext (not (assoc ext types))) - (let ((type (completing-read "Type to use [default]: " + (let ((type (completing-read "Type to use (default): " '("default" "name-only" "keep-old" "binary" "value-only") nil t nil nil "default"))) (push (list ext (make-symbol (upcase (concat ":" type)))) types) (setq types (sort types (lambda (x y) (string< (car x) (car y))))) (with-current-buffer (find-file-noselect types-file) - (if buffer-read-only (vc-checkout buffer-file-name t)) (erase-buffer) (pp types (current-buffer)) (save-buffer) (unless (get-buffer-window (current-buffer) t) (kill-buffer (current-buffer))))))) ;; Now do the ADD. - (let ((switches (append - (if (stringp vc-register-switches) - (list vc-register-switches) - vc-register-switches) - (if (stringp vc-mcvs-register-switches) - (list vc-mcvs-register-switches) - vc-mcvs-register-switches)))) - (prog1 (apply 'vc-mcvs-command nil 0 file - "add" - (and comment (string-match "[^\t\n ]" comment) - (concat "-m" comment)) - switches) - ;; I'm not sure exactly why, but if we don't setup the inode and root - ;; prop of the file, things break later on in vc-mode-line that - ;; ends up calling vc-mcvs-workfile-version. - (vc-mcvs-registered file) - ;; We also need to set vc-checkout-time so that vc-workfile-unchanged-p - ;; doesn't try to call `mcvs diff' on the file. - (vc-file-setprop file 'vc-checkout-time 0)))) + (prog1 (apply 'vc-mcvs-command nil 0 file + "add" + (and comment (string-match "[^\t\n ]" comment) + (concat "-m" comment)) + (vc-switches 'MCVS 'register)) + ;; I'm not sure exactly why, but if we don't setup the inode and root + ;; prop of the file, things break later on in vc-mode-line that + ;; ends up calling vc-mcvs-workfile-version. + ;; We also need to set vc-checkout-time so that vc-workfile-unchanged-p + ;; doesn't try to call `mcvs diff' on the file. + (vc-mcvs-registered file))) (defalias 'vc-mcvs-responsible-p 'vc-mcvs-root "Return non-nil if CVS thinks it is responsible for FILE.") @@ -291,26 +259,24 @@ This is only possible if Meta-CVS is responsible for FILE's directory.") (defun vc-mcvs-checkin (file rev comment) "Meta-CVS-specific version of `vc-backend-checkin'." - (let ((switches (if (stringp vc-checkin-switches) - (list vc-checkin-switches) - vc-checkin-switches)) - status) - (if (or (not rev) (vc-mcvs-valid-version-number-p rev)) - (setq status (apply 'vc-mcvs-command nil 1 file - "ci" (if rev (concat "-r" rev)) - "-m" comment - switches)) - (if (not (vc-mcvs-valid-symbolic-tag-name-p rev)) - (error "%s is not a valid symbolic tag name" rev) - ;; If the input revison is a valid symbolic tag name, we create it - ;; as a branch, commit and switch to it. - (apply 'vc-mcvs-command nil 0 file "tag" "-b" (list rev)) - (apply 'vc-mcvs-command nil 0 file "update" "-r" (list rev)) - (setq status (apply 'vc-mcvs-command nil 1 file - "ci" - "-m" comment - switches)) - (vc-file-setprop file 'vc-mcvs-sticky-tag rev))) + (unless (or (not rev) (vc-mcvs-valid-version-number-p rev)) + (if (not (vc-mcvs-valid-symbolic-tag-name-p rev)) + (error "%s is not a valid symbolic tag name" rev) + ;; If the input revision is a valid symbolic tag name, we create it + ;; as a branch, commit and switch to it. + ;; This file-specific form of branching is deprecated. + ;; We can't use `mcvs branch' and `mcvs switch' because they cannot + ;; be applied just to this one file. + (apply 'vc-mcvs-command nil 0 file "tag" "-b" (list rev)) + (apply 'vc-mcvs-command nil 0 file "update" "-r" (list rev)) + (vc-file-setprop file 'vc-mcvs-sticky-tag rev) + (setq rev nil))) + ;; This commit might cvs-commit several files (e.g. MAP and TYPES) + ;; so using numbered revs here is dangerous and somewhat meaningless. + (when rev (error "Cannot commit to a specific revision number")) + (let ((status (apply 'vc-mcvs-command nil 1 file + "ci" "-m" comment + (vc-switches 'MCVS 'checkin)))) (set-buffer "*vc*") (goto-char (point-min)) (when (not (zerop status)) @@ -349,17 +315,12 @@ This is only possible if Meta-CVS is responsible for FILE's directory.") (and rev (not (string= rev "")) (concat "-r" rev)) "-p" - (if (stringp vc-checkout-switches) - (list vc-checkout-switches) - vc-checkout-switches))) + (vc-switches 'MCVS 'checkout))) (defun vc-mcvs-checkout (file &optional editable rev) (message "Checking out %s..." file) (with-current-buffer (or (get-file-buffer file) (current-buffer)) - (let ((switches (if (stringp vc-checkout-switches) - (list vc-checkout-switches) - vc-checkout-switches))) - (vc-call update file editable rev switches))) + (vc-call update file editable rev (vc-switches 'MCVS 'checkout))) (vc-mode-line file) (message "Checking out %s...done" file)) @@ -384,9 +345,12 @@ This is only possible if Meta-CVS is responsible for FILE's directory.") (concat "-r" rev)) switches))) +(defun vc-mcvs-rename-file (old new) + (vc-mcvs-command nil 0 new "move" (file-relative-name old))) + (defun vc-mcvs-revert (file &optional contents-done) "Revert FILE to the version it was based on." - (vc-default-revert file contents-done) + (vc-default-revert 'MCVS file contents-done) (unless (eq (vc-checkout-model file) 'implicit) (if vc-mcvs-use-edit (vc-mcvs-command nil 0 file "unedit") @@ -457,71 +421,69 @@ The changes are between FIRST-VERSION and SECOND-VERSION." ;;; History functions ;;; -(defun vc-mcvs-print-log (file) +(defun vc-mcvs-print-log (file &optional buffer) "Get change log associated with FILE." - (vc-mcvs-command - nil - (if (and (vc-mcvs-stay-local-p file) (fboundp 'start-process)) 'async 0) - file "log")) - -(defun vc-mcvs-diff (file &optional oldvers newvers) + (let ((default-directory (vc-mcvs-root file))) + ;; Run the command from the root dir so that `mcvs filt' returns + ;; valid relative names. + (vc-mcvs-command + buffer + (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0) + file "log"))) + +(defun vc-mcvs-diff (file &optional oldvers newvers buffer) "Get a difference report using Meta-CVS between two versions of FILE." - (let (status (diff-switches-list (vc-diff-switches-list 'MCVS))) - (if (string= (vc-workfile-version file) "0") - ;; This file is added but not yet committed; there is no master file. - (if (or oldvers newvers) - (error "No revisions of %s exist" file) - ;; We regard this as "changed". - ;; Diff it against /dev/null. - ;; Note: this is NOT a "mcvs diff". - (apply 'vc-do-command "*vc-diff*" - 1 "diff" file - (append diff-switches-list '("/dev/null")))) - (setq status - (apply 'vc-mcvs-command "*vc-diff*" - (if (and (vc-mcvs-stay-local-p file) - (fboundp 'start-process)) - 'async - 1) - file "diff" - (and oldvers (concat "-r" oldvers)) - (and newvers (concat "-r" newvers)) - diff-switches-list)) - (if (vc-mcvs-stay-local-p file) - 1 ;; async diff, pessimistic assumption - status)))) + (if (string= (vc-workfile-version file) "0") + ;; This file is added but not yet committed; there is no master file. + (if (or oldvers newvers) + (error "No revisions of %s exist" file) + ;; We regard this as "changed". + ;; Diff it against /dev/null. + ;; Note: this is NOT a "mcvs diff". + (apply 'vc-do-command (or buffer "*vc-diff*") + 1 "diff" file + (append (vc-switches nil 'diff) '("/dev/null"))) + ;; Even if it's empty, it's locally modified. + 1) + (let* ((async (and (not vc-disable-async-diff) + (vc-stay-local-p file) + (fboundp 'start-process))) + ;; Run the command from the root dir so that `mcvs filt' returns + ;; valid relative names. + (default-directory (vc-mcvs-root file)) + (status + (apply 'vc-mcvs-command (or buffer "*vc-diff*") + (if async 'async 1) + file "diff" + (and oldvers (concat "-r" oldvers)) + (and newvers (concat "-r" newvers)) + (vc-switches 'MCVS 'diff)))) + (if async 1 status)))) ; async diff, pessimistic assumption. (defun vc-mcvs-diff-tree (dir &optional rev1 rev2) "Diff all files at and below DIR." (with-current-buffer "*vc-diff*" - (setq default-directory dir) - (if (vc-mcvs-stay-local-p dir) - ;; local diff: do it filewise, and only for files that are modified - (vc-file-tree-walk - dir - (lambda (f) - (vc-exec-after - `(let ((coding-system-for-read (vc-coding-system-for-diff ',f))) - ;; possible optimization: fetch the state of all files - ;; in the tree via vc-mcvs-dir-state-heuristic - (unless (vc-up-to-date-p ',f) - (message "Looking at %s" ',f) - (vc-diff-internal ',f ',rev1 ',rev2)))))) - ;; cvs diff: use a single call for the entire tree - (let ((coding-system-for-read - (or coding-system-for-read 'undecided))) - (apply 'vc-mcvs-command "*vc-diff*" 1 nil "diff" - (and rev1 (concat "-r" rev1)) - (and rev2 (concat "-r" rev2)) - (vc-diff-switches-list 'MCVS)))))) + ;; Run the command from the root dir so that `mcvs filt' returns + ;; valid relative names. + (setq default-directory (vc-mcvs-root dir)) + ;; cvs diff: use a single call for the entire tree + (let ((coding-system-for-read (or coding-system-for-read 'undecided))) + (apply 'vc-mcvs-command "*vc-diff*" 1 dir "diff" + (and rev1 (concat "-r" rev1)) + (and rev2 (concat "-r" rev2)) + (vc-switches 'MCVS 'diff))))) (defun vc-mcvs-annotate-command (file buffer &optional version) "Execute \"mcvs annotate\" on FILE, inserting the contents in BUFFER. Optional arg VERSION is a version to annotate from." (vc-mcvs-command buffer - (if (and (vc-mcvs-stay-local-p file) (fboundp 'start-process)) 'async 0) - file "annotate" (if version (concat "-r" version)))) + (if (and (vc-stay-local-p file) (fboundp 'start-process)) 'async 0) + file "annotate" (if version (concat "-r" version))) + (with-current-buffer buffer + (goto-char (point-min)) + (re-search-forward "^[0-9]") + (delete-region (point-min) (1- (point))))) (defalias 'vc-mcvs-annotate-current-time 'vc-cvs-annotate-current-time) (defalias 'vc-mcvs-annotate-time 'vc-cvs-annotate-time) @@ -534,8 +496,10 @@ Optional arg VERSION is a version to annotate from." "Assign to DIR's current version a given NAME. If BRANCHP is non-nil, the name is created as a branch (and the current workspace is immediately moved to that new branch)." - (vc-mcvs-command nil 0 dir "tag" "-c" (if branchp "-b") name) - (when branchp (vc-mcvs-command nil 0 dir "update" "-r" name))) + (if (not branchp) + (vc-mcvs-command nil 0 dir "tag" "-c" name) + (vc-mcvs-command nil 0 dir "branch" name) + (vc-mcvs-command nil 0 dir "switch" name))) (defun vc-mcvs-retrieve-snapshot (dir name update) "Retrieve a snapshot at and below DIR. @@ -578,7 +542,7 @@ If UPDATE is non-nil, then update (resynch) any affected buffers." ;;; Miscellaneous ;;; -(defalias 'vc-mcvs-make-version-backups-p 'vc-mcvs-stay-local-p +(defalias 'vc-mcvs-make-version-backups-p 'vc-stay-local-p "Return non-nil if version backups should be made for FILE.") (defalias 'vc-mcvs-check-headers 'vc-cvs-check-headers) @@ -591,14 +555,29 @@ If UPDATE is non-nil, then update (resynch) any affected buffers." "A wrapper around `vc-do-command' for use in vc-mcvs.el. The difference to vc-do-command is that this function always invokes `mcvs', and that it passes `vc-mcvs-global-switches' to it before FLAGS." - (apply 'vc-do-command buffer okstatus "mcvs" file - (append '("--error-continue") - (if (stringp vc-mcvs-global-switches) - (cons vc-mcvs-global-switches flags) - (append vc-mcvs-global-switches - flags))))) - -(defun vc-mcvs-stay-local-p (file) (vc-mcvs-cvs stay-local-p file)) + (let ((args (append '("--error-terminate") + (if (stringp vc-mcvs-global-switches) + (cons vc-mcvs-global-switches flags) + (append vc-mcvs-global-switches flags))))) + (if (not (member (car flags) '("diff" "log" "status"))) + ;; No need to filter: do it the easy way. + (apply 'vc-do-command buffer okstatus "mcvs" file args) + ;; We need to filter the output. + ;; The output of the filter uses filenames relative to the root, + ;; so we need to change the default-directory. + ;; (assert (equal default-directory (vc-mcvs-root file))) + (vc-do-command + buffer okstatus "sh" nil "-c" + (concat "mcvs " + (mapconcat + 'shell-quote-argument + (append (remq nil args) + (if file (list (file-relative-name file)))) + " ") + " | mcvs filt"))))) + +(defun vc-mcvs-repository-hostname (dirname) + (vc-cvs-repository-hostname (vc-mcvs-root dirname))) (defun vc-mcvs-dir-state-heuristic (dir) "Find the Meta-CVS state of all files in DIR, using only local information." @@ -617,4 +596,6 @@ and that it passes `vc-mcvs-global-switches' to it before FLAGS." (defalias 'vc-mcvs-valid-version-number-p 'vc-cvs-valid-version-number-p) (provide 'vc-mcvs) + +;; arch-tag: a39c7c1c-5247-429d-88df-dd7187d2e704 ;;; vc-mcvs.el ends here