# HG changeset patch # User Gerd Moellmann # Date 968096779 0 # Node ID 2d74ed749db818653bde4adf016f910decced793 # Parent 58ff79ca361ee4af6a974096e9d47c6baf1cdfa6 (vc-next-action-on-file): Do not visit the file if it's not necessary. If verbose in state `needs-patch', do the same as under `up-to-date'. When NOT verbose and `needs-patch', check out latest version instead of `merge-news'. (vc-next-action-dired): Don't mess with default-directory here; it breaks other parts of dired. It is the job of the backend-specific functions to adjust it temporarily if they need it. (vc-next-action): Remove a special CVS case. (vc-clear-headers): New optional arg FILE. (vc-checkin, vc-checkout): Set properties vc-state and vc-checkout-time properly. (vc-finish-steal): Call steal-lock, not steal, which doesn't exist. (vc-print-log): Use new backend function `show-log-entry'. (vc-cancel-version): Do the checks in a different order. Added a FIXME concerning RCS-only code. (vc-responsible-backend): New optional arg `register'. (vc-default-could-register): New function. (vc-dired-buffers-for-dir, vc-dired-resynch-file): New functions. (vc-resynch-buffer): Call vc-dired-resynch-file. (vc-start-entry, vc-finish-logentry, vc-revert-buffer): Use vc-resynch-buffer instead of vc-resynch-window. (vc-next-action-dired): Don't redisplay here, that gets done as a result of the individual file operations. (vc-retrieve-snapshot): Corrected prompt order. (vc-version-diff): Use `require' to check for existence of diff-mode. (vc-do-command): Doc fix. (vc-finish-logentry): When checking in from vc-dired, choose the right backend for logentry check. (vc-dired-mode-map): Inherit from dired-mode-map. (vc-dired-mode): Local value of dired-move-to-filename-regexp simplified. (vc-dired-state-info): Removed, updated caller. (vc-default-dired-state-info): Use parentheses instead of hyphens. (vc-dired-hook): Use vc-BACKEND-dir-state, if available. (vc-dired-listing-switches): New variable. (vc-directory): Use it, instead of dired-listing-switches. (vc-revert-buffer): Hide the frame for dedicated windows (vc-update-changelog): Split into generic part and default implementation. Doc string adapted. (vc-default-update-changelog): New function. Call the `rcs2log' script in exec-directory, to fix a long-standing nuisance. (vc-next-action-on-file): Doc fix. (vc-maybe-resolve-conflicts): Don't just toggle smerge-mode. (vc-print-log): Eval `file' before constructing the continuation. (vc-next-action-on-file): Corrected several messages. (vc-merge): Add prefix arg `merge-news'; handle it. (vc-finish-logentry): Thinko in the "same comment" detection. (vc-parent-buffer, vc-parent-buffer-name): Protect them against kill-all-local-variables. (vc-log-edit): Don't save vc-parent-buffer any more. (vc-last-comment-match): Initialize to an empty string. (vc-post-command-functions): New hook. (vc-do-command): Run it. (vc-next-action-on-file): Remove unnecessary pop-to-buffer. (vc-finish-logentry): Only add the comment to the ring if it's different from the last comment entered. (vc-new-comment-index): New function. (vc-previous-comment): Use it. Make the minibuffer message slightly less terse. (vc-comment-search-reverse): Make it work forward as well. Don't set vc-comment-ring-index if no match is found. Use vc-new-comment-index. (vc-comment-search-forward): Use vc-comment-search-reverse. (vc-dired-mode-map): Don't inherit from dired-mode-map since define-derived-mode will do it for us. Bind `v' to a keymap that inherits from vc-prefix-map so that we can bind `vt' without binding C-x v t. (vc-retrieve-snapshot): Parenthesis typo. (vc-create-snapshot, vc-default-create-snapshot): Swap DIR and NAME. (vc-retrieve-snapshot): Split into two parts. (vc-default-retrieve-snapshot): New function. (vc-do-command): Remove unused commands. (vc-version-diff): Make sure default-directory ends with a slash. Move the window commands into a vc-exec-after. (vc-print-log): Move more of the code into the `vc-exec-after'. (vc-exec-after): Fix disassembly of previous sentinel. (vc-print-log): Search current revision from beginning of buffer. (vc-revert-buffer): Clear echo area after the diff is finished. (vc-prefix-map): Removed definition of "t" for terse display in vc dired. (vc-dired-mode-map): Inherit from dired-mode-map. Added definition of "vt" for terse display. (vc-dired-mode): Fix dired-move-to-filename-regexp. (vc-exec-after): Avoid caddr. (vc-exec-after): New function. (vc-do-command): Use it to add a termination message for async procs. (vc-checkout): Try to handle a missing-backend situation. (vc-version-diff): Use vc-exec-after to fix the behavior for diffs of a directory with a backend using async diffs. (vc-print-log): Use vc-exec-after and use log-view-goto-rev if present. (vc-next-action-on-file): Use vc-revert-buffer to revert when there are no changes. (vc-prefix-map): Move the autoload to vc-hooks.el and move the `fset' outside of the defvar so that it works even if vc-prefix-map was already defined. (vc-setup-buffer): New function, split out of vc-do-command. (vc-do-command): Allow BUFFER to be t to mean `just use the current buffer without any fuss'. (vc-version-diff): Change the `diff' backend operation to just put the diff in the current buffer without erasing it. Always use (vc-workfile-unchanged-p): If checkout-time comparison is not possible, use vc-BACKEND-workfile-unchanged-p. (vc-default-workfile-unchanged-p): New function. Delegates to a full vc-BACKEND-diff. (vc-editable-p): Renamed from vc-writable-p. (with-vc-file, vc-merge): Use vc-editable-p. (vc-do-command): Remove unused var vc-file and fix the doubly-defined `status' var. Add a user message when starting an async command. (vc-restore-buffer-context, vc-resynch-buffer, vc-start-entry) (vc-finish-steal, vc-checkin, vc-finish-logentry, vc-rename-file): Use with-current-buffer. (vc-buffer-sync): Use unless. (vc-next-action-on-file): If the file is 'edited by read-only, make it read-write instead of trying to commit. (vc-version-diff, vc-update-change-log): Use `setq default-directory' rather than `cd'. (vc-log-edit): Don't forget to set default-directory in the buffer. (vc-checkout): Don't do anything special for ange-ftp files since ange-ftp already has vc-registered return nil. (vc-do-command): Use file-relative-name. (vc-responsible-backend): Use vc-backend if possible. (vc-create-snapshot): Improve the `interactive' spec. Add support for branches and dispatch to backend-specific `create-snapshot'. (vc-default-create-snapshot): New function, containing the bulk of the old vc-create-snapshot. (vc-retrieve-snapshot): Improve the interactive spec. (vc-do-command): Get rid of the `last' argument. (vc-header-alist): Remove, replaced by vc-X-header. (vc-insert-headers): Use vc-X-header instead of vc-header-alist. (vc-dired-hook): Use expand-file-name instead of concat. (vc-directory): Use file-name-as-directory. (vc-snapshot-precondition, vc-create-snapshot) (vc-retrieve-snapshot): Allow the command to operate on any directory. Update Copyright and add a crude list of backend funs. (vc-writable-p): New function. (with-vc-file): Use vc-writable-p. (vc-next-action-on-file): Update call to vc-steal-lock and cleanup. (vc-register): Avoid vc-name. (vc-locking-user): Remove. (vc-steal-lock): Make the `owner' arg non-optional. (vc-merge): Use vc-writable-p instead of vc-locking-user and vc-checkout-model. (vc-default-dired-state-info): Use vc-state instead of vc-locking-user and return special strings for special states. (vc-dired-hook): Use vc-up-to-date-p instead of vc-locking-user and get rid of one of the special CVS cases. (vc-cancel-version): prettify error message with \\[...]. (vc-rename-master): New function. (vc-rename-file): Use vc-BACKEND-rename-file (which might in turn use vc-rename-master) instead of vc-BACKEND-record-rename. Make the CVS special case generic. (vc-default-record-rename): Remove. (vc-file-tree-walk-internal): Only call FUNC for files that are under control of some VC backend and replace `concat' with expand-file-name. (vc-file-tree-walk): Update docstring. (vc-version-diff, vc-snapshot-precondition, vc-create-snapshot) (vc-retrieve-snapshot): Update call to vc-file-tree-walk. (vc-version-diff): Expand file name read from the minibuffer. Handle the case when a previous version number can't be guessed. Give suitable messages when there were no differences found. (vc-clear-headers): Call backend-specific implementation, if one exists. (vc-cancel-version): Made error checks generic. When done, clear headers generically, too. (vc-locking-user): Moved from vc-hooks.el. (vc-version-diff): Left out a vc- in call to vc-call-backend. (vc-default-dired-state-info, vc-default-record-rename) (vc-default-merge-news): Update for the new backend argument. (vc-merge): Use vc-find-backend-function. (vc-register): Put a FIXME note for a newly found bug. Call vc-call-backend without the leading vc-. (vc-responsible-backend, vc-finish-logentry, vc-annotate) (vc-check-headers): Call vc-call-backend without the leading vc-. (vc-annotate-time-span): Replace confusing use of `cond' with `or'. (vc-annotate-display): Replace confusing use of `cond' with `or'. Call vc-call-backend without the leading vc-. (vc-process-filter): New function. (vc-do-command): Setup `vc-process-filter' for the async process. (vc-maybe-resolve-conflicts): New function to reduce code-duplication. Additionally, it puts the buffer in `smerge-mode' if applicable. (vc-next-action-on-file): Use `vc-maybe-resolve-conflicts' after calling `merge-news'. (vc-merge): Use `vc-maybe-resolve-conflicts' after calling `merge'. (vc-log-edit): New function. Replacement for `vc-log-mode' by interfacing to log-edit.el. (vc-start-entry): Call `vc-log-edit' instead of `vc-log-mode' if log-edit is available. (vc-resolve-conflicts): Delegate to `smerge-ediff' if available. (vc-register): Remove `vc-buffer-backend' setup. (vc-log-mode-map): New name for vc-log-entry-mode and merge the defvar and the initialization. (vc-log-mode): Minor docstring fix and use vc-log-mode-map. (vc-file-clear-masterprops): Removed. (vc-checkin, vc-revert-buffer): Removed calls to the above. (vc-version-diff): Use buffer-size without argument. (vc-register): Heed vc-initial-comment. (vc-workfile-unchanged-p): Remove unused argument `want-differences-if-changed' and simplify. (vc-next-action-on-file) [needs-merge]: Resynch the buffer. (vc-revert-buffer): Use `unchanged-p' rather than vc-diff's status output (which is invalid for async vc-diff) to decide whether to do the revert silently or not. (with-vc-file, vc-next-action, vc-version-diff) (vc-dired-mark-locked): Replaced usage of vc-locking-user with vc-state or vc-up-to-date-p. (vc-merge): Use vc-backend-defines to check whether merging is possible. Set state to 'edited after successful merge. (vc-recompute-state, vc-next-action-on-file): Update to new `vc-state' semantics. (vc-finish-steal): Set 'vc-state to 'edited rather than setting 'vc-locking-user to the current user. (vc-merge): Inline vc-backend-merge. Comment out code that I don't understand and hence can't adapt to the new `vc-state' and `vc-locking-user' semantics. (vc-backend-merge): Remove. (vc-do-command): kill-all-local-variables, to reset any major-mode in which the buffer might have been put earlier. Use `remove' and `when'. Allow `okstatus' to be `async' and use `start-process' in this case. (vc-version-diff): Handle the case where the diff looks empty because of the use of an async process. (vc-next-action-on-file): Removed optional parameter `simple'. Recompute state unconditionally. (vc-default-toggle-read-only): Removed. (vc-backend-dispatch, vc-annotate-mode-syntax-table): Remove. (vc-prefix-map): Move from vc-hooks.el and make autoloaded. (vc-release-greater-or-equal-p): Move to vc-rcs.el. (vc-file-clear-masterprops): Braindead "fix". It was a nop and still is. So maybe it should be removed. (vc-head-version, vc-find-binary): Remove. (vc-recompute-state): Move from vc-hooks.el. (vc-next-action-on-file): Add a `simple' argument to allow avoiding the `recompute' step (use for vc-cvs-simple-toggle). (vc-default-toggle-read-only, vc-default-record-rename): New functions. (vc-next-action, vc-dired-hook): Use vc-state instead of vc-cvs-status. (vc-dired-mode-map): Properly defvar it. (vc-print-log): Call log-view-mode if available. (small-temporary-file-directory): defvar instead of use boundp. (vc-merge-news): Moved to vc-cvs.el. (vc-default-merge-news): New function. (function' quotes. (vc-annotate-mode-map, vc-annotate-mode-syntax-table): Initialize directly in the defvar. (vc-do-command): Bind inhibit-read-only so as to properly handle the case where the destination buffer has been made read-only. (vc-diff): Delegate to vc-version-diff in all cases. (vc-version-diff): Setup the *vc-diff* buffer as was done in vc-diff. (vc-annotate-mode-variables): Removed (code moved partly to defvars and partly to vc-annotate-add-menu). (vc-annotate-mode): Turned into a derived-mode. (vc-annotate-add-menu): Moved in code in vc-annotate-mode-variables. (vc-update-change-log): Use make-temp-file if available. (vc-next-action-on-file): Added handling of state `unlocked-changes'. (vc-checkout-carefully): Is now practically obsolete, unless the above is too slow to be enabled unconditionally. (vc-update-change-log): Fixed typo. (vc-responsible-backend): New function. (vc-register): Largely rewritten. (vc-admin): Removed (implementation moved into vc-register). (vc-checkin): Redocumented. (vc-finish-logentry): If no backend defined yet (because we are in the process of registering), use the responsible backend. Updated callers of `vc-checkout-required' to use `vc-checkout-model'. (vc-backend-release, vc-backend-release-p): Functions moved into vc-rcs.el (vc-backend-revert): Function moved into `vc-revert'; `vc-next-action' must be updated to accomodate this change. (vc-backend-steal): Function moved into `vc-finish-steal'. (vc-backend-logentry-check): Function moved into `vc-finish-logentry'. (vc-backend-printlog): Function moved into `vc-print-log'. (vc-backend-uncheck): Function moved into `vc-cancel-version'. (vc-backend-assign-name): Function moved into `vc-create-snapshot'. (vc-workfile-unchanged-p,vc-diff,vc-version-diff): Updated to use the vc-BACKEND-diff functions instead; `vc-diff' is now working. Typo fixed. This checkin is made with our new VC code base for the very first time. A simple `(vc-checkin (buffer-file-name))' was used to perform it. (vc-checkin): Merged with `vc-backend-checkin' and updated to match the split into various backends. (vc-backend-checkin): Removed. Merged with `vc-checkin'. (vc-retrieve-snapshot): Bug fix. (vc-next-action-on-file): Bug found and fixed. (vc-checkout, vc-version-other-window, vc-retrieve-snapshot) (vc-cancel-version): Handle of vc-BACKEND-checkout updated. (vc-next-action-on-file): Rewritten for the new state model. (vc-backend-merge-news): Renamed to `vc-merge-news'. (Specific parts still need to be split, and implemented for RCS). (vc-admin): Updated to handle selection of appropriate backend. Current implementation is crufty and need re-thinking. (vc-annotate-get-backend, vc-annotate-display-default) (vc-annotate-add-menu, vc-annotate, vc-annotate-display): Annotate functionality updated quite a lot to support multiple backends. Variables `vc-annotate-mode', `vc-annotate-buffers', `vc-annotate-backend' added. Renamed `vc-uses-locking' to `vc-checkout-required'. Renamed the `locked' state to `reserved'. (vc-update-change-log): Use small-temporary-file-directory, if defined. (Merged from main line, slightly adapted.) Split the annotate feature into a BACKEND specific part and moved it from the vc-cvs.el file to this one. (vc-resynch-window): Added TODO comment: check for interaction with view mode according to recent RCS change. (vc-backend-merge-news): Merged "CMUP" patch from mainline. Converted the remaining function comments to documentation strings. (vc-backend-release, vc-release-greater-or-equal) (vc-backend-release-p, vc-trunk-p, vc-branch-p, vc-branch-part) (vc-minor-part, vc-previous-version): Functions that operate and compare revision numbers got proper documentation. Comments added about their possible removal. (vc-latest-on-branch-p): Function removed and replaced in the vc-backend.el files. (vc-backend-diff): Function removed and placed in the backend files. (vc-backend-checkout): Function removed and replaced in the vc-backend.el files. (vc-backend-admin): Removed and replaced in the vc-backend.el files. (Martin): Removed all the annotate functionality since it is CVS backend specific. [Merged from mainline.] (vc-dired-mode): Make the dired-move-to-filename-regexp regexp match the date, to avoid treating date as file size. Add YYYY S option to WESTERN/ Require `compile' when compiling. (vc-logentry-check-hook): New option. (vc-steal-lock): Use compose-mail. (vc-dired-mode-map): Defvar when compiling. (vc-add-triple, vc-record-rename, vc-lookup-triple): Moved to vc-sccs.el and renamed. Callers changed. (vc-backend-checkout, vc-backend-logentry-check) (vc-backend-merge-news): Doc fix. (vc-default-logentry-check): New function. (vc-backend-checkin, vc-backend-revert, vc-backend-steal) (vc-backend-uncheck, vc-backend-print-log, vc-backend-assign-name) (vc-backend-merge): Doc fix. Use backend functions. (vc-check-headers): Use backend functions. (vc-backend-release): Call vc-system-release. (vc-rcs-release, vc-cvs-release, vc-sccs-release): Moved to backend files. (vc-backend-release): Dispatch to backend functions. (vc-backend-release-p): Don't mention CVS, RCS. [The SCCS case probably needs attention.] (vc-dired-mode, vc-dired-reformat-line, vc-dired-purge): Doc fix. (vc-fetch-cvs-status): Moved to vc-cvs.el and renamed. (vc-default-dired-state-info): New function. (vc-dired-state-info): Dispatch to backends. (vc-dired-hook): Doc fix. Simplify, pending removal of CVS specifics. (vc-file-clear-masterprops, vc-latest-on-branch-p) (vc-version-other-window, vc-backend-assign-name): Removed references to vc-latest-version; sometimes changed into vc-workfile-version. (with-vc-file, vc-next-action-on-file, vc-merge) (vc-backend-checkout): Changed calls to `vc-checkout-model' to `vc-uses-locking'. (vc-fetch-cvs-status): Use renamed vc-cvs-parse-status. Some doc fixes for autoloaded and interactive functions. Fix compilation warnings from ediff stuff. (vc-rcs-release, vc-cvs-release, vc-sccs-release): Custom fix. This is 1.244 from the emacs sources diff -r 58ff79ca361e -r 2d74ed749db8 lisp/vc.el --- a/lisp/vc.el Mon Sep 04 19:44:28 2000 +0000 +++ b/lisp/vc.el Mon Sep 04 19:46:19 2000 +0000 @@ -1,11 +1,11 @@ ;;; vc.el --- drive a version-control system from within Emacs -;; Copyright (C) 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc. +;; Copyright (C) 1992,93,94,95,96,97,98,2000 Free Software Foundation, Inc. -;; Author: Eric S. Raymond -;; Maintainer: Andre Spiegel +;; Author: FSF (see below for full credits) +;; Maintainer: Andre Spiegel -;; $Id: vc.el,v 1.259 2000/01/26 10:31:13 gerd Exp $ +;; $Id: vc.el,v 1.1 2000/09/04 19:35:57 gerd Exp gerd $ ;; This file is part of GNU Emacs. @@ -24,29 +24,36 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Credits: + +;; VC was initially designed and implemented by Eric S. Raymond +;; . Over the years, many people have +;; contributed substantial amounts of work to VC. These include: +;; Per Cederqvist +;; Paul Eggert +;; Sebastian Kremer +;; Martin Lorentzson +;; Dave Love +;; Stefan Monnier +;; Andre Spiegel +;; Richard Stallman +;; ttn@netcom.com + ;;; Commentary: ;; This mode is fully documented in the Emacs user's manual. ;; -;; This was designed and implemented by Eric Raymond . -;; Paul Eggert , Sebastian Kremer , -;; and Richard Stallman contributed valuable criticism, support, and testing. -;; CVS support was added by Per Cederqvist -;; in Jan-Feb 1994. Further enhancements came from ttn@netcom.com and -;; Andre Spiegel . -;; ;; Supported version-control systems presently include SCCS, RCS, and CVS. ;; ;; Some features will not work with old RCS versions. Where ;; appropriate, VC finds out which version you have, and allows or -;; disallows those features (stealing locks, for example, works only +;; disallows those features (stealing locks, for example, works only ;; from 5.6.2 onwards). ;; Even initial checkins will fail if your RCS version is so old that ci ;; doesn't understand -t-; this has been known to happen to people running -;; NExTSTEP 3.0. +;; NExTSTEP 3.0. ;; -;; You can support the RCS -x option by adding pairs to the -;; vc-master-templates list. +;; You can support the RCS -x option by customizing vc-rcs-master-templates. ;; ;; Proper function of the SCCS diff commands requires the shellscript vcdiff ;; to be installed somewhere on Emacs's path for executables. @@ -54,11 +61,6 @@ ;; If your site uses the ChangeLog convention supported by Emacs, the ;; function vc-comment-to-change-log should prove a useful checkin hook. ;; -;; This code depends on call-process passing back the subprocess exit -;; status. Thus, you need Emacs 18.58 or later to run it. For the -;; vc-directory command to work properly as documented, you need 19. -;; You also need Emacs 19's ring.el. -;; ;; The vc code maintains some internal state in order to reduce expensive ;; version-control operations to a minimum. Some names are only computed ;; once. If you perform version control operations with RCS/SCCS/CVS while @@ -70,32 +72,90 @@ ;;; Code: +;;;;;;;;;;;;;;;;; Backend-specific functions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; for each operation FUN, the backend should provide a function vc-BACKEND-FUN. +;; Operations marked with a `-' instead of a `*' have a sensible default +;; behavior. + +;; * registered (file) +;; * state (file) +;; - state-heuristic (file) +;; The default behavior delegates to `state'. +;; - dir-state (dir) +;; * checkout-model (file) +;; - mode-line-string (file) +;; * workfile-version (file) +;; * revert (file) +;; * merge-news (file) +;; * merge (file rev1 rev2) +;; * steal-lock (file &optional version) +;; * register (file rev comment) +;; * responsible-p (file) +;; Should also work if FILE is a directory (ends with a slash). +;; - could-register (file) +;; * checkout (file writable &optional rev destfile) +;; Checkout revision REV of FILE into DESTFILE. +;; DESTFILE defaults to FILE. +;; The file should be made writable if WRITABLE is non-nil. +;; REV can be nil (BASE) or "" (HEAD) or any other revision. +;; * checkin (file rev comment) +;; - logentry-check () +;; * diff (file &optional rev1 rev2) +;; Insert the diff for FILE into the current buffer. +;; REV1 should default to workfile-version. +;; REV2 should default to the current workfile +;; Return a status of either 0 (i.e. no diff) or 1 (i.e. either non-empty +;; diff or the diff is run asynchronously). +;; - workfile-unchanged-p (file) +;; Return non-nil if FILE is unchanged from its current workfile version. +;; This function should do a brief comparison of FILE's contents +;; with those of the master version. If the backend does not have +;; such a brief-comparison feature, the default implementation of this +;; function can be used, which delegates to a full vc-BACKEND-diff. +;; - clear-headers () +;; * check-headers () +;; - dired-state-info (file) +;; - create-snapshot (dir name branchp) +;; Take a snapshot of the current state of files under DIR and name it NAME. +;; This should make sure that files are up-to-date before proceeding +;; with the action. +;; DIR can also be a file and if BRANCHP is specified, NAME +;; should be created as a branch and DIR should be checked out under +;; this new branch. The default behavior does not support branches +;; but does a sanity check, a tree traversal and for each file calls +;; `assign-name'. +;; * assign-name (file name) +;; Give name NAME to the current version of FILE, assuming it is +;; up-to-date. Only used by the default version of `create-snapshot'. +;; - retrieve-snapshot (dir name update) +;; Retrieve a named snapshot of all registered files at or below DIR. +;; If UPDATE is non-nil, then update buffers of any files in the snapshot +;; that are currently visited. +;; * print-log (file) +;; Insert the revision log of FILE into the current buffer. +;; - show-log-entry (version) +;; - update-changelog (files) +;; Find changelog entries for FILES, or for all files at or below +;; the default-directory if FILES is nil. +;; * latest-on-branch-p (file) +;; Only used for sanity check before calling `uncheck'. +;; * uncheck (file target) +;; * rename-file (old new) +;; * annotate-command (file buf) +;; * annotate-difference (pos) + (require 'vc-hooks) (require 'ring) -(eval-when-compile (require 'dired)) ; for dired-map-over-marks macro +(eval-when-compile + (require 'compile) + (require 'dired)) ; for dired-map-over-marks macro (if (not (assoc 'vc-parent-buffer minor-mode-alist)) (setq minor-mode-alist (cons '(vc-parent-buffer vc-parent-buffer-name) minor-mode-alist))) -;; To implement support for a new version-control system, add another -;; branch to the vc-backend-dispatch macro and fill it in in each -;; call. The variable vc-master-templates in vc-hooks.el will also -;; have to change. - -(defmacro vc-backend-dispatch (f s r c) - "Execute FORM1, FORM2 or FORM3 for SCCS, RCS or CVS respectively. -If FORM3 is `RCS', use FORM2 for CVS as well as RCS. -\(CVS shares some code with RCS)." - (list 'let (list (list 'type (list 'vc-backend f))) - (list 'cond - (list (list 'eq 'type (quote 'SCCS)) s) ;; SCCS - (list (list 'eq 'type (quote 'RCS)) r) ;; RCS - (list (list 'eq 'type (quote 'CVS)) ;; CVS - (if (eq c 'RCS) r c)) - ))) - ;; General customization (defgroup vc nil @@ -122,7 +182,7 @@ (defcustom vc-default-init-version "1.1" "*A string used as the default version number when a new file is registered. -This can be overriden by giving a prefix argument to \\[vc-register]." +This can be overridden by giving a prefix argument to \\[vc-register]." :type 'string :group 'vc :version "20.3") @@ -162,6 +222,12 @@ string)) :group 'vc) +(defcustom vc-dired-listing-switches "-al" + "*Switches passed to `ls' for vc-dired. MUST contain the `l' option." + :type 'string + :group 'vc + :version "21.0") + (defcustom vc-dired-recurse t "*If non-nil, show directory trees recursively in VC Dired." :type 'boolean @@ -184,8 +250,31 @@ ;;; This is duplicated in diff.el. (defvar diff-switches "-c" - "*A string or list of strings specifying switches to be be passed to diff.") + "*A string or list of strings specifying switches to be passed to diff.") + +;;;###autoload +(defcustom vc-checkin-hook nil + "*Normal hook (list of functions) run after a checkin is done. +See `run-hooks'." + :type 'hook + :options '(vc-comment-to-change-log) + :group 'vc) +;;;###autoload +(defcustom vc-before-checkin-hook nil + "*Normal hook (list of functions) run before a file gets checked in. +See `run-hooks'." + :type 'hook + :group 'vc) + +(defcustom vc-logentry-check-hook nil + "*Normal hook run by `vc-backend-logentry-check'. +Use this to impose your own rules on the entry in addition to any the +version control backend imposes itself." + :type 'hook + :group 'vc) + +;; Annotate customization (defcustom vc-annotate-color-map '(( 26.3672 . "#FF0000") ( 52.7344 . "#FF3800") @@ -207,7 +296,7 @@ "*Association list of age versus color, for \\[vc-annotate]. Ages are given in units of 2**-16 seconds. Default is eighteen steps using a twenty day increment." - :type 'sexp + :type 'alist :group 'vc) (defcustom vc-annotate-very-old-color "#0046FF" @@ -224,52 +313,30 @@ (defcustom vc-annotate-menu-elements '(2 0.5 0.1 0.01) "*Menu elements for the mode-specific menu of VC-Annotate mode. List of factors, used to expand/compress the time scale. See `vc-annotate'." - :type 'sexp - :group 'vc) - -;;;###autoload -(defcustom vc-checkin-hook nil - "*Normal hook (list of functions) run after a checkin is done. -See `run-hooks'." - :type 'hook - :options '(vc-comment-to-change-log) - :group 'vc) - -;;;###autoload -(defcustom vc-before-checkin-hook nil - "*Normal hook (list of functions) run before a file gets checked in. -See `run-hooks'." - :type 'hook + :type '(repeat number) :group 'vc) -;;;###autoload -(defcustom vc-annotate-mode-hook nil - "*Hooks to run when VC-Annotate mode is turned on." - :type 'hook - :group 'vc) +;; vc-annotate functionality (CVS only). +(defvar vc-annotate-mode nil + "Variable indicating if VC-Annotate mode is active.") + +(defvar vc-annotate-mode-map + (let ((m (make-sparse-keymap))) + (define-key m [menu-bar] (make-sparse-keymap "VC-Annotate")) + m) + "Local keymap used for VC-Annotate mode.") + +(defvar vc-annotate-mode-menu nil + "Local keymap used for VC-Annotate mode's menu bar menu.") ;; Header-insertion hair -(defcustom vc-header-alist - '((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$")) - "*Header keywords to be inserted by `vc-insert-headers'. -Must be a list of two-element lists, the first element of each must -be `RCS', `CVS', or `SCCS'. The second element is the string to -be inserted for this particular backend." - :type '(repeat (list :format "%v" - (choice :tag "System" - (const SCCS) - (const RCS) - (const CVS)) - (string :tag "Header"))) - :group 'vc) - (defcustom vc-static-header-alist '(("\\.c$" . "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n")) - "*Associate static header string templates with file types. A \%s in the -template is replaced with the first string associated with the file's -version-control type in `vc-header-alist'." + "*Associate static header string templates with file types. +A \%s in the template is replaced with the first string associated with +the file's version-control type in `vc-header-alist'." :type '(repeat (cons :format "%v" (regexp :tag "File Type") (string :tag "Header String"))) @@ -288,6 +355,9 @@ :group 'vc) ;; Default is to be extra careful for super-user. +;; TODO: This variable is no longer used; the corresponding checks +;; are always done now. If that turns out to be fast enough, +;; the variable can be obsoleted. (defcustom vc-checkout-carefully (= (user-uid) 0) "*Non-nil means be extra-careful in checkout. Verify that the file really is not locked @@ -295,44 +365,61 @@ :type 'boolean :group 'vc) -(defcustom vc-rcs-release nil - "*The release number of your RCS installation, as a string. -If nil, VC itself computes this value when it is first needed." - :type '(choice (const :tag "Auto" nil) - string - (const :tag "Unknown" unknown)) - :group 'vc) + +;;; The main keymap -(defcustom vc-sccs-release nil - "*The release number of your SCCS installation, as a string. -If nil, VC itself computes this value when it is first needed." - :type '(choice (const :tag "Auto" nil) - string - (const :tag "Unknown" unknown)) - :group 'vc) +(defvar vc-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'vc-update-change-log) + (define-key map "c" 'vc-cancel-version) + (define-key map "d" 'vc-directory) + (define-key map "g" 'vc-annotate) + (define-key map "h" 'vc-insert-headers) + (define-key map "i" 'vc-register) + (define-key map "l" 'vc-print-log) + (define-key map "m" 'vc-merge) + (define-key map "r" 'vc-retrieve-snapshot) + (define-key map "s" 'vc-create-snapshot) + (define-key map "u" 'vc-revert-buffer) + (define-key map "v" 'vc-next-action) + (define-key map "=" 'vc-diff) + (define-key map "~" 'vc-version-other-window) + map)) +(fset 'vc-prefix-map vc-prefix-map) -(defcustom vc-cvs-release nil - "*The release number of your CVS installation, as a string. -If nil, VC itself computes this value when it is first needed." - :type '(choice (const :tag "Auto" nil) - string - (const :tag "Unknown" unknown)) - :group 'vc) +;; Initialization code, to be done just once at load-time +(defvar vc-log-mode-map + (let ((map (make-sparse-keymap))) + (define-key map "\M-n" 'vc-next-comment) + (define-key map "\M-p" 'vc-previous-comment) + (define-key map "\M-r" 'vc-comment-search-reverse) + (define-key map "\M-s" 'vc-comment-search-forward) + (define-key map "\C-c\C-c" 'vc-finish-logentry) + map)) +;; Compatibility with old name. Should we bother ? +(defvar vc-log-entry-mode vc-log-mode-map) + ;; Variables the user doesn't need to know about. -(defvar vc-log-entry-mode nil) (defvar vc-log-operation nil) (defvar vc-log-after-operation-hook nil) (defvar vc-checkout-writable-buffer-hook 'vc-checkout-writable-buffer) +(defvar vc-annotate-buffers nil + "An association list of current \"Annotate\" buffers and their +corresponding backends. The keys are \(BUFFER . BACKEND\). See also +`vc-annotate-get-backend'.") ;; In a log entry buffer, this is a local variable ;; that points to the buffer for which it was made ;; (either a file, or a VC dired buffer). (defvar vc-parent-buffer nil) +(put 'vc-parent-buffer 'permanent-local t) (defvar vc-parent-buffer-name nil) +(put 'vc-parent-buffer-name 'permanent-local t) (defvar vc-log-file) (defvar vc-log-version) +;; FIXME: only used in vc-sccs.el (defconst vc-name-assoc-file "VC-names") (defvar vc-dired-mode nil) @@ -340,93 +427,30 @@ (defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size)) (defvar vc-comment-ring-index nil) -(defvar vc-last-comment-match nil) - -;;; Find and compare backend releases - -(defun vc-backend-release (backend) - ;; Returns which backend release is installed on this system. - (cond - ((eq backend 'RCS) - (or vc-rcs-release - (and (zerop (vc-do-command nil nil "rcs" nil nil "-V")) - (save-excursion - (set-buffer (get-buffer "*vc*")) - (setq vc-rcs-release - (car (vc-parse-buffer - '(("^RCS version \\([0-9.]+ *.*\\)" 1))))))) - (setq vc-rcs-release 'unknown))) - ((eq backend 'CVS) - (or vc-cvs-release - (and (zerop (vc-do-command nil 1 "cvs" nil nil "-v")) - (save-excursion - (set-buffer (get-buffer "*vc*")) - (setq vc-cvs-release - (car (vc-parse-buffer - '(("^Concurrent Versions System (CVS) \\([0-9.]+\\)" - 1))))))) - (setq vc-cvs-release 'unknown))) - ((eq backend 'SCCS) - vc-sccs-release))) +(defvar vc-last-comment-match "") -(defun vc-release-greater-or-equal (r1 r2) - ;; Compare release numbers, represented as strings. - ;; Release components are assumed cardinal numbers, not decimal - ;; fractions (5.10 is a higher release than 5.9). Omitted fields - ;; are considered lower (5.6.7 is earlier than 5.6.7.1). - ;; Comparison runs till the end of the string is found, or a - ;; non-numeric component shows up (5.6.7 is earlier than "5.6.7 beta", - ;; which is probably not what you want in some cases). - ;; This code is suitable for existing RCS release numbers. - ;; CVS releases are handled reasonably, too (1.3 < 1.4* < 1.5). - (let (v1 v2 i1 i2) - (catch 'done - (or (and (string-match "^\\.?\\([0-9]+\\)" r1) - (setq i1 (match-end 0)) - (setq v1 (string-to-number (match-string 1 r1))) - (or (and (string-match "^\\.?\\([0-9]+\\)" r2) - (setq i2 (match-end 0)) - (setq v2 (string-to-number (match-string 1 r2))) - (if (> v1 v2) (throw 'done t) - (if (< v1 v2) (throw 'done nil) - (throw 'done - (vc-release-greater-or-equal - (substring r1 i1) - (substring r2 i2))))))) - (throw 'done t))) - (or (and (string-match "^\\.?\\([0-9]+\\)" r2) - (throw 'done nil)) - (throw 'done t))))) - -(defun vc-backend-release-p (backend release) - ;; Return t if we have RELEASE of BACKEND or better - (let (i r (ri 0) (ii 0) is rs (installation (vc-backend-release backend))) - (if (not (eq installation 'unknown)) - (cond - ((or (eq backend 'RCS) (eq backend 'CVS)) - (vc-release-greater-or-equal installation release)))))) - -;;; functions that operate on RCS revision numbers - +;;; functions that operate on RCS revision numbers. This code should +;;; also be moved into the backends. It stays for now, however, since +;;; it is used in code below. (defun vc-trunk-p (rev) - ;; return t if REV is a revision on the trunk + "Return t if REV is a revision on the trunk" (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev)))) (defun vc-branch-p (rev) - ;; return t if REV is a branch revision + "Return t if REV is a branch revision" (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev)))) (defun vc-branch-part (rev) - ;; return the branch part of a revision number REV + "return the branch part of a revision number REV" (substring rev 0 (string-match "\\.[0-9]+\\'" rev))) (defun vc-minor-part (rev) - ;; return the minor version number of a revision number REV + "Return the minor version number of a revision number REV" (string-match "[0-9]+\\'" rev) (substring rev (match-beginning 0) (match-end 0))) (defun vc-previous-version (rev) - ;; guess the previous version number + "Guess the previous version number" (let ((branch (vc-branch-part rev)) (minor-num (string-to-number (vc-minor-part rev)))) (if (> minor-num 1) @@ -450,86 +474,36 @@ ;; log buffer with a nonzero local value of vc-comment-ring-index. (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size))) -(defun vc-file-clear-masterprops (file) - ;; clear all properties of FILE that were retrieved - ;; from the master file - (vc-file-setprop file 'vc-latest-version nil) - (vc-file-setprop file 'vc-your-latest-version nil) - (vc-backend-dispatch file - (progn ;; SCCS - (vc-file-setprop file 'vc-master-locks nil)) - (progn ;; RCS - (vc-file-setprop file 'vc-default-branch nil) - (vc-file-setprop file 'vc-head-version nil) - (vc-file-setprop file 'vc-master-workfile-version nil) - (vc-file-setprop file 'vc-master-locks nil)) - (progn - (vc-file-setprop file 'vc-cvs-status nil)))) - -(defun vc-head-version (file) - ;; Return the RCS head version of FILE - (cond ((vc-file-getprop file 'vc-head-version)) - (t (vc-fetch-master-properties file) - (vc-file-getprop file 'vc-head-version)))) - ;; Random helper functions -(defun vc-latest-on-branch-p (file) - ;; return t iff the current workfile version of FILE is - ;; the latest on its branch. - (vc-backend-dispatch file - ;; SCCS - (string= (vc-workfile-version file) (vc-latest-version file)) - ;; RCS - (let ((workfile-version (vc-workfile-version file)) tip-version) - (if (vc-trunk-p workfile-version) - (progn - ;; Re-fetch the head version number. This is to make - ;; sure that no-one has checked in a new version behind - ;; our back. - (vc-fetch-master-properties file) - (string= (vc-file-getprop file 'vc-head-version) - workfile-version)) - ;; If we are not on the trunk, we need to examine the - ;; whole current branch. (vc-master-workfile-version - ;; is not what we need.) - (save-excursion - (set-buffer (get-buffer-create "*vc-info*")) - (vc-insert-file (vc-name file) "^desc") - (setq tip-version (car (vc-parse-buffer (list (list - (concat "^\\(" (regexp-quote (vc-branch-part workfile-version)) - "\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2))))) - (if (get-buffer "*vc-info*") - (kill-buffer (get-buffer "*vc-info*"))) - (string= tip-version workfile-version)))) - ;; CVS - t)) +(defsubst vc-editable-p (file) + (or (eq (vc-checkout-model file) 'implicit) + (eq (vc-state file) 'edited) + (eq (vc-state file) 'needs-merge))) ;;; Two macros for elisp programming ;;;###autoload (defmacro with-vc-file (file comment &rest body) - "Execute BODY, checking out a writable copy of FILE first if necessary. -After BODY has been executed, check-in FILE with COMMENT (a string). -FILE is passed through `expand-file-name'; BODY executed within -`save-excursion'. If FILE is not under version control, or locked by + "Check out a writable copy of FILE if necessary and execute the body. +Check in FILE with COMMENT (a string) after BODY has been executed. +FILE is passed through `expand-file-name'; BODY executed within +`save-excursion'. If FILE is not under version control, or locked by somebody else, signal error." `(let ((file (expand-file-name ,file))) (or (vc-registered file) (error (format "File not under version control: `%s'" file))) - (let ((locking-user (vc-locking-user file))) - (cond ((and (not locking-user) - (eq (vc-checkout-model file) 'manual)) - (vc-checkout file t)) - ((and (stringp locking-user) - (not (string= locking-user (vc-user-login-name)))) - (error (format "`%s' is locking `%s'" locking-user file))))) + (unless (vc-editable-p file) + (let ((state (vc-state file))) + (if (stringp state) (error (format "`%s' is locking `%s'" state file)) + (vc-checkout file t)))) (save-excursion ,@body) (vc-checkin file nil ,comment))) ;;;###autoload (defmacro edit-vc-file (file comment &rest body) - "Edit FILE under version control, executing BODY. Checkin with COMMENT. + "Edit FILE under version control, executing body. +Checkin with COMMENT after executing BODY. This macro uses `with-vc-file', passing args to it. However, before executing BODY, find FILE, and after BODY, save buffer." `(with-vc-file @@ -539,7 +513,8 @@ (save-buffer))) (defun vc-ensure-vc-buffer () - ;; Make sure that the current buffer visits a version-controlled file. + "Make sure that the current buffer visits a version-controlled +file." (if vc-dired-mode (set-buffer (find-file-noselect (dired-get-filename))) (while vc-parent-buffer @@ -554,111 +529,131 @@ (if (memq system-type '(ms-dos windows-nt)) '(".exe" ".com" ".bat" ".cmd" ".btm" "") '(""))) -(defun vc-find-binary (name) - "Look for a command anywhere on the subprocess-command search path." - (or (cdr (assoc name vc-binary-assoc)) - (catch 'found - (mapcar - (function - (lambda (s) - (if s - (let ((full (concat s "/" name)) - (suffixes vc-binary-suffixes) - candidate) - (while suffixes - (setq candidate (concat full (car suffixes))) - (if (and (file-executable-p candidate) - (not (file-directory-p candidate))) - (progn - (setq vc-binary-assoc - (cons (cons name candidate) vc-binary-assoc)) - (throw 'found candidate)) - (setq suffixes (cdr suffixes)))))))) - exec-path) - nil))) -(defun vc-do-command (buffer okstatus command file last &rest flags) - "Execute a version-control command, notifying user and checking for errors. -Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil. The -command is considered successful if its exit status does not exceed -OKSTATUS (if OKSTATUS is nil, that means to ignore errors). FILE is -the name of the working file (may also be nil, to execute commands -that don't expect a file name). If FILE is non-nil, the argument LAST -indicates what filename should actually be passed to the command: if -it is `MASTER', the name of FILE's master file is used, if it is -`WORKFILE', then FILE is passed through unchanged. If an optional -list of FLAGS is present, that is inserted into the command line -before the filename." - (and file (setq file (expand-file-name file))) - (if (not buffer) (setq buffer "*vc*")) - (if vc-command-messages - (message "Running %s on %s..." command file)) - (let ((obuf (current-buffer)) (camefrom (current-buffer)) - (squeezed nil) - (olddir default-directory) - vc-file status) - (set-buffer (get-buffer-create buffer)) +(defun vc-process-filter (p s) + "An alternative output filter for async processes. +The only difference with the default filter is to insert S after markers." + (with-current-buffer (process-buffer p) + (save-excursion + (let ((inhibit-read-only t)) + (goto-char (process-mark p)) + (insert s) + (set-marker (process-mark p) (point)))))) + +(defun vc-setup-buffer (&optional buf) + "prepare BUF for executing a VC command and make it the current buffer. +BUF defaults to \"*vc*\", can be a string and will be created if necessary." + (unless buf (setq buf "*vc*")) + (let ((camefrom (current-buffer)) + (olddir default-directory)) + (set-buffer (get-buffer-create buf)) + (kill-all-local-variables) (set (make-local-variable 'vc-parent-buffer) camefrom) (set (make-local-variable 'vc-parent-buffer-name) (concat " from " (buffer-name camefrom))) (setq default-directory olddir) - - (erase-buffer) + (let ((inhibit-read-only t)) + (erase-buffer)))) + +(defun vc-exec-after (code) + "Eval CODE when the current buffer's process is done. +If the current buffer has no process, just evaluate CODE. +Else, add CODE to the process' sentinel." + (let ((proc (get-buffer-process (current-buffer)))) + (cond + ;; If there's no background process, just execute the code. + ((null proc) (eval code)) + ;; If the background process has exited, reap it and try again + ((eq (process-status proc) 'exit) + (delete-process proc) + (vc-exec-after code)) + ;; If a process is running, add CODE to the sentinel + ((eq (process-status proc) 'run) + (let ((sentinel (process-sentinel proc))) + (set-process-sentinel proc + `(lambda (p s) + (with-current-buffer ',(current-buffer) + (goto-char (process-mark p)) + ,@(append (cdr (cdr (cdr ;strip off `with-current-buffer buf + ; (goto-char...)' + (car (cdr (cdr ;strip off `lambda (p s)' + sentinel)))))) + (list `(vc-exec-after ',code)))))))) + (t (error "Unexpected process state")))) + nil) + +(defvar vc-post-command-functions nil + "Hook run at the end of `vc-do-command'. +Each function is called inside the buffer in which the command was run +and is passed 3 argument: the COMMAND, the FILE and the FLAGS.") - (mapcar - (function (lambda (s) (and s (setq squeezed (append squeezed (list s)))))) - flags) - (if (and (eq last 'MASTER) file (setq vc-file (vc-name file))) - (setq squeezed (append squeezed (list vc-file)))) - (if (and file (eq last 'WORKFILE)) - (progn - (let* ((pwd (expand-file-name default-directory)) - (preflen (length pwd))) - (if (string= (substring file 0 preflen) pwd) - (setq file (substring file preflen)))) - (setq squeezed (append squeezed (list file))))) - (let ((exec-path (append vc-path exec-path)) - ;; Add vc-path to PATH for the execution of this command. - (process-environment - (cons (concat "PATH=" (getenv "PATH") - path-separator - (mapconcat 'identity vc-path path-separator)) - process-environment)) - (w32-quote-process-args t)) - (setq status (apply 'call-process command nil t nil squeezed))) - (goto-char (point-max)) - (set-buffer-modified-p nil) - (forward-line -1) - (if (or (not (integerp status)) (and okstatus (< okstatus status))) - (progn - (pop-to-buffer buffer) - (goto-char (point-min)) - (shrink-window-if-larger-than-buffer) - (error "Running %s...FAILED (%s)" command - (if (integerp status) - (format "status %d" status) - status)) - ) - (if vc-command-messages - (message "Running %s...OK" command)) - ) - (set-buffer obuf) - status) - ) +(defun vc-do-command (buffer okstatus command file &rest flags) + "Execute a version-control command, notifying user and checking for errors. +Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil or the current +buffer (which is assumed to be properly setup) if BUFFER is t. The +command is considered successful if its exit status does not exceed +OKSTATUS (if OKSTATUS is nil, that means to ignore errors, if it is 'async, +that means not to wait for termination of the subprocess). FILE is +the name of the working file (may also be nil, to execute commands +that don't expect a file name). If an optional list of FLAGS is present, +that is inserted into the command line before the filename." + (and file (setq file (expand-file-name file))) + (if vc-command-messages + (message "Running %s on %s..." command file)) + (save-current-buffer + (unless (eq buffer t) (vc-setup-buffer buffer)) + (let ((squeezed nil) + (inhibit-read-only t) + (status 0)) + (setq squeezed (delq nil (copy-sequence flags))) + (when file + ;; FIXME: file-relative-name can return a bogus result because + ;; it doesn't look at the actual file-system to see if symlinks + ;; come into play. + (setq squeezed (append squeezed (list (file-relative-name file))))) + (let ((exec-path (append vc-path exec-path)) + ;; Add vc-path to PATH for the execution of this command. + (process-environment + (cons (concat "PATH=" (getenv "PATH") + path-separator + (mapconcat 'identity vc-path path-separator)) + process-environment)) + (w32-quote-process-args t)) + (if (eq okstatus 'async) + (let ((proc (apply 'start-process command (current-buffer) command + squeezed))) + (message "Running %s in the background..." command) + ;;(set-process-sentinel proc (lambda (p msg) (delete-process p))) + (set-process-filter proc 'vc-process-filter) + (vc-exec-after + `(message "Running %s in the background... done" ',command))) + (setq status (apply 'call-process command nil t nil squeezed)) + (when (or (not (integerp status)) (and okstatus (< okstatus status))) + (pop-to-buffer (current-buffer)) + (goto-char (point-min)) + (shrink-window-if-larger-than-buffer) + (error "Running %s...FAILED (%s)" command + (if (integerp status) (format "status %d" status) status)))) + (if vc-command-messages + (message "Running %s...OK" command))) + (vc-exec-after + `(run-hook-with-args 'vc-post-command-functions ',command ',file ',flags)) + status))) -;;; Save a bit of the text around POSN in the current buffer, to help -;;; us find the corresponding position again later. This works even -;;; if all markers are destroyed or corrupted. -;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode. (defun vc-position-context (posn) + "Save a bit of the text around POSN in the current buffer, to help +us find the corresponding position again later. This works even if +all markers are destroyed or corrupted." + ;; A lot of this was shamelessly lifted from Sebastian Kremer's + ;; rcs.el mode. (list posn (buffer-size) (buffer-substring posn (min (point-max) (+ posn 100))))) -;;; Return the position of CONTEXT in the current buffer, or nil if we -;;; couldn't find it. (defun vc-find-position-by-context (context) + "Return the position of CONTEXT in the current buffer, or nil if we +couldn't find it." (let ((context-string (nth 2 context))) (if (equal "" context-string) (point-max) @@ -677,7 +672,7 @@ (- (point) (length context-string)))))))) (defun vc-context-matches-p (posn context) - ;; Returns t if POSN matches CONTEXT, nil otherwise. + "Returns t if POSN matches CONTEXT, nil otherwise." (let* ((context-string (nth 2 context)) (len (length context-string)) (end (+ posn len))) @@ -686,8 +681,8 @@ (string= context-string (buffer-substring posn end))))) (defun vc-buffer-context () - ;; Return a list '(point-context mark-context reparse); from which - ;; vc-restore-buffer-context can later restore the context. + "Return a list '(point-context mark-context reparse); from which +vc-restore-buffer-context can later restore the context." (let ((point-context (vc-position-context (point))) ;; Use mark-marker to avoid confusion in transient-mark-mode. (mark-context (if (eq (marker-buffer (mark-marker)) (current-buffer)) @@ -701,8 +696,7 @@ ;; iff that buffer is a compilation output buffer ;; that contains markers into the current buffer. (save-excursion - (mapcar (function - (lambda (buffer) + (mapcar (lambda (buffer) (set-buffer buffer) (let ((errors (or compilation-old-error-list @@ -716,21 +710,20 @@ (cdr (car errors)))) (setq buffer-error-marked-p t)) (setq errors (cdr errors))) - (if buffer-error-marked-p buffer)))) + (if buffer-error-marked-p buffer))) (buffer-list))))))) (list point-context mark-context reparse))) (defun vc-restore-buffer-context (context) - ;; Restore point/mark, and reparse any affected compilation buffers. - ;; CONTEXT is that which vc-buffer-context returns. + "Restore point/mark, and reparse any affected compilation buffers. +CONTEXT is that which vc-buffer-context returns." (let ((point-context (nth 0 context)) (mark-context (nth 1 context)) (reparse (nth 2 context))) ;; Reparse affected compilation buffers. (while reparse (if (car reparse) - (save-excursion - (set-buffer (car reparse)) + (with-current-buffer (car reparse) (let ((compilation-last-buffer (current-buffer)) ;select buffer ;; Record the position in the compilation buffer of ;; the last error next-error went to. @@ -755,211 +748,191 @@ (let ((new-mark (vc-find-position-by-context mark-context))) (if new-mark (set-mark new-mark)))))) -;; Maybe this "smart mark preservation" could be added directly -;; to revert-buffer since it can be generally useful. -sm (defun vc-revert-buffer1 (&optional arg no-confirm) - ;; Revert buffer, try to keep point and mark where user expects them in spite - ;; of changes because of expanded version-control key words. - ;; This is quite important since otherwise typeahead won't work as expected. + "Revert buffer, try to keep point and mark where user expects them +in spite of changes because of expanded version-control key words. +This is quite important since otherwise typeahead won't work as +expected." (interactive "P") (widen) (let ((context (vc-buffer-context))) ;; Use save-excursion here, because it may be able to restore point ;; and mark properly even in cases where vc-restore-buffer-context - ;; would fail. However, save-excursion might also get it wrong -- + ;; would fail. However, save-excursion might also get it wrong -- ;; in this case, vc-restore-buffer-context gives it a second try. (save-excursion - ;; t means don't call normal-mode; + ;; t means don't call normal-mode; ;; that's to preserve various minor modes. (revert-buffer arg no-confirm t)) (vc-restore-buffer-context context))) (defun vc-buffer-sync (&optional not-urgent) - ;; Make sure the current buffer and its working file are in sync - ;; NOT-URGENT means it is ok to continue if the user says not to save. + "Make sure the current buffer and its working file are in sync +NOT-URGENT means it is ok to continue if the user says not to save." (if (buffer-modified-p) (if (or vc-suppress-confirm (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name)))) (save-buffer) - (if not-urgent - nil + (unless not-urgent (error "Aborted"))))) - -(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed) - ;; Has the given workfile changed since last checkout? +(defun vc-workfile-unchanged-p (file) + "Has the given workfile changed since last checkout?" (let ((checkout-time (vc-file-getprop file 'vc-checkout-time)) - (lastmod (nth 5 (file-attributes file)))) - (or (equal checkout-time lastmod) - (and (or (not checkout-time) want-differences-if-changed) - (let ((unchanged (zerop (vc-backend-diff file nil nil - (not want-differences-if-changed))))) - ;; 0 stands for an unknown time; it can't match any mod time. - (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0)) - unchanged))))) + (lastmod (nth 5 (file-attributes file)))) + (if checkout-time + (equal checkout-time lastmod) + (let ((unchanged (vc-call workfile-unchanged-p file))) + (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0)) + unchanged)))) + +(defun vc-default-workfile-unchanged-p (file) + "Default check whether workfile is unchanged: diff against master version." + (zerop (vc-call diff file (vc-workfile-version file)))) + +(defun vc-recompute-state (file) + "Force a recomputation of the version control state of FILE. +The state is computed using the exact, and possibly expensive +function `vc-BACKEND-state', not the heuristic." + (vc-file-setprop file 'vc-state (vc-call state file))) (defun vc-next-action-on-file (file verbose &optional comment) - ;;; If comment is specified, it will be used as an admin or checkin comment. - (let ((vc-type (vc-backend file)) - owner version buffer) - (cond - - ;; If the file is not under version control, register it - ((not vc-type) - (vc-register verbose comment)) - - ;; CVS: changes to the master file need to be - ;; merged back into the working file - ((and (eq vc-type 'CVS) - (or (eq (vc-cvs-status file) 'needs-checkout) - (eq (vc-cvs-status file) 'needs-merge))) - (if (or vc-dired-mode - (yes-or-no-p - (format "%s is not up-to-date. Merge in changes now? " - (buffer-name)))) - (progn - (if vc-dired-mode - (and (setq buffer (get-file-buffer file)) - (buffer-modified-p buffer) - (switch-to-buffer-other-window buffer) - (vc-buffer-sync t)) - (setq buffer (current-buffer)) - (vc-buffer-sync t)) - (if (and buffer (buffer-modified-p buffer) - (not (yes-or-no-p - (format - "Buffer %s modified; merge file on disc anyhow? " - (buffer-name buffer))))) - (error "Merge aborted")) - (let ((status (vc-backend-merge-news file))) - (and buffer - (vc-resynch-buffer file t - (not (buffer-modified-p buffer)))) - (if (not (zerop status)) - (if (y-or-n-p "Conflicts detected. Resolve them now? ") - (vc-resolve-conflicts))))) - (error "%s needs update" (buffer-name)))) - - ;; For CVS files with implicit checkout: if unmodified, don't do anything - ((and (eq vc-type 'CVS) - (eq (vc-checkout-model file) 'implicit) - (not (vc-locking-user file)) - (not verbose)) - (message "%s is up to date" (buffer-name))) - - ;; If there is no lock on the file, assert one and get it. - ((not (setq owner (vc-locking-user file))) - ;; With implicit checkout, make sure not to lose unsaved changes. - (and (eq (vc-checkout-model file) 'implicit) - (buffer-modified-p buffer) - (vc-buffer-sync)) - (if (and vc-checkout-carefully - (not (vc-workfile-unchanged-p file t))) - (if (save-window-excursion - (pop-to-buffer "*vc-diff*") - (goto-char (point-min)) - (insert-string (format "Changes to %s since last lock:\n\n" - file)) - (not (beep)) - (yes-or-no-p - (concat "File has unlocked changes, " - "claim lock retaining changes? "))) - (progn (vc-backend-steal file) - (vc-mode-line file)) - (if (not (yes-or-no-p "Revert to checked-in version, instead? ")) - (error "Checkout aborted") - (vc-revert-buffer1 t t) - (vc-checkout-writable-buffer file)) - ) - (if verbose - (if (not (eq vc-type 'SCCS)) - (vc-checkout file nil - (read-string "Branch or version to move to: ")) - (error "Sorry, this is not implemented for SCCS")) - (if (vc-latest-on-branch-p file) - (vc-checkout-writable-buffer file) - (if (yes-or-no-p - "This is not the latest version. Really lock it? ") - (vc-checkout-writable-buffer file) - (if (yes-or-no-p "Lock the latest version instead? ") - (vc-checkout-writable-buffer file - (if (vc-trunk-p (vc-workfile-version file)) - "" ;; this means check out latest on trunk - (vc-branch-part (vc-workfile-version file))))))) - ))) - - ;; a checked-out version exists, but the user may not own the lock - ((and (not (eq vc-type 'CVS)) - (not (string-equal owner (vc-user-login-name)))) - (if comment - (error "Sorry, you can't steal the lock on %s this way" file)) - (and (eq vc-type 'RCS) - (not (vc-backend-release-p 'RCS "5.6.2")) - (error "File is locked by %s" owner)) - (vc-steal-lock - file - (if verbose (read-string "Version to steal: ") - (vc-workfile-version file)) - owner)) - - ;; OK, user owns the lock on the file - (t - (if vc-dired-mode - (find-file-other-window file) - (find-file file)) - - ;; If the file on disk is newer, then the user just - ;; said no to rereading it. So the user probably wishes to - ;; overwrite the file with the buffer's contents, and check - ;; that in. - (if (not (verify-visited-file-modtime (current-buffer))) - (if (yes-or-no-p "Replace file on disk with buffer contents? ") - (write-file (buffer-file-name)) - (error "Aborted")) - ;; if buffer is not saved, give user a chance to do it - (vc-buffer-sync)) - - ;; Revert if file is unchanged and buffer is too. - ;; If buffer is modified, that means the user just said no - ;; to saving it; in that case, don't revert, - ;; because the user might intend to save - ;; after finishing the log entry. - (if (and (vc-workfile-unchanged-p file) - (not (buffer-modified-p))) - ;; DO NOT revert the file without asking the user! - (cond - ((yes-or-no-p "Revert to master version? ") - (vc-backend-revert file) - (vc-resynch-window file t t))) - - ;; user may want to set nonstandard parameters - (if verbose - (setq version (read-string "New version level: "))) - - ;; OK, let's do the checkin - (vc-checkin file version comment) - ))))) + "Do The Right Thing for a given version-controlled FILE. +If COMMENT is specified, it will be used as an admin or checkin comment. +If VERBOSE is non-nil, query the user rather than using default parameters." + (let ((visited (get-file-buffer file)) + state version) + (when visited + ;; Check relation of buffer and file, and make sure + ;; user knows what he's doing. First, finding the file + ;; will check whether the file on disk is newer. + (if vc-dired-mode + (find-file-other-window file) + (find-file file)) + (if (not (verify-visited-file-modtime (current-buffer))) + (if (yes-or-no-p "Replace file on disk with buffer contents? ") + (write-file (buffer-file-name)) + (error "Aborted")) + ;; Now, check if we have unsaved changes. + (vc-buffer-sync t) + (if (buffer-modified-p) + (or (y-or-n-p "Operate on disk file, keeping modified buffer? ") + (error "Aborted"))))) + + ;; Do the right thing + (if (not (vc-registered file)) + (vc-register verbose comment) + (vc-recompute-state file) + (setq state (vc-state file)) + (cond + ;; up-to-date + ((or (eq state 'up-to-date) + (and verbose (eq state 'needs-patch))) + (cond + (verbose + ;; go to a different version + (setq version (read-string "Branch or version to move to: ")) + (vc-checkout file (eq (vc-checkout-model file) 'implicit) version)) + ((not (eq (vc-checkout-model file) 'implicit)) + ;; check the file out + (vc-checkout file t)) + (t + ;; do nothing + (message "%s is up-to-date" file)))) + + ;; Abnormal: edited but read-only + ((and visited (eq state 'edited) buffer-read-only) + ;; Make the file+buffer read-write. If the user really wanted to + ;; commit, he'll get a chance to do that next time around, anyway. + (message "File is edited but read-only; making it writable") + (set-file-modes buffer-file-name + (logior (file-modes buffer-file-name) 128)) + (toggle-read-only -1)) + + ;; edited + ((eq state 'edited) + (cond + ;; For files with locking, if the file does not contain + ;; any changes, just let go of the lock, i.e. revert. + ((and (not (eq (vc-checkout-model file) 'implicit)) + (vc-workfile-unchanged-p file) + ;; If buffer is modified, that means the user just + ;; said no to saving it; in that case, don't revert, + ;; because the user might intend to save after + ;; finishing the log entry. + (not (and visited (buffer-modified-p)))) + ;; DO NOT revert the file without asking the user! + (if (not visited) (find-file-other-window file)) + (if (yes-or-no-p "Revert to master version? ") + (vc-revert-buffer))) + (t ;; normal action + (if verbose (setq version (read-string "New version: "))) + (vc-checkin file version comment)))) + + ;; locked by somebody else + ((stringp state) + (if comment + (error "Sorry, you can't steal the lock on %s this way" + (file-name-nondirectory file))) + (vc-steal-lock file + (if verbose (read-string "Version to steal: ") + (vc-workfile-version file)) + state)) + + ;; needs-patch + ((eq state 'needs-patch) + (if (yes-or-no-p (format + "%s is not up-to-date. Get latest version? " + (file-name-nondirectory file))) + (vc-checkout file (eq (vc-checkout-model file) 'implicit) "") + (if (and (not (eq (vc-checkout-model file) 'implicit)) + (yes-or-no-p "Lock this version? ")) + (vc-checkout file t) + (error "Aborted")))) + + ;; needs-merge + ((eq state 'needs-merge) + (if (yes-or-no-p (format + "%s is not up-to-date. Merge in changes now? " + (file-name-nondirectory file))) + (vc-maybe-resolve-conflicts file (vc-call merge-news file)) + (error "Aborted"))) + + ;; unlocked-changes + ((eq state 'unlocked-changes) + (if (not visited) (find-file-other-window file)) + (if (save-window-excursion + (vc-version-diff file (vc-workfile-version file) nil) + (goto-char (point-min)) + (insert-string (format "Changes to %s since last lock:\n\n" + file)) + (not (beep)) + (yes-or-no-p (concat "File has unlocked changes. " + "Claim lock retaining changes? "))) + (progn (vc-call steal-lock file) + ;; Must clear any headers here because they wouldn't + ;; show that the file is locked now. + (vc-clear-headers file) + (vc-mode-line file)) + (if (not (yes-or-no-p + "Revert to checked-in version, instead? ")) + (error "Checkout aborted") + (vc-revert-buffer1 t t) + (vc-checkout file t)))))))) (defvar vc-dired-window-configuration) (defun vc-next-action-dired (file rev comment) - ;; Do a vc-next-action-on-file on all the marked files, possibly - ;; passing on the log comment we've just entered. + "Do a vc-next-action-on-file on all the marked files, possibly +passing on the log comment we've just entered." (let ((dired-buffer (current-buffer)) (dired-dir default-directory)) (dired-map-over-marks (let ((file (dired-get-filename))) (message "Processing %s..." file) - ;; Adjust the default directory so that checkouts - ;; go to the right place. - (let ((default-directory (file-name-directory file))) - (vc-next-action-on-file file nil comment) - (set-buffer dired-buffer)) - ;; Make sure that files don't vanish - ;; after they are checked in. - (let ((vc-dired-terse-mode nil)) - (dired-do-redisplay file)) + (vc-next-action-on-file file nil comment) + (set-buffer dired-buffer) (set-window-configuration vc-dired-window-configuration) (message "Processing %s...done" file)) nil t)) @@ -970,14 +943,17 @@ ;;;###autoload (defun vc-next-action (verbose) "Do the next logical checkin or checkout operation on the current file. - If you call this from within a VC dired buffer with no files marked, + +If you call this from within a VC dired buffer with no files marked, it will operate on the file in the current line. - If you call this from within a VC dired buffer, and one or more + +If you call this from within a VC dired buffer, and one or more files are marked, it will accept a log message and then operate on each one. The log message will be used as a comment for any register or checkin operations, but ignored when doing checkouts. Attempted lock steals will raise an error. - A prefix argument lets you specify the version number to use. + +A prefix argument lets you specify the version number to use. For RCS and SCCS files: If the file is not already registered, this registers it for version @@ -1012,14 +988,10 @@ (let ((files (dired-get-marked-files))) (set (make-local-variable 'vc-dired-window-configuration) (current-window-configuration)) - (if (string= "" + (if (string= "" (mapconcat - (function (lambda (f) - (if (eq (vc-backend f) 'CVS) - (if (or (eq (vc-cvs-status f) 'locally-modified) - (eq (vc-cvs-status f) 'locally-added)) - "@" "") - (if (vc-locking-user f) "@" "")))) + (lambda (f) + (if (not (vc-up-to-date-p f)) "@" "")) files "")) (vc-next-action-dired nil nil "dummy") (vc-start-entry nil nil nil @@ -1040,17 +1012,25 @@ ) ;;;###autoload -(defun vc-register (&optional override comment) - "Register the current file into your version-control system." +(defun vc-register (&optional set-version comment) + "Register the current file into a version-control system. +With prefix argument SET-VERSION, allow user to specify initial version +level. If COMMENT is present, use that as an initial comment. + +The version-control system to use is found by cycling through the list +`vc-handled-backends'. The first backend in that list which declares +itself responsible for the file (usually because other files in that +directory are already registered under that backend) will be used to +register the file. If no backend declares itself responsible, the +first backend that could register the file is used." (interactive "P") (or buffer-file-name (error "No visited file")) - (let ((master (vc-name buffer-file-name))) - (and master (file-exists-p master) - (error "This file is already registered")) - (and master - (not (y-or-n-p "Previous master file has vanished. Make a new one? ")) - (error "This file is already registered"))) + (when (vc-backend buffer-file-name) + (if (vc-registered buffer-file-name) + (error "This file is already registered") + (unless (y-or-n-p "Previous master file has vanished. Make a new one? ") + (error "Aborted")))) ;; Watch out for new buffers of size 0: the corresponding file ;; does not exist yet, even though buffer-modified-p is nil. (if (and (not (buffer-modified-p)) @@ -1058,32 +1038,66 @@ (not (file-exists-p buffer-file-name))) (set-buffer-modified-p t)) (vc-buffer-sync) - (cond ((not vc-make-backup-files) - ;; inhibit backup for this buffer - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t))) - (vc-admin - buffer-file-name - (or (and override - (read-string - (format "Initial version level for %s: " buffer-file-name))) - vc-default-init-version) - comment) - ;; Recompute backend property (it may have been set to nil before). - (setq vc-buffer-backend (vc-backend (buffer-file-name))) - ) + + (vc-start-entry buffer-file-name + (if set-version + (read-string "Initial version level for %s: " + (buffer-name)) + ;; TODO: Use backend-specific init version. + vc-default-init-version) + (or comment (not vc-initial-comment)) + "Enter initial comment." + (lambda (file rev comment) + (message "Registering %s... " file) + (let ((backend (vc-responsible-backend file))) + (vc-call-backend backend 'register file rev comment) + (vc-file-setprop file 'vc-backend backend) + (unless vc-make-backup-files + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t))) + (message "Registering %s... done" file)))) + +(defun vc-responsible-backend (file &optional register) + "Return the name of the backend system that is responsible for FILE. +If no backend in variable `vc-handled-backends' declares itself +responsible, the first backend in that list will be returned (if optional +arg REGISTER is non-nil, return the first backend that could register the +file). +FILE can also be a directory name (ending with a slash)." + (if (null vc-handled-backends) + (error "Cannot register, no backends in `vc-handled-backends'")) + (or (and (not (file-directory-p file)) (vc-backend file)) + (catch 'found + (mapcar (lambda (backend) + (if (vc-call-backend backend 'responsible-p file) + (throw 'found backend))) + vc-handled-backends) + (if register + (mapcar (lambda (backend) + (if (vc-call-backend backend 'could-register file) + (throw 'found backend))) + vc-handled-backends) + (car vc-handled-backends))))) + +(defun vc-default-could-register (backend file) + "Return non-nil if BACKEND could be used to register FILE. +The default implementation returns t for all files." + t) (defun vc-resynch-window (file &optional keep noquery) - ;; If the given file is in the current buffer, - ;; either revert on it so we see expanded keywords, - ;; or unvisit it (depending on vc-keep-workfiles) - ;; NOQUERY if non-nil inhibits confirmation for reverting. - ;; NOQUERY should be t *only* if it is known the only difference - ;; between the buffer and the file is due to RCS rather than user editing! + "If the given file is in the current buffer, either revert on it so +we see expanded keywords, or unvisit it (depending on +vc-keep-workfiles) NOQUERY if non-nil inhibits confirmation for +reverting. NOQUERY should be t *only* if it is known the only +difference between the buffer and the file is due to version control +rather than user editing!" (and (string= buffer-file-name file) (if keep (progn (vc-revert-buffer1 t noquery) + ;; TODO: Adjusting view mode might no longer be necessary + ;; after RMS change to files.el of 1999-08-08. Investigate + ;; this when we install the new VC. (and view-read-only (if (file-writable-p file) (and view-mode @@ -1096,26 +1110,25 @@ (kill-buffer (current-buffer))))) (defun vc-resynch-buffer (file &optional keep noquery) - ;; if FILE is currently visited, resynch its buffer + "If FILE is currently visited, resynch its buffer." (if (string= buffer-file-name file) (vc-resynch-window file keep noquery) (let ((buffer (get-file-buffer file))) (if buffer - (save-excursion - (set-buffer buffer) - (vc-resynch-window file keep noquery)))))) + (with-current-buffer buffer + (vc-resynch-window file keep noquery))))) + (vc-dired-resynch-file file)) (defun vc-start-entry (file rev comment msg action &optional after-hook) - ;; Accept a comment for an operation on FILE revision REV. If COMMENT - ;; is nil, pop up a VC-log buffer, emit MSG, and set the - ;; action on close to ACTION; otherwise, do action immediately. - ;; Remember the file's buffer in vc-parent-buffer (current one if no file). - ;; AFTER-HOOK specifies the local value for vc-log-operation-hook. + "Accept a comment for an operation on FILE revision REV. If COMMENT +is nil, pop up a VC-log buffer, emit MSG, and set the action on close +to ACTION; otherwise, do action immediately. Remember the file's +buffer in vc-parent-buffer (current one if no file). AFTER-HOOK +specifies the local value for vc-log-operation-hook." (let ((parent (if file (find-file-noselect file) (current-buffer)))) (if vc-before-checkin-hook (if file - (save-excursion - (set-buffer parent) + (with-current-buffer parent (run-hooks 'vc-before-checkin-hook)) (run-hooks 'vc-before-checkin-hook))) (if comment @@ -1125,7 +1138,7 @@ (set (make-local-variable 'vc-parent-buffer-name) (concat " from " (buffer-name vc-parent-buffer))) (if file (vc-mode-line file)) - (vc-log-mode file) + (if (fboundp 'log-edit) (vc-log-edit file) (vc-log-mode file)) (make-local-variable 'vc-log-after-operation-hook) (if after-hook (setq vc-log-after-operation-hook after-hook)) @@ -1138,44 +1151,41 @@ (vc-finish-logentry t) (insert comment) (vc-finish-logentry nil))) - (message "%s Type C-c C-c when done." msg)))) - -(defun vc-admin (file rev &optional comment) - "Check a file into your version-control system. -FILE is the unmodified name of the file. REV should be the base version -level to check it in under. COMMENT, if specified, is the checkin comment." - (vc-start-entry file rev - (or comment (not vc-initial-comment)) - "Enter initial comment." 'vc-backend-admin - nil)) + (message "%s Type C-c C-c when done" msg)))) (defun vc-checkout (file &optional writable rev) "Retrieve a copy of the latest version of the given file." - ;; If ftp is on this system and the name matches the ange-ftp format - ;; for a remote file, the user is trying something that won't work. - (if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp")) - (error "Sorry, you can't check out files over FTP")) - (vc-backend-checkout file writable rev) + (condition-case err + (vc-call checkout file writable rev) + (file-error + ;; Maybe the backend is not installed ;-( + (when writable + (let ((buf (get-file-buffer file))) + (when buf (with-current-buffer buf (toggle-read-only -1))))) + (signal (car err) (cdr err)))) + (vc-file-setprop file 'vc-state + (if (or (eq (vc-checkout-model file) 'implicit) + (not writable)) + (if (vc-call latest-on-branch-p file) + 'up-to-date + 'needs-patch) + 'edited)) + (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))) (vc-resynch-buffer file t t)) -(defun vc-steal-lock (file rev &optional owner) +(defun vc-steal-lock (file rev owner) "Steal the lock on the current workfile." (let (file-description) - (if (not owner) - (setq owner (vc-locking-user file))) (if rev (setq file-description (format "%s:%s" file rev)) (setq file-description file)) (if (not (yes-or-no-p (format "Steal the lock on %s from %s? " file-description owner))) - (error "Steal cancelled")) - (pop-to-buffer (get-buffer-create "*VC-mail*")) + (error "Steal canceled")) + (compose-mail owner (format "Stolen lock on %s" file-description) + nil nil nil nil + (list (list 'vc-finish-steal file rev))) (setq default-directory (expand-file-name "~/")) - (auto-save-mode auto-save-default) - (mail-mode) - (erase-buffer) - (mail-setup owner (format "Stolen lock on %s" file-description) nil nil nil - (list (list 'vc-finish-steal file rev))) (goto-char (point-max)) (insert (format "I stole the lock on %s, " file-description) @@ -1183,27 +1193,40 @@ ".\n") (message "Please explain why you stole the lock. Type C-c C-c when done."))) -;; This is called when the notification has been sent. (defun vc-finish-steal (file version) - (vc-backend-steal file version) - (if (get-file-buffer file) - (save-excursion - (set-buffer (get-file-buffer file)) - (vc-resynch-window file t t)))) + ;; This is called when the notification has been sent. + (message "Stealing lock on %s..." file) + (vc-call steal-lock file version) + (vc-file-setprop file 'vc-state 'edited) + (vc-resynch-buffer file t t) + (message "Stealing lock on %s...done" file)) (defun vc-checkin (file &optional rev comment) - "Check in the file specified by FILE. -The optional argument REV may be a string specifying the new version level -\(if nil increment the current level). The file is either retained with write -permissions zeroed, or deleted (according to the value of `vc-keep-workfiles'). -If the back-end is CVS, a writable workfile is always kept. -COMMENT is a comment string; if omitted, a buffer is popped up to accept a -comment. + "Check in FILE. +The optional argument REV may be a string specifying the new version +level (if nil increment the current level). COMMENT is a comment +string; if omitted, a buffer is popped up to accept a comment. + +If `vc-keep-workfiles' is nil, FILE is deleted afterwards, provided +that the version control system supports this mode of operation. Runs the normal hook `vc-checkin-hook'." - (vc-start-entry file rev comment - "Enter a change comment." 'vc-backend-checkin - 'vc-checkin-hook)) + (vc-start-entry + file rev comment + "Enter a change comment." + (lambda (file rev comment) + (message "Checking in %s..." file) + ;; "This log message intentionally left almost blank". + ;; RCS 5.7 gripes about white-space-only comments too. + (or (and comment (string-match "[^\t\n ]" comment)) + (setq comment "*** empty log message ***")) + ;; Change buffers to get local value of vc-checkin-switches. + (with-current-buffer (or (get-file-buffer file) (current-buffer)) + (vc-call checkin file rev comment)) + (vc-file-setprop file 'vc-state 'up-to-date) + (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))) + (message "Checking in %s...done" file)) + 'vc-checkin-hook)) (defun vc-comment-to-change-log (&optional whoami file-name) "Enter last VC comment into change log file for current buffer's file. @@ -1256,19 +1279,22 @@ "Complete the operation implied by the current log entry." (interactive) ;; Check and record the comment, if any. - (if (not nocomment) - (progn - ;; Comment too long? - (vc-backend-logentry-check vc-log-file) - ;; Record the comment in the comment ring - (ring-insert vc-comment-ring (buffer-string)) - )) + (unless nocomment + ;; Comment too long? + (vc-call-backend (or (and vc-log-file (vc-backend vc-log-file)) + (vc-responsible-backend default-directory)) + 'logentry-check) + (run-hooks 'vc-logentry-check-hook) + ;; Record the comment in the comment ring + (let ((comment (buffer-string))) + (unless (and (ring-p vc-comment-ring) + (not (ring-empty-p vc-comment-ring)) + (equal comment (ring-ref vc-comment-ring 0))) + (ring-insert vc-comment-ring comment)))) ;; Sync parent buffer in case the user modified it while editing the comment. ;; But not if it is a vc-dired buffer. - (save-excursion - (set-buffer vc-parent-buffer) - (or vc-dired-mode - (vc-buffer-sync))) + (with-current-buffer vc-parent-buffer + (or vc-dired-mode (vc-buffer-sync))) (if (not vc-log-operation) (error "No log operation is pending")) ;; save the parameters held in buffer-local variables (let ((log-operation vc-log-operation) @@ -1280,7 +1306,7 @@ (pop-to-buffer vc-parent-buffer) ;; OK, do it to it (save-excursion - (funcall log-operation + (funcall log-operation log-file log-version log-entry)) @@ -1296,79 +1322,69 @@ (pop-to-buffer tmp-vc-parent-buffer)))) ;; Now make sure we see the expanded headers (if buffer-file-name - (vc-resynch-window buffer-file-name vc-keep-workfiles t)) - (if vc-dired-mode + (vc-resynch-buffer buffer-file-name vc-keep-workfiles t)) + (if vc-dired-mode (dired-move-to-filename)) (run-hooks after-hook 'vc-finish-logentry-hook))) ;; Code for access to the comment ring +(defun vc-new-comment-index (stride len) + (mod (cond + (vc-comment-ring-index (+ vc-comment-ring-index stride)) + ;; Initialize the index on the first use of this command + ;; so that the first M-p gets index 0, and the first M-n gets + ;; index -1. + ((> stride 0) (1- stride)) + (t stride)) + len)) + (defun vc-previous-comment (arg) "Cycle backwards through comment history." (interactive "*p") (let ((len (ring-length vc-comment-ring))) - (cond ((<= len 0) - (message "Empty comment ring") - (ding)) - (t - (erase-buffer) - ;; Initialize the index on the first use of this command - ;; so that the first M-p gets index 0, and the first M-n gets - ;; index -1. - (if (null vc-comment-ring-index) - (setq vc-comment-ring-index - (if (> arg 0) -1 - (if (< arg 0) 1 0)))) - (setq vc-comment-ring-index - (mod (+ vc-comment-ring-index arg) len)) - (message "%d" (1+ vc-comment-ring-index)) - (insert (ring-ref vc-comment-ring vc-comment-ring-index)))))) + (if (<= len 0) + (progn (message "Empty comment ring") (ding)) + (erase-buffer) + (setq vc-comment-ring-index (vc-new-comment-index arg len)) + (message "Comment %d" (1+ vc-comment-ring-index)) + (insert (ring-ref vc-comment-ring vc-comment-ring-index))))) (defun vc-next-comment (arg) "Cycle forwards through comment history." (interactive "*p") (vc-previous-comment (- arg))) -(defun vc-comment-search-reverse (str) +(defun vc-comment-search-reverse (str &optional stride) "Searches backwards through comment history for substring match." - (interactive "sComment substring: ") + ;; Why substring rather than regexp ? -sm + (interactive + (list (read-string "Comment substring: " nil nil vc-last-comment-match))) + (unless stride (setq stride 1)) (if (string= str "") (setq str vc-last-comment-match) (setq vc-last-comment-match str)) - (if (null vc-comment-ring-index) - (setq vc-comment-ring-index -1)) - (let ((str (regexp-quote str)) - (len (ring-length vc-comment-ring)) - (n (1+ vc-comment-ring-index))) - (while (and (< n len) (not (string-match str (ring-ref vc-comment-ring n)))) - (setq n (+ n 1))) - (cond ((< n len) - (vc-previous-comment (- n vc-comment-ring-index))) - (t (error "Not found"))))) + (let* ((str (regexp-quote str)) + (len (ring-length vc-comment-ring)) + (n (vc-new-comment-index stride len))) + (while (progn (when (or (>= n len) (< n 0)) (error "Not found")) + (not (string-match str (ring-ref vc-comment-ring n)))) + (setq n (+ n stride))) + (setq vc-comment-ring-index n) + (vc-previous-comment 0))) (defun vc-comment-search-forward (str) "Searches forwards through comment history for substring match." - (interactive "sComment substring: ") - (if (string= str "") - (setq str vc-last-comment-match) - (setq vc-last-comment-match str)) - (if (null vc-comment-ring-index) - (setq vc-comment-ring-index 0)) - (let ((str (regexp-quote str)) - (len (ring-length vc-comment-ring)) - (n vc-comment-ring-index)) - (while (and (>= n 0) (not (string-match str (ring-ref vc-comment-ring n)))) - (setq n (- n 1))) - (cond ((>= n 0) - (vc-next-comment (- n vc-comment-ring-index))) - (t (error "Not found"))))) + (interactive + (list (read-string "Comment substring: " nil nil vc-last-comment-match))) + (vc-comment-search-reverse str -1)) ;; Additional entry points for examining version histories ;;;###autoload (defun vc-diff (historic &optional not-urgent) "Display diffs between file versions. -Normally this compares the current file and buffer with the most recent +Normally this compares the current file and buffer with the most recent checked in version of that file. This uses no arguments. With a prefix argument, it reads the file name to use and two version designators specifying which versions to compare." @@ -1376,36 +1392,17 @@ (vc-ensure-vc-buffer) (if historic (call-interactively 'vc-version-diff) - (let ((file buffer-file-name) - unchanged) + (let ((file buffer-file-name)) (vc-buffer-sync not-urgent) - (setq unchanged (vc-workfile-unchanged-p buffer-file-name)) - (if unchanged - (message "No changes to %s since latest version" file) - (vc-backend-diff file) - ;; Ideally, we'd like at this point to parse the diff so that - ;; the buffer effectively goes into compilation mode and we - ;; can visit the old and new change locations via next-error. - ;; Unfortunately, this is just too painful to do. The basic - ;; problem is that the `old' file doesn't exist to be - ;; visited. This plays hell with numerous assumptions in - ;; the diff.el and compile.el machinery. - (set-buffer "*vc-diff*") - (setq default-directory (file-name-directory file)) - (if (= 0 (buffer-size)) - (progn - (setq unchanged t) - (message "No changes to %s since latest version" file)) - (pop-to-buffer "*vc-diff*") - (goto-char (point-min)) - (shrink-window-if-larger-than-buffer))) - (not unchanged)))) + (if (vc-workfile-unchanged-p buffer-file-name) + (message "No changes to %s since latest version" file) + (vc-version-diff file nil nil))))) (defun vc-version-diff (file rel1 rel2) "For FILE, report diffs between two stored versions REL1 and REL2 of it. If FILE is a directory, generate diffs between versions for all registered files in or below it." - (interactive + (interactive (let ((file (expand-file-name (read-file-name (if buffer-file-name "File or dir to diff: (default visited file) " @@ -1414,18 +1411,19 @@ (rel1-default nil) (rel2-default nil)) ;; compute default versions based on the file state (cond - ;; if it's a directory, don't supply any version defauolt - ((file-directory-p file) + ;; if it's a directory, don't supply any version default + ((file-directory-p file) nil) - ;; if the file is locked, use current version as older version - ((vc-locking-user file) + ;; if the file is not up-to-date, use current version as older version + ((not (vc-up-to-date-p file)) (setq rel1-default (vc-workfile-version file))) ;; if the file is not locked, use last and previous version as default (t (setq rel1-default (vc-previous-version (vc-workfile-version file))) + (if (string= rel1-default "") (setq rel1-default nil)) (setq rel2-default (vc-workfile-version file)))) ;; construct argument list - (list file + (list file (read-string (if rel1-default (concat "Older version: (default " rel1-default ") ") @@ -1438,52 +1436,58 @@ nil nil rel2-default)))) (if (string-equal rel1 "") (setq rel1 nil)) (if (string-equal rel2 "") (setq rel2 nil)) + (vc-setup-buffer "*vc-diff*") (if (file-directory-p file) - (let ((camefrom (current-buffer))) - (set-buffer (get-buffer-create "*vc-status*")) - (set (make-local-variable 'vc-parent-buffer) camefrom) - (set (make-local-variable 'vc-parent-buffer-name) - (concat " from " (buffer-name camefrom))) - (erase-buffer) + (let ((inhibit-read-only t)) (insert "Diffs between " (or rel1 "last version checked in") " and " (or rel2 "current workfile(s)") ":\n\n") - (set-buffer (get-buffer-create "*vc-diff*")) - (cd file) + (setq default-directory (file-name-as-directory file)) + ;; FIXME: this should do a single exec in CVS. (vc-file-tree-walk default-directory - (function (lambda (f) - (message "Looking at %s" f) - (and - (not (file-directory-p f)) - (vc-registered f) - (vc-backend-diff f rel1 rel2) - (append-to-buffer "*vc-status*" (point-min) (point-max))) - ))) - (pop-to-buffer "*vc-status*") - (insert "\nEnd of diffs.\n") - (goto-char (point-min)) - (set-buffer-modified-p nil) - ) - (if (zerop (vc-backend-diff file rel1 rel2)) - (message "No changes to %s between %s and %s." file rel1 rel2) - (pop-to-buffer "*vc-diff*")))) + (lambda (f) + (vc-exec-after + `(progn + (message "Looking at %s" ',f) + (vc-call-backend ',(vc-backend file) 'diff ',f ',rel1 ',rel2))))) + (vc-exec-after `(let ((inhibit-read-only t)) + (insert "\nEnd of diffs.\n")))) + + (cd (file-name-directory file)) + (vc-call diff file rel1 rel2)) + (if (and (zerop (buffer-size)) + (not (get-buffer-process (current-buffer)))) + (progn + (if rel1 + (if rel2 + (message "No changes to %s between %s and %s" file rel1 rel2) + (message "No changes to %s since %s" file rel1)) + (message "No changes to %s since latest version" file)) + nil) + (pop-to-buffer (current-buffer)) + ;; Gnus-5.8.5 sets up an autoload for diff-mode, even if it's + ;; not available. Work around that. + (if (require 'diff-mode nil t) (diff-mode)) + (vc-exec-after '(progn (goto-char (point-min)) + (shrink-window-if-larger-than-buffer))) + t)) ;;;###autoload (defun vc-version-other-window (rev) "Visit version REV of the current buffer in another window. If the current buffer is named `F', the version is named `F.~REV~'. If `F.~REV~' already exists, it is used instead of being re-created." - (interactive "sVersion to visit (default is latest version): ") + (interactive "sVersion to visit (default is workfile version): ") (vc-ensure-vc-buffer) (let* ((version (if (string-equal rev "") - (vc-latest-version buffer-file-name) + (vc-workfile-version buffer-file-name) rev)) (filename (concat buffer-file-name ".~" version "~"))) (or (file-exists-p filename) - (vc-backend-checkout buffer-file-name nil version filename)) + (vc-call checkout buffer-file-name nil version filename)) (find-file-other-window filename))) ;; Header-insertion code @@ -1492,7 +1496,7 @@ (defun vc-insert-headers () "Insert headers in a file for use with your version-control system. Headers desired are inserted at point, and are pulled from -the variable `vc-header-alist'." +the variable `vc-BACKEND-header'." (interactive) (vc-ensure-vc-buffer) (save-excursion @@ -1504,83 +1508,99 @@ (let* ((delims (cdr (assq major-mode vc-comment-alist))) (comment-start-vc (or (car delims) comment-start "#")) (comment-end-vc (or (car (cdr delims)) comment-end "")) - (hdstrings (cdr (assoc (vc-backend (buffer-file-name)) vc-header-alist)))) - (mapcar (function (lambda (s) - (insert comment-start-vc "\t" s "\t" - comment-end-vc "\n"))) + (hdsym (vc-make-backend-sym (vc-backend (buffer-file-name)) + 'header)) + (hdstrings (and (boundp hdsym) (symbol-value hdsym)))) + (mapcar (lambda (s) + (insert comment-start-vc "\t" s "\t" + comment-end-vc "\n")) hdstrings) (if vc-static-header-alist - (mapcar (function (lambda (f) - (if (string-match (car f) buffer-file-name) - (insert (format (cdr f) (car hdstrings)))))) + (mapcar (lambda (f) + (if (string-match (car f) buffer-file-name) + (insert (format (cdr f) (car hdstrings))))) vc-static-header-alist)) ) ))))) -(defun vc-clear-headers () - ;; Clear all version headers in the current buffer, i.e. reset them - ;; to the nonexpanded form. Only implemented for RCS, yet. - ;; Don't lose point and mark during this. - (let ((context (vc-buffer-context)) - (case-fold-search nil)) - ;; save-excursion may be able to relocate point and mark properly. - ;; If it fails, vc-restore-buffer-context will give it a second try. - (save-excursion - (goto-char (point-min)) - (while (re-search-forward - (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|" - "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$") - nil t) - (replace-match "$\\1$"))) - (vc-restore-buffer-context context))) +(defun vc-clear-headers (&optional file) + "Clear all version headers in the current buffer (or FILE), i.e. reset them +to the non-expanded form." + (let* ((filename (or file buffer-file-name)) + (visited (find-buffer-visiting filename)) + (backend (vc-backend filename))) + (when (vc-find-backend-function backend 'clear-headers) + (if visited + (let ((context (vc-buffer-context))) + ;; save-excursion may be able to relocate point and mark + ;; properly. If it fails, vc-restore-buffer-context + ;; will give it a second try. + (save-excursion + (vc-call-backend backend 'clear-headers)) + (vc-restore-buffer-context context)) + (find-file filename) + (vc-call-backend backend 'clear-headers) + (kill-buffer filename))))) ;;;###autoload -(defun vc-merge () - (interactive) +(defun vc-merge (&optional merge-news) + "Merge changes between two revisions into the work file. +With prefix arg, merge news, i.e. recent changes from the current branch. + +See Info node `Merging'." + (interactive "P") (vc-ensure-vc-buffer) (vc-buffer-sync) (let* ((file buffer-file-name) (backend (vc-backend file)) - first-version second-version locking-user) - (if (eq backend 'SCCS) - (error "Sorry, merging is not implemented for SCCS") - (setq locking-user (vc-locking-user file)) - (if (eq (vc-checkout-model file) 'manual) - (if (not locking-user) - (if (not (y-or-n-p - (format "File must be %s for merging. %s now? " - (if (eq backend 'RCS) "locked" "writable") - (if (eq backend 'RCS) "Lock" "Check out")))) - (error "Merge aborted") - (vc-checkout file t)) - (if (not (string= locking-user (vc-user-login-name))) - (error "File is locked by %s" locking-user)))) + (state (vc-state file)) + first-version second-version) + (cond + ((not (vc-find-backend-function backend + (if merge-news 'merge-news 'merge))) + (error "Sorry, merging is not implemented for %s" backend)) + ((stringp state) + (error "File is locked by %s" state)) + ((not (vc-editable-p file)) + (if (y-or-n-p + "File must be checked out for merging. Check out now? ") + (vc-checkout file t) + (error "Merge aborted")))) + (unless merge-news (setq first-version (read-string "Branch or version to merge from: ")) (if (and (>= (elt first-version 0) ?0) - (<= (elt first-version 0) ?9)) - (if (not (vc-branch-p first-version)) - (setq second-version - (read-string "Second version: " - (concat (vc-branch-part first-version) "."))) - ;; We want to merge an entire branch. Set versions - ;; accordingly, so that vc-backend-merge understands us. - (setq second-version first-version) - ;; first-version must be the starting point of the branch - (setq first-version (vc-branch-part first-version)))) - (let ((status (vc-backend-merge file first-version second-version))) - (if (and (eq (vc-checkout-model file) 'implicit) - (not (vc-locking-user file))) - (vc-file-setprop file 'vc-locking-user nil)) - (vc-resynch-buffer file t t) - (if (not (zerop status)) - (if (y-or-n-p "Conflicts detected. Resolve them now? ") - (vc-resolve-conflicts "WORKFILE" "MERGE SOURCE") - (message "File contains conflict markers")) - (message "Merge successful")))))) + (<= (elt first-version 0) ?9)) + (if (not (vc-branch-p first-version)) + (setq second-version + (read-string "Second version: " + (concat (vc-branch-part first-version) "."))) + ;; We want to merge an entire branch. Set versions + ;; accordingly, so that vc-backend-merge understands us. + (setq second-version first-version) + ;; first-version must be the starting point of the branch + (setq first-version (vc-branch-part first-version))))) + (let ((status (if merge-news + (vc-call merge-news file) + (vc-call merge file first-version second-version)))) + (vc-maybe-resolve-conflicts file status "WORKFILE" "MERGE SOURCE")))) + +(defun vc-maybe-resolve-conflicts (file status &optional name-A name-B) + (vc-resynch-buffer file t (not (buffer-modified-p))) + (if (zerop status) (message "Merge successful") + (if (fboundp 'smerge-mode) (smerge-mode 1)) + (if (y-or-n-p "Conflicts detected. Resolve them now? ") + (if (fboundp 'smerge-ediff) + (smerge-ediff) + (vc-resolve-conflicts name-A name-B)) + (message "File contains conflict markers")))) (defvar vc-ediff-windows) (defvar vc-ediff-result) - +(eval-when-compile + (defvar ediff-buffer-A) + (defvar ediff-buffer-B) + (defvar ediff-buffer-C) + (require 'ediff-util)) ;;;###autoload (defun vc-resolve-conflicts (&optional name-A name-B) "Invoke ediff to resolve conflicts in the current buffer. @@ -1589,19 +1609,19 @@ (vc-ensure-vc-buffer) (let* ((found nil) (file-name (file-name-nondirectory buffer-file-name)) - (your-buffer (generate-new-buffer - (concat "*" file-name + (your-buffer (generate-new-buffer + (concat "*" file-name " " (or name-A "WORKFILE") "*"))) - (other-buffer (generate-new-buffer - (concat "*" file-name + (other-buffer (generate-new-buffer + (concat "*" file-name " " (or name-B "CHECKED-IN") "*"))) (result-buffer (current-buffer))) - (save-excursion + (save-excursion (set-buffer your-buffer) (erase-buffer) (insert-buffer result-buffer) (goto-char (point-min)) - (while (re-search-forward (concat "^<<<<<<< " + (while (re-search-forward (concat "^<<<<<<< " (regexp-quote file-name) "\n") nil t) (setq found t) (replace-match "") @@ -1621,7 +1641,7 @@ (erase-buffer) (insert-buffer result-buffer) (goto-char (point-min)) - (while (re-search-forward (concat "^<<<<<<< " + (while (re-search-forward (concat "^<<<<<<< " (regexp-quote file-name) "\n") nil t) (let ((start (match-beginning 0))) (if (not (re-search-forward "^=======\n" nil t)) @@ -1643,25 +1663,24 @@ (make-local-variable 'vc-ediff-windows) (setq vc-ediff-windows config) (make-local-variable 'vc-ediff-result) - (setq vc-ediff-result result-buffer) + (setq vc-ediff-result result-buffer) (make-local-variable 'ediff-quit-hook) (setq ediff-quit-hook - (function - (lambda () - (let ((buffer-A ediff-buffer-A) - (buffer-B ediff-buffer-B) - (buffer-C ediff-buffer-C) - (result vc-ediff-result) - (windows vc-ediff-windows)) - (ediff-cleanup-mess) - (set-buffer result) - (erase-buffer) - (insert-buffer buffer-C) - (kill-buffer buffer-A) - (kill-buffer buffer-B) - (kill-buffer buffer-C) - (set-window-configuration windows) - (message "Conflict resolution finished; you may save the buffer"))))) + (lambda () + (let ((buffer-A ediff-buffer-A) + (buffer-B ediff-buffer-B) + (buffer-C ediff-buffer-C) + (result vc-ediff-result) + (windows vc-ediff-windows)) + (ediff-cleanup-mess) + (set-buffer result) + (erase-buffer) + (insert-buffer buffer-C) + (kill-buffer buffer-A) + (kill-buffer buffer-B) + (kill-buffer buffer-C) + (set-window-configuration windows) + (message "Conflict resolution finished; you may save the buffer")))) (message "Please resolve conflicts now; exit ediff when done") nil)))) @@ -1671,14 +1690,27 @@ (defvar vc-dired-switches) (defvar vc-dired-terse-mode) +(defvar vc-dired-mode-map + (let ((map (make-sparse-keymap)) + (vmap (make-sparse-keymap))) + (set-keymap-parent map dired-mode-map) + (define-key map "\C-xv" vc-prefix-map) + (define-key map "v" vmap) + (set-keymap-parent vmap vc-prefix-map) + (define-key vmap "t" 'vc-dired-toggle-terse-mode) + map)) + (define-derived-mode vc-dired-mode dired-mode "Dired under VC" - "The major mode used in VC directory buffers. It works like Dired, -but lists only files under version control, with the current VC state of -each file being indicated in the place of the file's link count, owner, -group and size. Subdirectories are also listed, and you may insert them -into the buffer as desired, like in Dired. - All Dired commands operate normally, with the exception of `v', which -is redefined as the version control prefix, so that you can type + "The major mode used in VC directory buffers. + +It works like Dired, but lists only files under version control, with +the current VC state of each file being indicated in the place of the +file's link count, owner, group and size. Subdirectories are also +listed, and you may insert them into the buffer as desired, like in +Dired. + +All Dired commands operate normally, with the exception of `v', which +is redefined as the version control prefix, so that you can type `vl', `v=' etc. to invoke `vc-print-log', `vc-diff', and the like on the file named in the current Dired buffer line. `vv' invokes `vc-next-action' on this file, or on all files currently marked. @@ -1688,12 +1720,12 @@ ;; The following is slightly modified from dired.el, ;; because file lines look a bit different in vc-dired-mode. (set (make-local-variable 'dired-move-to-filename-regexp) - (let* + (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)") ;; In some locales, month abbreviations are as short as 2 letters, ;; and they can be padded on the right with spaces. (month (concat l l "+ *")) - ;; Recognize any non-ASCII character. + ;; Recognize any non-ASCII character. ;; The purpose is to match a Kanji character. (k "[^\0-\177]") ;; (k "[^\x00-\x7f\x80-\xff]") @@ -1705,7 +1737,8 @@ (western (concat "\\(" month s dd "\\|" dd s month "\\)" s "\\(" HH:MM "\\|" s yyyy"\\|" yyyy s "\\)")) (japanese (concat mm k s dd k s "\\(" s HH:MM "\\|" yyyy k "\\)"))) - (concat s "\\(" western "\\|" japanese "\\)" s))) + ;; the .* below ensures that we find the last match on a line + (concat ".*" s "\\(" western "\\|" japanese "\\)" s))) (and (boundp 'vc-dired-switches) vc-dired-switches (set (make-local-variable 'dired-actual-switches) @@ -1713,9 +1746,6 @@ (set (make-local-variable 'vc-dired-terse-mode) vc-dired-terse-display) (setq vc-dired-mode t)) -(define-key vc-dired-mode-map "\C-xv" vc-prefix-map) -(define-key vc-dired-mode-map "v" vc-prefix-map) - (defun vc-dired-toggle-terse-mode () "Toggle terse display in VC Dired." (interactive) @@ -1726,53 +1756,30 @@ (vc-dired-hook) (revert-buffer)))) -(define-key vc-dired-mode-map "vt" 'vc-dired-toggle-terse-mode) - (defun vc-dired-mark-locked () "Mark all files currently locked." (interactive) (dired-mark-if (let ((f (dired-get-filename nil t))) (and f (not (file-directory-p f)) - (vc-locking-user f))) + (not (vc-up-to-date-p f)))) "locked file")) (define-key vc-dired-mode-map "*l" 'vc-dired-mark-locked) -(defun vc-fetch-cvs-status (dir) - (let ((default-directory dir)) - ;; Don't specify DIR in this command, the default-directory is - ;; enough. Otherwise it might fail with remote repositories. - (vc-do-command "*vc-info*" 0 "cvs" nil nil "status" "-l") - (save-excursion - (set-buffer (get-buffer "*vc-info*")) - (goto-char (point-min)) - (while (re-search-forward "^=+\n\\([^=\n].*\n\\|\n\\)+" nil t) - (narrow-to-region (match-beginning 0) (match-end 0)) - (vc-parse-cvs-status) - (goto-char (point-max)) - (widen))))) - -(defun vc-dired-state-info (file) - ;; Return the string that indicates the version control status - ;; on a VC dired line. - (let* ((cvs-state (and (eq (vc-backend file) 'CVS) - (vc-cvs-status file))) - (state - (if cvs-state - (cond ((eq cvs-state 'up-to-date) nil) - ((eq cvs-state 'needs-checkout) "patch") - ((eq cvs-state 'locally-modified) "modified") - ((eq cvs-state 'needs-merge) "merge") - ((eq cvs-state 'unresolved-conflict) "conflict") - ((eq cvs-state 'locally-added) "added")) - (vc-locking-user file)))) - (if state (concat "(" state ")")))) +(defun vc-default-dired-state-info (backend file) + (let ((state (vc-state file))) + (cond + ((stringp state) (concat "(" state ")")) + ((eq state 'edited) (concat "(" (vc-user-login-name) ")")) + ((eq state 'needs-merge) "(merge)") + ((eq state 'needs-patch) "(patch)") + ((eq state 'unlocked-changes) "(stale)")))) (defun vc-dired-reformat-line (x) - ;; Reformat a directory-listing line, replacing various columns with - ;; version control information. - ;; This code, like dired, assumes UNIX -l format. + "Reformat a directory-listing line. +Replace various columns with version control information. +This code, like dired, assumes UNIX -l format." (beginning-of-line) (let ((pos (point)) limit perm date-and-file) (end-of-line) @@ -1782,9 +1789,9 @@ (or (re-search-forward ;; owner and group "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[^ ]+ +[0-9]+\\( .*\\)" - limit t) + limit t) (re-search-forward ;; only owner displayed - "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[0-9]+\\( .*\\)" + "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[0-9]+\\( .*\\)" limit t) (re-search-forward ;; OS/2 -l format, no links, owner, group "^\\(..[drwxlts-]+ \\) *[0-9]+\\( .*\\)" @@ -1795,34 +1802,32 @@ (replace-match (concat perm x date-and-file))))) (defun vc-dired-hook () - ;; Called by dired after any portion of a vc-dired buffer has been read in. - ;; Reformat the listing according to version control. + "Reformat the listing according to version control. +Called by dired after any portion of a vc-dired buffer has been read in." (message "Getting version information... ") (let (subdir filename (buffer-read-only nil) cvs-dir) (goto-char (point-min)) - (while (not (eq (point) (point-max))) - (cond + (while (not (eobp)) + (cond ;; subdir header line ((setq subdir (dired-get-subdir)) - (if (file-directory-p (concat subdir "/CVS")) - (progn - (vc-fetch-cvs-status (file-name-as-directory subdir)) - (setq cvs-dir t)) - (setq cvs-dir nil)) + ;; if the backend supports it, get the state + ;; of all files in this directory at once + (let ((backend (vc-responsible-backend subdir))) + (if (vc-find-backend-function backend 'dir-state) + (vc-call-backend backend 'dir-state subdir))) (forward-line 1) ;; erase (but don't remove) the "total" line - (let ((start (point))) - (end-of-line) - (delete-region start (point)) - (beginning-of-line) - (forward-line 1))) - ;; directory entry + (delete-region (point) (line-end-position)) + (beginning-of-line) + (forward-line 1)) + ;; file line ((setq filename (dired-get-filename nil t)) (cond ;; subdir ((file-directory-p filename) - (cond - ((member (file-name-nondirectory filename) + (cond + ((member (file-name-nondirectory filename) vc-directory-exclusion-list) (let ((pos (point))) (dired-kill-tree filename) @@ -1832,7 +1837,7 @@ ;; Don't show directories in terse mode. Don't use ;; dired-kill-line to remove it, because in recursive listings, ;; that would remove the directory contents as well. - (delete-region (progn (beginning-of-line) (point)) + (delete-region (line-beginning-position) (progn (forward-line 1) (point)))) ((string-match "\\`\\.\\.?\\'" (file-name-nondirectory filename)) (dired-kill-line)) @@ -1840,16 +1845,12 @@ (vc-dired-reformat-line nil) (forward-line 1)))) ;; ordinary file - ((if cvs-dir - (and (eq (vc-file-getprop filename 'vc-backend) 'CVS) - (or (not vc-dired-terse-mode) - (not (eq (vc-cvs-status filename) 'up-to-date)))) - (and (vc-backend filename) - (or (not vc-dired-terse-mode) - (vc-locking-user filename)))) - (vc-dired-reformat-line (vc-dired-state-info filename)) + ((and (vc-backend filename) + (not (and vc-dired-terse-mode + (vc-up-to-date-p filename)))) + (vc-dired-reformat-line (vc-call dired-state-info filename)) (forward-line 1)) - (t + (t (dired-kill-line)))) ;; any other line (t (forward-line 1)))) @@ -1862,7 +1863,7 @@ (message "No files locked under %s" default-directory))))) (defun vc-dired-purge () - ;; Remove empty subdirs + "Remove empty subdirs." (let (subdir) (goto-char (point-min)) (while (setq subdir (dired-get-subdir)) @@ -1881,139 +1882,136 @@ (goto-char (point-max)))))) (goto-char (point-min)))) +(defun vc-dired-buffers-for-dir (dir) + "Return a list of all vc-dired buffers that currently display DIR." + (let (result) + (mapcar (lambda (buffer) + (with-current-buffer buffer + (if vc-dired-mode + (setq result (append result (list buffer)))))) + (dired-buffers-for-dir dir)) + result)) + +(defun vc-dired-resynch-file (file) + "Update the entries for FILE in any VC Dired buffers that list it." + (let ((buffers (vc-dired-buffers-for-dir (file-name-directory file)))) + (when buffers + (mapcar (lambda (buffer) + (with-current-buffer buffer + (if (dired-goto-file file) + ;; bind vc-dired-terse-mode to nil so that + ;; files won't vanish when they are checked in + (let ((vc-dired-terse-mode nil)) + (dired-do-redisplay 1))))) + buffers)))) + ;;;###autoload -(defun vc-directory (dirname read-switches) +(defun vc-directory (dir read-switches) + "Create a buffer in VC Dired Mode for directory DIR. + +See Info node `VC Dired Mode'. + +With prefix arg READ-SWITCHES, specify a value to override +`dired-listing-switches' when generating the listing." (interactive "DDired under VC (directory): \nP") - (let ((vc-dired-switches (concat dired-listing-switches + (let ((vc-dired-switches (concat vc-dired-listing-switches (if vc-dired-recurse "R" "")))) - (if read-switches + (if read-switches (setq vc-dired-switches (read-string "Dired listing switches: " vc-dired-switches))) (require 'dired) (require 'dired-aux) - ;; force a trailing slash - (if (not (eq (elt dirname (1- (length dirname))) ?/)) - (setq dirname (concat dirname "/"))) - (switch-to-buffer - (dired-internal-noselect (expand-file-name dirname) - (or vc-dired-switches dired-listing-switches) + (switch-to-buffer + (dired-internal-noselect (expand-file-name (file-name-as-directory dir)) + vc-dired-switches 'vc-dired-mode)))) -;; Named-configuration support for SCCS - -(defun vc-add-triple (name file rev) - (save-excursion - (find-file (expand-file-name - vc-name-assoc-file - (file-name-directory (vc-name file)))) - (goto-char (point-max)) - (insert name "\t:\t" file "\t" rev "\n") - (basic-save-buffer) - (kill-buffer (current-buffer)) - )) - -(defun vc-record-rename (file newname) - (save-excursion - (find-file - (expand-file-name - vc-name-assoc-file - (file-name-directory (vc-name file)))) - (goto-char (point-min)) - ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname)) - (while (re-search-forward (concat ":" (regexp-quote file) "$") nil t) - (replace-match (concat ":" newname) nil nil)) - (basic-save-buffer) - (kill-buffer (current-buffer)) - )) - -(defun vc-lookup-triple (file name) - ;; Return the numeric version corresponding to a named snapshot of file - ;; If name is nil or a version number string it's just passed through - (cond ((null name) name) - ((let ((firstchar (aref name 0))) - (and (>= firstchar ?0) (<= firstchar ?9))) - name) - (t - (save-excursion - (set-buffer (get-buffer-create "*vc-info*")) - (vc-insert-file - (expand-file-name - vc-name-assoc-file - (file-name-directory (vc-name file)))) - (prog1 - (car (vc-parse-buffer - (list (list (concat name "\t:\t" file "\t\\(.+\\)") 1)))) - (kill-buffer "*vc-info*")))) - )) ;; Named-configuration entry points -(defun vc-snapshot-precondition () - ;; Scan the tree below the current directory. - ;; If any files are locked, return the name of the first such file. - ;; (This means, neither snapshot creation nor retrieval is allowed.) - ;; If one or more of the files are currently visited, return `visited'. - ;; Otherwise, return nil. +(defun vc-snapshot-precondition (dir) + "Scan the tree below the current directory. If any files are +locked, return the name of the first such file. \(This means, neither +snapshot creation nor retrieval is allowed.\) If one or more of the +files are currently visited, return `visited'. Otherwise, return +nil." (let ((status nil)) (catch 'vc-locked-example (vc-file-tree-walk - default-directory - (function (lambda (f) - (and (vc-registered f) - (if (vc-locking-user f) (throw 'vc-locked-example f) - (if (get-file-buffer f) (setq status 'visited))))))) + dir + (lambda (f) + (if (not (vc-up-to-date-p f)) (throw 'vc-locked-example f) + (if (get-file-buffer f) (setq status 'visited))))) status))) ;;;###autoload -(defun vc-create-snapshot (name) - "Make a snapshot called NAME. -The snapshot is made from all registered files at or below the current -directory. For each file, the version level of its latest -version becomes part of the named configuration." - (interactive "sNew snapshot name: ") - (let ((result (vc-snapshot-precondition))) +(defun vc-create-snapshot (dir name branchp) + "Descending recursively from DIR, make a snapshot called NAME. +For each registered file, the version level of its latest version +becomes part of the named configuration. If the prefix argument +BRANCHP is given, the snapshot is made as a new branch and the files +are checked out in that new branch." + (interactive + (list (read-file-name "Directory: " default-directory default-directory t) + (read-string "New snapshot name: ") + current-prefix-arg)) + (message "Making %s... " (if branchp "branch" "snapshot")) + (if (file-directory-p dir) (setq dir (file-name-as-directory dir))) + (vc-call-backend (vc-responsible-backend dir) + 'create-snapshot dir name branchp) + (message "Making %s... done" (if branchp "branch" "snapshot"))) + +(defun vc-default-create-snapshot (backend dir name branchp) + (when branchp + (error "VC backend %s does not support module branches" backend)) + (let ((result (vc-snapshot-precondition dir))) (if (stringp result) - (error "File %s is locked" result) + (error "File %s is not up-to-date" result) (vc-file-tree-walk - default-directory - (function (lambda (f) (and - (vc-name f) - (vc-backend-assign-name f name))))) - ))) + dir + (lambda (f) + (vc-call assign-name f name)))))) ;;;###autoload -(defun vc-retrieve-snapshot (name) - "Retrieve the snapshot called NAME, or latest versions if NAME is empty. -When retrieving a snapshot, there must not be any locked files at or below -the current directory. If none are locked, all registered files are -checked out (unlocked) at their version levels in the snapshot NAME. -If NAME is the empty string, all registered files that are not currently -locked are updated to the latest versions." - (interactive "sSnapshot name to retrieve (default latest versions): ") - (let ((update (yes-or-no-p "Update any affected buffers? "))) - (if (string= name "") - (progn - (vc-file-tree-walk - default-directory - (function (lambda (f) (and - (vc-registered f) - (not (vc-locking-user f)) - (vc-error-occurred - (vc-backend-checkout f nil "") - (if update (vc-resynch-buffer f t t)))))))) - (let ((result (vc-snapshot-precondition))) - (if (stringp result) - (error "File %s is locked" result) - (setq update (and (eq result 'visited) update)) - (vc-file-tree-walk - default-directory - (function (lambda (f) (and - (vc-name f) - (vc-error-occurred - (vc-backend-checkout f nil name) - (if update (vc-resynch-buffer f t t))))))) - ))))) +(defun vc-retrieve-snapshot (dir name) + "Descending recursively from DIR, retrieve the snapshot called NAME, +or latest versions if NAME is empty. If locking is used for the files +in DIR, then there must not be any locked files at or below DIR (but +if NAME is empty, locked files are allowed and simply skipped)." + (interactive + (list (read-file-name "Directory: " default-directory default-directory t) + (read-string "Snapshot name to retrieve (default latest versions): "))) + (let ((update (yes-or-no-p "Update any affected buffers? ")) + (msg (if (or (not name) (string= name "")) + (format "Updating %s... " (abbreviate-file-name dir)) + (format "Retrieving snapshot into %s... " + (abbreviate-file-name dir))))) + (message msg) + (vc-call-backend (vc-responsible-backend dir) + 'retrieve-snapshot dir name update) + (message (concat msg "done")))) + +(defun vc-default-retrieve-snapshot (backend dir name update) + (if (string= name "") + (progn + (vc-file-tree-walk + dir + (lambda (f) (and + (vc-up-to-date-p f) + (vc-error-occurred + (vc-call checkout f nil "") + (if update (vc-resynch-buffer f t t))))))) + (let ((result (vc-snapshot-precondition dir))) + (if (stringp result) + (error "File %s is locked" result) + (setq update (and (eq result 'visited) update)) + (vc-file-tree-walk + dir + (lambda (f) (and + (vc-error-occurred + (vc-call checkout f nil name) + (if update (vc-resynch-buffer f t t)))))))))) ;; Miscellaneous other entry points @@ -2023,73 +2021,60 @@ (interactive) (vc-ensure-vc-buffer) (let ((file buffer-file-name)) - (vc-backend-print-log file) - (pop-to-buffer (get-buffer-create "*vc*")) + (vc-setup-buffer nil) (setq default-directory (file-name-directory file)) - (goto-char (point-max)) (forward-line -1) - (while (looking-at "=*\n") - (delete-char (- (match-end 0) (match-beginning 0))) - (forward-line -1)) - (goto-char (point-min)) - (if (looking-at "[\b\t\n\v\f\r ]+") - (delete-char (- (match-end 0) (match-beginning 0)))) - (shrink-window-if-larger-than-buffer) - ;; move point to the log entry for the current version - (and (not (eq (vc-backend file) 'SCCS)) - (re-search-forward - ;; also match some context, for safety - (concat "----\nrevision " (vc-workfile-version file) - "\\(\tlocked by:.*\n\\|\n\\)date: ") nil t) - ;; set the display window so that - ;; the whole log entry is displayed - (let (start end lines) - (beginning-of-line) (forward-line -1) (setq start (point)) - (if (not (re-search-forward "^----*\nrevision" nil t)) - (setq end (point-max)) - (beginning-of-line) (forward-line -1) (setq end (point))) - (setq lines (count-lines start end)) - (cond - ;; if the global information and this log entry fit - ;; into the window, display from the beginning - ((< (count-lines (point-min) end) (window-height)) - (goto-char (point-min)) - (recenter 0) - (goto-char start)) - ;; if the whole entry fits into the window, - ;; display it centered - ((< (1+ lines) (window-height)) - (goto-char start) - (recenter (1- (- (/ (window-height) 2) (/ lines 2))))) - ;; otherwise (the entry is too large for the window), - ;; display from the start - (t - (goto-char start) - (recenter 0))))))) + (vc-call print-log file) + (pop-to-buffer (current-buffer)) + (if (fboundp 'log-view-mode) (log-view-mode)) + (vc-exec-after + `(progn + (goto-char (point-max)) (forward-line -1) + (while (looking-at "=*\n") + (delete-char (- (match-end 0) (match-beginning 0))) + (forward-line -1)) + (goto-char (point-min)) + (if (looking-at "[\b\t\n\v\f\r ]+") + (delete-char (- (match-end 0) (match-beginning 0)))) + (shrink-window-if-larger-than-buffer) + ;; move point to the log entry for the current version + (if (fboundp 'log-view-goto-rev) + (log-view-goto-rev ',(vc-workfile-version file)) + (if (vc-find-backend-function ',(vc-backend file) 'show-log-entry) + (vc-call-backend ',(vc-backend file) + 'show-log-entry + ',(vc-workfile-version file)))))))) ;;;###autoload (defun vc-revert-buffer () "Revert the current buffer's file back to the version it was based on. This asks for confirmation if the buffer contents are not identical -to that version. Note that for RCS and CVS, this function does not -automatically pick up newer changes found in the master file; -use C-u \\[vc-next-action] RET to do so." +to that version. Note that for RCS and CVS, this function does not +automatically pick up newer changes found in the master file; +use \\[universal-argument] \\[vc-next-action] to do so." (interactive) (vc-ensure-vc-buffer) (let ((file buffer-file-name) ;; This operation should always ask for confirmation. (vc-suppress-confirm nil) - (obuf (current-buffer)) (changed (vc-diff nil t))) - (if changed - (unwind-protect - (if (not (yes-or-no-p "Discard changes? ")) - (error "Revert cancelled")) - (if (and (window-dedicated-p (selected-window)) - (one-window-p t 'selected-frame)) - (make-frame-invisible (selected-frame)) - (delete-window)))) + (obuf (current-buffer))) + (unless (vc-workfile-unchanged-p file) + (vc-diff nil t) + (vc-exec-after `(message nil)) + (unwind-protect + (if (not (yes-or-no-p "Discard changes? ")) + (error "Revert canceled")) + (if (or (window-dedicated-p (selected-window)) + (one-window-p t 'selected-frame)) + (make-frame-invisible (selected-frame)) + (delete-window)))) (set-buffer obuf) - (vc-backend-revert file) - (vc-resynch-window file t t))) + ;; Do the reverting + (message "Reverting %s..." file) + (vc-call revert file) + (vc-file-setprop file 'vc-state 'up-to-date) + (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))) + (vc-resynch-buffer file t t) + (message "Reverting %s...done" file))) ;;;###autoload (defun vc-cancel-version (norevert) @@ -2097,21 +2082,26 @@ A prefix argument means do not revert the buffer afterwards." (interactive "P") (vc-ensure-vc-buffer) - (cond - ((eq (vc-backend (buffer-file-name)) 'CVS) - (error "Unchecking files under CVS is dangerous and not supported in VC")) - ((vc-locking-user (buffer-file-name)) - (error "This version is locked; use vc-revert-buffer to discard changes")) - ((not (vc-latest-on-branch-p (buffer-file-name))) - (error "This is not the latest version--VC cannot cancel it"))) - (let* ((target (vc-workfile-version (buffer-file-name))) + (let* ((backend (vc-backend (buffer-file-name))) + (target (vc-workfile-version (buffer-file-name))) (recent (if (vc-trunk-p target) "" (vc-branch-part target))) (config (current-window-configuration)) done) + (cond + ((not (vc-find-backend-function backend 'uncheck)) + (error "Sorry, canceling versions is not supported under %s" backend)) + ((not (vc-call latest-on-branch-p (buffer-file-name))) + (error "This is not the latest version; VC cannot cancel it")) + ((not (vc-up-to-date-p (buffer-file-name))) + (error (substitute-command-keys "File is not up to date; use \\[vc-revert-buffer] to discard changes")))) (if (null (yes-or-no-p (format "Remove version %s from master? " target))) nil - (setq norevert (or norevert (not - (yes-or-no-p "Revert buffer to most recent remaining version? ")))) - (vc-backend-uncheck (buffer-file-name) target) + (setq norevert (or norevert (not + (yes-or-no-p "Revert buffer to most recent remaining version? ")))) + + (message "Removing last change from %s..." (buffer-file-name)) + (vc-call uncheck (buffer-file-name) target) + (message "Removing last change from %s...done" (buffer-file-name)) + ;; Check out the most recent remaining version. If it fails, because ;; the whole branch got deleted, do a double-take and check out the ;; version where the branch started. @@ -2119,15 +2109,16 @@ (condition-case err (progn (if norevert - ;; Check out locked, but only to disc, and keep + ;; Check out locked, but only to disk, and keep ;; modifications in the buffer. - (vc-backend-checkout (buffer-file-name) t recent) + (vc-call checkout (buffer-file-name) t recent) ;; Check out unlocked, and revert buffer. (vc-checkout (buffer-file-name) nil recent)) (setq done t)) ;; If the checkout fails, vc-do-command signals an error. ;; We catch this error, check the reason, correct the ;; version number, and try a second time. + ;; FIXME: This is still RCS-only code. (error (set-buffer "*vc*") (goto-char (point-min)) (if (search-forward "no side branches present for" nil t) @@ -2146,12 +2137,41 @@ ;; inhibit backup for this buffer (progn (make-local-variable 'backup-inhibited) (setq backup-inhibited t))) - (if (eq (vc-backend (buffer-file-name)) 'RCS) - (progn (setq buffer-read-only nil) - (vc-clear-headers))) + (setq buffer-read-only nil) + (vc-clear-headers) (vc-mode-line (buffer-file-name)))) - (message "Version %s has been removed from the master" target) - ))) + (message "Version %s has been removed from the master" target)))) + +(defun vc-rename-master (oldmaster newfile templates) + "Rename OLDMASTER to be the master file for NEWFILE based on TEMPLATES." + (let* ((dir (file-name-directory (expand-file-name oldmaster))) + (newdir (or (file-name-directory newfile) "")) + (newbase (file-name-nondirectory newfile)) + (masters + ;; List of potential master files for `newfile' + (mapcar + (lambda (s) (vc-possible-master s newdir newbase)) + templates))) + (if (or (file-symlink-p oldmaster) + (file-symlink-p (file-name-directory oldmaster))) + (error "This unsafe in the presence of symbolic links")) + (rename-file + oldmaster + (catch 'found + ;; If possible, keep the master file in the same directory. + (mapcar (lambda (f) + (if (and f (string= (file-name-directory (expand-file-name f)) + dir)) + (throw 'found f))) + masters) + ;; If not, just use the first possible place. + (mapcar (lambda (f) + (and f + (or (not (setq dir (file-name-directory f))) + (file-directory-p dir)) + (throw 'found f))) + masters) + (error "New file lacks a version control directory"))))) ;;;###autoload (defun vc-rename-file (old new) @@ -2163,77 +2183,42 @@ ;; consider to be wrong. When the famous, long-awaited rename database is ;; implemented things might change for the better. This is unlikely to occur ;; until CVS 2.0 is released. --ceder 1994-01-23 21:27:51 - (if (eq (vc-backend old) 'CVS) - (error "Renaming files under CVS is dangerous and not supported in VC")) - (let ((oldbuf (get-file-buffer old))) + (let ((oldbuf (get-file-buffer old)) + (backend (vc-backend old))) + (unless (or (null backend) (vc-find-backend-function backend 'rename-file)) + (error "Renaming files under %s is not supported in VC" backend)) (if (and oldbuf (buffer-modified-p oldbuf)) (error "Please save files before moving them")) (if (get-file-buffer new) (error "Already editing new file name")) (if (file-exists-p new) (error "New file already exists")) - (let ((oldmaster (vc-name old)) newmaster) - (if oldmaster - (progn - (if (vc-locking-user old) - (error "Please check in files before moving them")) - (if (or (file-symlink-p oldmaster) - ;; This had FILE, I changed it to OLD. -- rms. - (file-symlink-p (vc-backend-subdirectory-name old))) - (error "This is not a safe thing to do in the presence of symbolic links")) - (setq newmaster - (let ((backend (vc-backend old)) - (newdir (or (file-name-directory new) "")) - (newbase (file-name-nondirectory new))) - (catch 'found - (mapcar - (function - (lambda (s) - (if (eq backend (cdr s)) - (let* ((newmaster (format (car s) newdir newbase)) - (newmasterdir (file-name-directory newmaster))) - (if (or (not newmasterdir) - (file-directory-p newmasterdir)) - (throw 'found newmaster)))))) - vc-master-templates) - (error "New file lacks a version control directory")))) - ;; Handle the SCCS PROJECTDIR feature. It is odd that this - ;; is a special case, but a more elegant solution would require - ;; significant changes in other parts of VC. - (if (eq (vc-backend old) 'SCCS) - (let ((project-dir (vc-sccs-project-dir))) - (if project-dir - (setq newmaster - (concat project-dir - (file-name-nondirectory newmaster)))))) - (rename-file oldmaster newmaster))) - (if (or (not oldmaster) (file-exists-p old)) - (rename-file old new))) -; ?? Renaming a file might change its contents due to keyword expansion. -; We should really check out a new copy if the old copy was precisely equal -; to some checked in version. However, testing for this is tricky.... + (when backend + (if (and backend (not (vc-up-to-date-p old))) + (error "Please check in files before moving them")) + (vc-call-backend backend 'rename-file old new)) + ;; Move the actual file (unless the backend did it already) + (if (or (not backend) (file-exists-p old)) + (rename-file old new)) + ;; ?? Renaming a file might change its contents due to keyword expansion. + ;; We should really check out a new copy if the old copy was precisely equal + ;; to some checked in version. However, testing for this is tricky.... (if oldbuf - (save-excursion - (set-buffer oldbuf) + (with-current-buffer oldbuf (let ((buffer-read-only buffer-read-only)) (set-visited-file-name new)) (vc-backend new) (vc-mode-line new) - (set-buffer-modified-p nil)))) - ;; This had FILE, I changed it to OLD. -- rms. - (vc-backend-dispatch old - (vc-record-rename old new) ;SCCS - nil ;RCS - nil ;CVS - ) - ) + (set-buffer-modified-p nil))))) + +;; Only defined in very recent Emacsen +(defvar small-temporary-file-directory nil) ;;;###autoload (defun vc-update-change-log (&rest args) - "Find change log file and add entries from recent RCS/CVS logs. + "Find change log file and add entries from recent version control logs. Normally, find log entries for all registered files in the default -directory using `rcs2log', which finds CVS logs preferentially. -The mark is left at the end of the text prepended to the change log. +directory. With prefix arg of C-u, only find log entries for the current buffer's file. @@ -2241,9 +2226,8 @@ files that are under version control. This puts all the entries in the log for the default directory, which may not be appropriate. -From a program, any arguments are assumed to be filenames and are -passed to the `rcs2log' script after massaging to be relative to the -default directory." +From a program, any arguments are assumed to be filenames for which +log entries should be gathered." (interactive (cond ((consp current-prefix-arg) ;C-u (list buffer-file-name)) @@ -2258,13 +2242,22 @@ (setq buffers (cdr buffers))) files)) (t - ;; `rcs2log' will find the relevant RCS or CVS files - ;; relative to the curent directory if none supplied. + ;; Don't supply any filenames to backend; this means + ;; it should find all relevant files relative to + ;; the default-directory. nil))) + (vc-call-backend (vc-responsible-backend default-directory) + 'update-changelog args)) + +(defun vc-default-update-changelog (backend files) + "Default implementation of update-changelog; uses `rcs2log' which only +works for RCS and CVS." + ;; FIXME: We (c|sh)ould add support for cvs2cl (let ((odefault default-directory) (changelog (find-change-log)) ;; Presumably not portable to non-Unixy systems, along with rcs2log: - (tempfile (make-temp-file + (tempfile (funcall + (if (fboundp 'make-temp-file) 'make-temp-file 'make-temp-name) (expand-file-name "vc" (or small-temporary-file-directory temporary-file-directory)))) @@ -2284,93 +2277,74 @@ (message "Computing change log entries... %s" (unwind-protect (progn - (cd odefault) - (if (eq 0 (apply 'call-process - (expand-file-name "rcs2log" exec-directory) - nil - (list t tempfile) nil - "-c" changelog - "-u" (concat (vc-user-login-name) - "\t" full-name - "\t" mailing-address) - (mapcar - (function - (lambda (f) - (file-relative-name - (if (file-name-absolute-p f) - f - (concat odefault f))))) - args))) - "done" + (setq default-directory odefault) + (if (eq 0 (apply 'call-process + (expand-file-name "rcs2log" + exec-directory) + nil (list t tempfile) nil + "-c" changelog + "-u" (concat (vc-user-login-name) + "\t" full-name + "\t" mailing-address) + (mapcar + (lambda (f) + (file-relative-name + (if (file-name-absolute-p f) + f + (concat odefault f)))) + files))) + "done" (pop-to-buffer (set-buffer (get-buffer-create "*vc*"))) (erase-buffer) (insert-file tempfile) "failed")) - (cd (file-name-directory changelog)) + (setq default-directory (file-name-directory changelog)) (delete-file tempfile))))) - -;; vc-annotate functionality (CVS only). -(defvar vc-annotate-mode-map nil - "Local keymap used for VC-Annotate mode.") -(defvar vc-annotate-mode-menu nil - "Local keymap used for VC-Annotate mode's menu bar menu.") - -;; Syntax Table -(defvar vc-annotate-mode-syntax-table nil - "Syntax table used in VC-Annotate mode buffers.") +;;; Annotate functionality ;; Declare globally instead of additional parameter to ;; temp-buffer-show-function (not possible to pass more than one ;; parameter). -(defvar vc-annotate-ratio nil) +(defvar vc-annotate-ratio nil "Global variable") +(defvar vc-annotate-backend nil "Global variable") -(defun vc-annotate-mode-variables () - (if (not vc-annotate-mode-syntax-table) - (progn (setq vc-annotate-mode-syntax-table (make-syntax-table)) - (set-syntax-table vc-annotate-mode-syntax-table))) - (if (not vc-annotate-mode-map) - (setq vc-annotate-mode-map (make-sparse-keymap))) - (setq vc-annotate-mode-menu (make-sparse-keymap "Annotate")) - (define-key vc-annotate-mode-map [menu-bar] - (make-sparse-keymap "VC-Annotate")) - (define-key vc-annotate-mode-map [menu-bar vc-annotate-mode] - (cons "VC-Annotate" vc-annotate-mode-menu))) +(defun vc-annotate-get-backend (buffer) + "Return the backend matching \"Annotate\" buffer BUFFER. Return NIL +if no match made. Associations are made based on +`vc-annotate-buffers'." + (cdr (assoc buffer vc-annotate-buffers))) -(defun vc-annotate-mode () - "Major mode for buffers displaying output from the CVS `annotate' command. +(define-derived-mode vc-annotate-mode fundamental-mode "Annotate" + "Major mode for buffers displaying output from the `annotate' command. You can use the mode-specific menu to alter the time-span of the used colors. See variable `vc-annotate-menu-elements' for customizing the menu items." - (interactive) - (kill-all-local-variables) ; Recommended by RMS. - (vc-annotate-mode-variables) ; This defines various variables. - (use-local-map vc-annotate-mode-map) ; This provides the local keymap. - (set-syntax-table vc-annotate-mode-syntax-table) - (setq major-mode 'vc-annotate-mode) ; This is how `describe-mode' - ; finds out what to describe. - (setq mode-name "Annotate") ; This goes into the mode line. - (run-hooks 'vc-annotate-mode-hook) (vc-annotate-add-menu)) (defun vc-annotate-display-default (&optional event) "Use the default color spectrum for VC Annotate mode." - (interactive) + (interactive "e") (message "Redisplaying annotation...") - (vc-annotate-display (get-buffer (buffer-name))) + (vc-annotate-display (current-buffer) + nil + (vc-annotate-get-backend (current-buffer))) (message "Redisplaying annotation...done")) (defun vc-annotate-add-menu () - "Adds the menu 'Annotate' to the menu bar in VC-Annotate mode." + "Add the menu 'Annotate' to the menu bar in VC-Annotate mode." + (setq vc-annotate-mode-menu (make-sparse-keymap "Annotate")) + (define-key vc-annotate-mode-map [menu-bar vc-annotate-mode] + (cons "VC-Annotate" vc-annotate-mode-menu)) (define-key vc-annotate-mode-menu [default] '("Default" . vc-annotate-display-default)) (let ((menu-elements vc-annotate-menu-elements)) (while menu-elements (let* ((element (car menu-elements)) - (days (round (* element - (vc-annotate-car-last-cons vc-annotate-color-map) + (days (round (* element + (vc-annotate-car-last-cons vc-annotate-color-map) 0.7585)))) (setq menu-elements (cdr menu-elements)) (define-key vc-annotate-mode-menu @@ -2383,14 +2357,21 @@ (message "Redisplaying annotation...") (vc-annotate-display (get-buffer (buffer-name)) - (vc-annotate-time-span vc-annotate-color-map ,element)) + (vc-annotate-time-span vc-annotate-color-map ,element) + (vc-annotate-get-backend (current-buffer))) (message "Redisplaying annotation...done")))))))) + +;;;; (defun vc-BACKEND-annotate-command (file buffer) ...) +;;;; Execute "annotate" on FILE by using `call-process' and insert +;;;; the contents in BUFFER. + ;;;###autoload (defun vc-annotate (ratio) - "Display the result of the CVS `annotate' command using colors. -New lines are displayed in red, old in blue. -A prefix argument specifies a factor for stretching the time scale. + "Display the result of the \"Annotate\" command using colors. +\"Annotate\" is defined by `vc-BACKEND-annotate-command'. New lines +are displayed in red, old in blue. A prefix argument specifies a +factor for stretching the time scale. `vc-annotate-menu-elements' customizes the menu elements of the mode-specific menu. `vc-annotate-color-map' and @@ -2398,17 +2379,23 @@ colors. `vc-annotate-background' specifies the background color." (interactive "p") (vc-ensure-vc-buffer) - (if (not (eq (vc-backend (buffer-file-name)) 'CVS)) - (error "Sorry, vc-annotate is only implemented for CVS")) (message "Annotating...") - (let ((temp-buffer-name (concat "*cvs annotate " (buffer-name) "*")) + (let ((temp-buffer-name (concat "*Annotate " (buffer-name) "*")) (temp-buffer-show-function 'vc-annotate-display) - (vc-annotate-ratio ratio)) - (with-output-to-temp-buffer temp-buffer-name - (call-process "cvs" nil (get-buffer temp-buffer-name) nil - "annotate" (file-name-nondirectory (buffer-file-name))))) + (vc-annotate-ratio ratio) + (vc-annotate-backend (vc-backend (buffer-file-name)))) + (with-output-to-temp-buffer temp-buffer-name + (vc-call-backend vc-annotate-backend 'annotate-command + (file-name-nondirectory (buffer-file-name)) + (get-buffer temp-buffer-name))) + ;; Don't use the temp-buffer-name until the buffer is created + ;; (only after `with-output-to-temp-buffer'.) + (setq vc-annotate-buffers + (append vc-annotate-buffers + (list (cons (get-buffer temp-buffer-name) vc-annotate-backend))))) (message "Annotating... done")) + (defun vc-annotate-car-last-cons (a-list) "Return car of last cons in association list A-LIST." (if (not (eq nil (cdr a-list))) @@ -2416,21 +2403,21 @@ (car (car a-list)))) (defun vc-annotate-time-span (a-list span &optional quantize) -"Return an association list with factor SPAN applied to the time-span -of association list A-LIST. Optionaly quantize to the factor of -QUANTIZE." +"Apply factor SPAN to the time-span of association list A-LIST +Return the new alist. +Optionally quantize to the factor of QUANTIZE." ;; Apply span to each car of every cons - (if (not (eq nil a-list)) + (if (not (eq nil a-list)) (append (list (cons (* (car (car a-list)) span) (cdr (car a-list)))) - (vc-annotate-time-span (nthcdr (cond (quantize) ; optional - (1)) ; Default to cdr + (vc-annotate-time-span (nthcdr (or quantize ; optional + 1) ; Default to cdr a-list) span quantize)))) (defun vc-annotate-compcar (threshold a-list) - "Test successive cons cells of association list A-LIST against -THRESHOLD. Return the first cons cell which car is not less than -THRESHOLD, nil otherwise" + "Test successive cons cells of association list A-LIST against THRESHOLD. +Return the first cons cell which car is not less than THRESHOLD, +nil otherwise" (let ((i 1) (tmp-cons (car a-list))) (while (and tmp-cons (< (car tmp-cons) threshold)) @@ -2439,649 +2426,91 @@ tmp-cons)) ; Return the appropriate value -(defun vc-annotate-display (buffer &optional color-map) - "Do the VC-Annotate display in BUFFER using COLOR-MAP." +;;;; (defun vc-BACKEND-annotate-difference (point) ...) +;;;; +;;;; Return the difference between the age of the line at point and +;;;; the current time. Return NIL if there is no more comparison to +;;;; be made in the buffer. Return value as defined for +;;;; `current-time'. You can safely assume that point is placed at +;;;; the beginning of each line, starting at `point-min'. The buffer +;;;; that point is placed in is the Annotate output, as defined by +;;;; the relevant backend. + +(defun vc-annotate-display (buffer &optional color-map backend) + "Do the VC-Annotate display in BUFFER using COLOR-MAP. The original +Annotating file is supposed to be handled by BACKEND. If BACKEND is +NIL, variable VC-ANNOTATE-BACKEND is used instead. This function is +destructive on VC-ANNOTATE-BACKEND when BACKEND is non-nil." ;; Handle the case of the global variable vc-annotate-ratio being ;; set. This variable is used to pass information from function ;; vc-annotate since it is not possible to use another parameter - ;; (see temp-buffer-show-function). + ;; (see temp-buffer-show-function). (if (and (not color-map) vc-annotate-ratio) ;; This will only be true if called from vc-annotate with ratio ;; being non-nil. (setq color-map (vc-annotate-time-span vc-annotate-color-map vc-annotate-ratio))) - - ;; We need a list of months and their corresponding numbers. - (let* ((local-month-numbers - '(("Jan" . 1) ("Feb" . 2) ("Mar" . 3) ("Apr" . 4) - ("May" . 5) ("Jun" . 6) ("Jul" . 7) ("Aug" . 8) - ("Sep" . 9) ("Oct" . 10) ("Nov" . 11) ("Dec" . 12)))) - (set-buffer buffer) - (display-buffer buffer) - (or (eq major-mode 'vc-annotate-mode) ; Turn on vc-annotate-mode if not done - (vc-annotate-mode)) - ;; Delete old overlays - (mapcar - (lambda (overlay) - (if (overlay-get overlay 'vc-annotation) - (delete-overlay overlay))) - (overlays-in (point-min) (point-max))) - (goto-char (point-min)) ; Position at the top of the buffer. - (while (re-search-forward - "^\\S-+\\s-+\\S-+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): " -;; "^[0-9]+\\(\.[0-9]+\\)*\\s-+(\\sw+\\s-+\\([0-9]+\\)-\\(\\sw+\\)-\\([0-9]+\\)): " - nil t) + (set-buffer buffer) + (display-buffer buffer) + (if (not vc-annotate-mode) ; Turn on vc-annotate-mode if not done + (vc-annotate-mode)) + (goto-char (point-min)) ; Position at the top of the buffer. + ;; Delete old overlays + (mapcar + (lambda (overlay) + (if (overlay-get overlay 'vc-annotation) + (delete-overlay overlay))) + (overlays-in (point-min) (point-max))) + (goto-char (point-min)) ; Position at the top of the buffer. + + (if backend (setq vc-annotate-backend backend)) ; Destructive on `vc-annotate-backend' - (let* (;; Unfortunately, order is important. match-string will - ;; be corrupted by extent functions in XEmacs. Access - ;; string-matches first. - (day (string-to-number (match-string 1))) - (month (cdr (assoc (match-string 2) local-month-numbers))) - (year-tmp (string-to-number (match-string 3))) - ;; Years 0..68 are 2000..2068. - ;; Years 69..99 are 1969..1999. - (year (+ (cond ((> 69 year-tmp) 2000) - ((> 100 year-tmp) 1900) - (t 0)) - year-tmp)) - (high (- (car (current-time)) - (car (encode-time 0 0 0 day month year)))) - (color (cond ((vc-annotate-compcar high (cond (color-map) - (vc-annotate-color-map)))) - ((cons nil vc-annotate-very-old-color)))) - ;; substring from index 1 to remove any leading `#' in the name - (face-name (concat "vc-annotate-face-" (substring (cdr color) 1))) - ;; Make the face if not done. - (face (cond ((intern-soft face-name)) - ((let ((tmp-face (make-face (intern face-name)))) - (set-face-foreground tmp-face (cdr color)) - (if vc-annotate-background - (set-face-background tmp-face vc-annotate-background)) - tmp-face)))) ; Return the face - (point (point)) - overlay) - + (let ((difference (vc-call-backend vc-annotate-backend 'annotate-difference (point)))) + (while difference + (let* + ((color (or (vc-annotate-compcar + difference (or color-map vc-annotate-color-map)) + (cons nil vc-annotate-very-old-color))) + ;; substring from index 1 to remove any leading `#' in the name + (face-name (concat "vc-annotate-face-" (substring (cdr color) 1))) + ;; Make the face if not done. + (face (or (intern-soft face-name) + (let ((tmp-face (make-face (intern face-name)))) + (set-face-foreground tmp-face (cdr color)) + (if vc-annotate-background + (set-face-background tmp-face vc-annotate-background)) + tmp-face))) ; Return the face + (point (point)) + overlay) (forward-line 1) (setq overlay (make-overlay point (point))) (overlay-put overlay 'face face) - (overlay-put overlay 'vc-annotation t))))) + (overlay-put overlay 'vc-annotation t)) + (setq difference (vc-call-backend vc-annotate-backend 'annotate-difference (point)))))) ;; Collect back-end-dependent stuff here -(defun vc-backend-admin (file &optional rev comment) - ;; Register a file into the version-control system - ;; Automatically retrieves a read-only version of the file with - ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise - ;; it deletes the workfile. - (vc-file-clearprops file) - (or vc-default-back-end - (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS))) - (message "Registering %s..." file) - (let* ((switches - (if (stringp vc-register-switches) - (list vc-register-switches) - vc-register-switches)) - (project-dir) - (backend - (cond - ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end) - ((file-exists-p "RCS") 'RCS) - ((file-exists-p "CVS") 'CVS) - ((file-exists-p "SCCS") 'SCCS) - ((setq project-dir (vc-sccs-project-dir)) 'SCCS) - (t vc-default-back-end)))) - (cond ((eq backend 'SCCS) - (let ((vc-name - (if project-dir (concat project-dir - "s." (file-name-nondirectory file)) - (format - (car (rassq 'SCCS vc-master-templates)) - (or (file-name-directory file) "") - (file-name-nondirectory file))))) - (apply 'vc-do-command nil 0 "admin" nil nil ;; SCCS - (and rev (concat "-r" rev)) - "-fb" - (concat "-i" file) - (and comment (concat "-y" comment)) - vc-name - switches)) - (delete-file file) - (if vc-keep-workfiles - (vc-do-command nil 0 "get" file 'MASTER))) - ((eq backend 'RCS) - (apply 'vc-do-command nil 0 "ci" file 'WORKFILE ;; RCS - ;; if available, use the secure registering option - (and (vc-backend-release-p 'RCS "5.6.4") "-i") - (concat (if vc-keep-workfiles "-u" "-r") rev) - (and comment (concat "-t-" comment)) - switches)) - ((eq backend 'CVS) - (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE ;; CVS - "add" - (and comment (string-match "[^\t\n ]" comment) - (concat "-m" comment)) - switches) - ))) - (message "Registering %s...done" file) - ) - -(defun vc-backend-checkout (file &optional writable rev workfile) - ;; Retrieve a copy of a saved version into a workfile - (let ((filename (or workfile file)) - (file-buffer (get-file-buffer file)) - switches) - (message "Checking out %s..." filename) - (save-excursion - ;; Change buffers to get local value of vc-checkout-switches. - (if file-buffer (set-buffer file-buffer)) - (setq switches (if (stringp vc-checkout-switches) - (list vc-checkout-switches) - vc-checkout-switches)) - ;; Save this buffer's default-directory - ;; and use save-excursion to make sure it is restored - ;; in the same buffer it was saved in. - (let ((default-directory default-directory)) - (save-excursion - ;; Adjust the default-directory so that the check-out creates - ;; the file in the right place. - (setq default-directory (file-name-directory filename)) - (vc-backend-dispatch file - (progn ;; SCCS - (and rev (string= rev "") (setq rev nil)) - (if workfile - ;; Some SCCS implementations allow checking out directly to a - ;; file using the -G option, but then some don't so use the - ;; least common denominator approach and use the -p option - ;; ala RCS. - (let ((vc-modes (logior (file-modes (vc-name file)) - (if writable 128 0))) - (failed t)) - (unwind-protect - (progn - (let ((coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion)) - (with-temp-file filename - (apply 'vc-do-command - (current-buffer) 0 "get" file 'MASTER - "-s" ;; suppress diagnostic output - (if writable "-e") - "-p" - (and rev - (concat "-r" - (vc-lookup-triple file rev))) - switches))) - (set-file-modes filename - (logior (file-modes (vc-name file)) - (if writable 128 0))) - (setq failed nil)) - (and failed (file-exists-p filename) - (delete-file filename)))) - (apply 'vc-do-command nil 0 "get" file 'MASTER ;; SCCS - (if writable "-e") - (and rev (concat "-r" (vc-lookup-triple file rev))) - switches) - (vc-file-setprop file 'vc-workfile-version nil))) - (if workfile ;; RCS - ;; RCS doesn't let us check out into arbitrary file names directly. - ;; Use `co -p' and make stdout point to the correct file. - (let ((vc-modes (logior (file-modes (vc-name file)) - (if writable 128 0))) - (failed t)) - (unwind-protect - (progn - (let ((coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion)) - (with-temp-file filename - (apply 'vc-do-command - (current-buffer) 0 "co" file 'MASTER - "-q" ;; suppress diagnostic output - (if writable "-l") - (concat "-p" rev) - switches))) - (set-file-modes filename - (logior (file-modes (vc-name file)) - (if writable 128 0))) - (setq failed nil)) - (and failed (file-exists-p filename) (delete-file filename)))) - (let (new-version) - ;; if we should go to the head of the trunk, - ;; clear the default branch first - (and rev (string= rev "") - (vc-do-command nil 0 "rcs" file 'MASTER "-b")) - ;; now do the checkout - (apply 'vc-do-command - nil 0 "co" file 'MASTER - ;; If locking is not strict, force to overwrite - ;; the writable workfile. - (if (eq (vc-checkout-model file) 'implicit) "-f") - (if writable "-l") - (if rev (concat "-r" rev) - ;; if no explicit revision was specified, - ;; check out that of the working file - (let ((workrev (vc-workfile-version file))) - (if workrev (concat "-r" workrev) - nil))) - switches) - ;; determine the new workfile version - (save-excursion - (set-buffer "*vc*") - (goto-char (point-min)) - (setq new-version - (if (re-search-forward "^revision \\([0-9.]+\\).*\n" nil t) - (buffer-substring (match-beginning 1) (match-end 1))))) - (vc-file-setprop file 'vc-workfile-version new-version) - ;; if necessary, adjust the default branch - (and rev (not (string= rev "")) - (vc-do-command nil 0 "rcs" file 'MASTER - (concat "-b" (if (vc-latest-on-branch-p file) - (if (vc-trunk-p new-version) nil - (vc-branch-part new-version)) - new-version)))))) - (if workfile ;; CVS - ;; CVS is much like RCS - (let ((failed t)) - (unwind-protect - (progn - (let ((coding-system-for-read 'no-conversion) - (coding-system-for-write 'no-conversion)) - (with-temp-file filename - (apply 'vc-do-command - (current-buffer) 0 "cvs" file 'WORKFILE - "-Q" ;; suppress diagnostic output - "update" - (concat "-r" rev) - "-p" - switches))) - (setq failed nil)) - (and failed (file-exists-p filename) (delete-file filename)))) - ;; default for verbose checkout: clear the sticky tag - ;; so that the actual update will get the head of the trunk - (and rev (string= rev "") - (vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A")) - ;; If a revision was specified, check that out. - (if rev - (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE - (and writable (eq (vc-checkout-model file) 'manual) "-w") - "update" - (and rev (not (string= rev "")) - (concat "-r" rev)) - switches) - ;; If no revision was specified, call "cvs edit" to make - ;; the file writeable. - (and writable (eq (vc-checkout-model file) 'manual) - (vc-do-command nil 0 "cvs" file 'WORKFILE "edit"))) - (if rev (vc-file-setprop file 'vc-workfile-version nil)))) - (cond - ((not workfile) - (vc-file-clear-masterprops file) - (if writable - (vc-file-setprop file 'vc-locking-user (vc-user-login-name))) - (vc-file-setprop file - 'vc-checkout-time (nth 5 (file-attributes file))))) - (message "Checking out %s...done" filename)))))) - -(defun vc-backend-logentry-check (file) - (vc-backend-dispatch file - (if (>= (buffer-size) 512) ;; SCCS - (progn - (goto-char 512) - (error - "Log must be less than 512 characters; point is now at pos 512"))) - nil ;; RCS - nil) ;; CVS - ) - -(defun vc-backend-checkin (file rev comment) - ;; Register changes to FILE as level REV with explanatory COMMENT. - ;; Automatically retrieves a read-only version of the file with - ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise - ;; it deletes the workfile. - ;; Adaptation for RCS branch support: if this is an explicit checkin, - ;; or if the checkin creates a new branch, set the master file branch - ;; accordingly. - (message "Checking in %s..." file) - ;; "This log message intentionally left almost blank". - ;; RCS 5.7 gripes about white-space-only comments too. - (or (and comment (string-match "[^\t\n ]" comment)) - (setq comment "*** empty log message ***")) - (save-excursion - ;; Change buffers to get local value of vc-checkin-switches. - (set-buffer (or (get-file-buffer file) (current-buffer))) - (let ((switches - (if (stringp vc-checkin-switches) - (list vc-checkin-switches) - vc-checkin-switches))) - ;; Clear the master-properties. Do that here, not at the - ;; end, because if the check-in fails we want them to get - ;; re-computed before the next try. - (vc-file-clear-masterprops file) - (vc-backend-dispatch file - ;; SCCS - (progn - (apply 'vc-do-command nil 0 "delta" file 'MASTER - (if rev (concat "-r" rev)) - (concat "-y" comment) - switches) - (vc-file-setprop file 'vc-locking-user 'none) - (vc-file-setprop file 'vc-workfile-version nil) - (if vc-keep-workfiles - (vc-do-command nil 0 "get" file 'MASTER)) - ) - ;; RCS - (let ((old-version (vc-workfile-version file)) new-version) - (apply 'vc-do-command nil 0 "ci" file 'MASTER - ;; if available, use the secure check-in option - (and (vc-backend-release-p 'RCS "5.6.4") "-j") - (concat (if vc-keep-workfiles "-u" "-r") rev) - (concat "-m" comment) - switches) - (vc-file-setprop file 'vc-locking-user 'none) - (vc-file-setprop file 'vc-workfile-version nil) +(defalias 'vc-default-logentry-check 'ignore) - ;; determine the new workfile version - (set-buffer "*vc*") - (goto-char (point-min)) - (if (or (re-search-forward - "new revision: \\([0-9.]+\\);" nil t) - (re-search-forward - "reverting to previous revision \\([0-9.]+\\)" nil t)) - (progn (setq new-version (buffer-substring (match-beginning 1) - (match-end 1))) - (vc-file-setprop file 'vc-workfile-version new-version))) - - ;; if we got to a different branch, adjust the default - ;; branch accordingly - (cond - ((and old-version new-version - (not (string= (vc-branch-part old-version) - (vc-branch-part new-version)))) - (vc-do-command nil 0 "rcs" file 'MASTER - (if (vc-trunk-p new-version) "-b" - (concat "-b" (vc-branch-part new-version)))) - ;; If this is an old RCS release, we might have - ;; to remove a remaining lock. - (if (not (vc-backend-release-p 'RCS "5.6.2")) - ;; exit status of 1 is also accepted. - ;; It means that the lock was removed before. - (vc-do-command nil 1 "rcs" file 'MASTER - (concat "-u" old-version)))))) - ;; CVS - (progn - ;; explicit check-in to the trunk requires a - ;; double check-in (first unexplicit) (CVS-1.3) - (condition-case nil - (progn - (if (and rev (vc-trunk-p rev)) - (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE - "ci" "-m" "intermediate" - switches)) - (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE - "ci" (if rev (concat "-r" rev)) - (concat "-m" comment) - switches)) - (error (if (eq (vc-cvs-status file) 'needs-merge) - ;; The CVS output will be on top of this message. - (error "Type C-x 0 C-x C-q to merge in changes") - (error "Check-in failed")))) - ;; determine and store the new workfile version - (set-buffer "*vc*") - (goto-char (point-min)) - (if (re-search-forward - "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" nil t) - (vc-file-setprop file 'vc-workfile-version - (buffer-substring (match-beginning 2) - (match-end 2))) - (vc-file-setprop file 'vc-workfile-version nil)) - ;; if this was an explicit check-in, remove the sticky tag - (if rev - (vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A")) - ;; Forget the checkout model, because we might have assumed - ;; a wrong one when we found the file. After commit, we can - ;; tell it from the permissions of the file - ;; (see vc-checkout-model). - (vc-file-setprop file 'vc-checkout-model nil) - (vc-file-setprop file 'vc-locking-user 'none) - (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file))))))) - (message "Checking in %s...done" file)) - -(defun vc-backend-revert (file) - ;; Revert file to the version it was based on. - (message "Reverting %s..." file) - (vc-file-clear-masterprops file) - (vc-backend-dispatch - file - ;; SCCS - (progn - (vc-do-command nil 0 "unget" file 'MASTER nil) - (vc-do-command nil 0 "get" file 'MASTER nil) - ;; Checking out explicit versions is not supported under SCCS, yet. - ;; We always "revert" to the latest version; therefore - ;; vc-workfile-version is cleared here so that it gets recomputed. - (vc-file-setprop file 'vc-workfile-version nil)) - ;; RCS - (vc-do-command nil 0 "co" file 'MASTER - "-f" (concat "-u" (vc-workfile-version file))) - ;; CVS - (progn - ;; Check out via standard output (caused by the final argument - ;; FILE below), so that no sticky tag is set. - (vc-backend-checkout file nil (vc-workfile-version file) file) - ;; If "cvs edit" was used to make the file writeable, - ;; call "cvs unedit" now to undo that. - (if (eq (vc-checkout-model file) 'manual) - (vc-do-command nil 0 "cvs" file 'WORKFILE "unedit")))) - (vc-file-setprop file 'vc-locking-user 'none) - (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file))) - (message "Reverting %s...done" file) - ) - -(defun vc-backend-steal (file &optional rev) - ;; Steal the lock on the current workfile. Needs RCS 5.6.2 or later for -M. - (message "Stealing lock on %s..." file) - (vc-backend-dispatch file - (progn ;SCCS - (vc-do-command nil 0 "unget" file 'MASTER "-n" (if rev (concat "-r" rev))) - (vc-do-command nil 0 "get" file 'MASTER "-g" (if rev (concat "-r" rev))) - ) - (vc-do-command nil 0 "rcs" file 'MASTER ;RCS - "-M" (concat "-u" rev) (concat "-l" rev)) - (error "You cannot steal a CVS lock; there are no CVS locks to steal") ;CVS - ) - (vc-file-setprop file 'vc-locking-user (vc-user-login-name)) - (message "Stealing lock on %s...done" file) - ) - -(defun vc-backend-uncheck (file target) - ;; Undo the latest checkin. - (message "Removing last change from %s..." file) - (vc-backend-dispatch file - (vc-do-command nil 0 "rmdel" file 'MASTER (concat "-r" target)) - (vc-do-command nil 0 "rcs" file 'MASTER (concat "-o" target)) - nil ;; this is never reached under CVS - ) - (message "Removing last change from %s...done" file) - ) - -(defun vc-backend-print-log (file) - ;; Get change log associated with FILE. - (vc-backend-dispatch - file - (vc-do-command nil 0 "prs" file 'MASTER) - (vc-do-command nil 0 "rlog" file 'MASTER) - (vc-do-command nil 0 "cvs" file 'WORKFILE "log"))) - -(defun vc-backend-assign-name (file name) - ;; Assign to a FILE's latest version a given NAME. - (vc-backend-dispatch file - (vc-add-triple name file (vc-latest-version file)) ;; SCCS - (vc-do-command nil 0 "rcs" file 'MASTER (concat "-n" name ":")) ;; RCS - (vc-do-command nil 0 "cvs" file 'WORKFILE "tag" name) ;; CVS - ) - ) - -(defun vc-backend-diff (file &optional oldvers newvers cmp) - ;; Get a difference report between two versions of FILE. - ;; Get only a brief comparison report if CMP, a difference report otherwise. - (let ((backend (vc-backend file)) options status - (diff-switches-list (if (listp diff-switches) - diff-switches - (list diff-switches)))) - (cond - ((eq backend 'SCCS) - (setq oldvers (vc-lookup-triple file oldvers)) - (setq newvers (vc-lookup-triple file newvers)) - (setq options (append (list (and cmp "--brief") "-q" - (and oldvers (concat "-r" oldvers)) - (and newvers (concat "-r" newvers))) - (and (not cmp) diff-switches-list))) - (apply 'vc-do-command "*vc-diff*" 1 "vcdiff" file 'MASTER options)) - ((eq backend 'RCS) - (if (not oldvers) (setq oldvers (vc-workfile-version file))) - ;; If we know that --brief is not supported, don't try it. - (setq cmp (and cmp (not (eq vc-rcsdiff-knows-brief 'no)))) - (setq options (append (list (and cmp "--brief") "-q" - (concat "-r" oldvers) - (and newvers (concat "-r" newvers))) - (and (not cmp) diff-switches-list))) - (setq status (apply 'vc-do-command "*vc-diff*" 2 - "rcsdiff" file 'WORKFILE options)) - ;; If --brief didn't work, do a double-take and remember it - ;; for the future. - (if (eq status 2) - (setq status - (prog1 - (apply 'vc-do-command "*vc-diff*" 1 "rcsdiff" file 'WORKFILE - (if cmp (cdr options) options)) - (if cmp (setq vc-rcsdiff-knows-brief 'no)))) - ;; If --brief DID work, remember that, too. - (and cmp (not vc-rcsdiff-knows-brief) - (setq vc-rcsdiff-knows-brief 'yes)) - status)) - ;; CVS is different. - ((eq backend 'CVS) - (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) - (if cmp 1 ;; file is added but not committed, - ;; we regard this as "changed". - ;; diff it against /dev/null. - (apply 'vc-do-command - "*vc-diff*" 1 "diff" file 'WORKFILE - (append diff-switches-list '("/dev/null"))))) - ;; cmp is not yet implemented -- we always do a full diff. - (apply 'vc-do-command - "*vc-diff*" 1 "cvs" file 'WORKFILE "diff" - (and oldvers (concat "-r" oldvers)) - (and newvers (concat "-r" newvers)) - diff-switches-list)))))) - -(defun vc-backend-merge-news (file) - ;; Merge in any new changes made to FILE. - (message "Merging changes into %s..." file) - (prog1 - (vc-backend-dispatch - file - (error "vc-backend-merge-news not meaningful for SCCS files") ;SCCS - (error "vc-backend-merge-news not meaningful for RCS files") ;RCS - (save-excursion ; CVS - (vc-file-clear-masterprops file) - (vc-file-setprop file 'vc-workfile-version nil) - (vc-file-setprop file 'vc-locking-user nil) - (vc-file-setprop file 'vc-checkout-time nil) - (vc-do-command nil 0 "cvs" file 'WORKFILE "update") - ;; Analyze the merge result reported by CVS, and set - ;; file properties accordingly. - (set-buffer (get-buffer "*vc*")) - (goto-char (point-min)) - ;; get new workfile version - (if (re-search-forward (concat "^Merging differences between " - "[01234567890.]* and " - "\\([01234567890.]*\\) into") - nil t) - (vc-file-setprop file 'vc-workfile-version (match-string 1))) - ;; get file status - (if (re-search-forward - (concat "^\\(\\([CMUP]\\) \\)?" - (regexp-quote (file-name-nondirectory file)) - "\\( already contains the differences between \\)?") - nil t) - (cond - ;; Merge successful, we are in sync with repository now - ((or (string= (match-string 2) "U") - (string= (match-string 2) "P") - ;; Special case: file contents in sync with - ;; repository anyhow: - (match-string 3)) - (vc-file-setprop file 'vc-locking-user 'none) - (vc-file-setprop file 'vc-checkout-time - (nth 5 (file-attributes file))) - 0) ;; indicate success to the caller - ;; Merge successful, but our own changes are still in the file - ((string= (match-string 2) "M") - (vc-file-setprop file 'vc-locking-user (vc-file-owner file)) - (vc-file-setprop file 'vc-checkout-time 0) - 0) ;; indicate success to the caller - ;; Conflicts detected! - ((string= (match-string 2) "C") - (vc-file-setprop file 'vc-locking-user (vc-file-owner file)) - (vc-file-setprop file 'vc-checkout-time 0) - 1) ;; signal the error to the caller - ) - (pop-to-buffer "*vc*") - (error "Couldn't analyze cvs update result")))) - (message "Merging changes into %s...done" file))) - -(defun vc-backend-merge (file first-version &optional second-version) - ;; Merge the changes between FIRST-VERSION and SECOND-VERSION into - ;; the current working copy of FILE. It is assumed that FILE is - ;; locked and writable (vc-merge ensures this). - (vc-backend-dispatch file - ;; SCCS - (error "Sorry, merging is not implemented for SCCS") - ;; RCS - (vc-do-command nil 1 "rcsmerge" file 'MASTER - "-kk" ;; ignore keyword conflicts - (concat "-r" first-version) - (if second-version (concat "-r" second-version))) - ;; CVS - (progn - (vc-do-command nil 0 "cvs" file 'WORKFILE - "update" "-kk" - (concat "-j" first-version) - (concat "-j" second-version)) - (save-excursion - (set-buffer (get-buffer "*vc*")) - (goto-char (point-min)) - (if (re-search-forward "conflicts during merge" nil t) - 1 ;; signal error - 0 ;; signal success - ))))) +(defun vc-default-merge-news (backend file) + (error "vc-merge-news not meaningful for %s files" backend)) (defun vc-check-headers () "Check if the current file has any headers in it." (interactive) - (save-excursion - (goto-char (point-min)) - (vc-backend-dispatch buffer-file-name - (re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" nil t) ;; SCCS - (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t) ;; RCS - 'RCS ;; CVS works like RCS in this regard. - ) - )) + (vc-call-backend (vc-backend buffer-file-name) 'check-headers)) ;; Back-end-dependent stuff ends here. ;; Set up key bindings for use while editing log messages (defun vc-log-mode (&optional file) - "Minor mode for driving version-control tools. + "Major mode for editing VC log entries. These bindings are added to the global keymap when you enter this mode: \\[vc-next-action] perform next logical version-control operation on current file -\\[vc-register] register current file +\\[vc-register] register current file \\[vc-toggle-read-only] like next-action, but won't register files \\[vc-insert-headers] insert version-control headers in current file \\[vc-print-log] display change history of current file @@ -3090,7 +2519,7 @@ \\[vc-diff] show diffs between file versions \\[vc-version-other-window] visit old version in another window \\[vc-directory] show all files locked by any user in or below . -\\[vc-annotate] colorful display of the cvs annotate command +\\[vc-annotate] colorful display of the cvs annotate command \\[vc-update-change-log] add change log entry from recent checkins While you are entering a change log message for a version, the following @@ -3106,39 +2535,39 @@ \\[vc-comment-search-reverse] search backward for regexp in the comment ring \\[vc-comment-search-forward] search backward for regexp in the comment ring -Entry to the change-log submode calls the value of text-mode-hook, then -the value of vc-log-mode-hook. +Entry to the change-log submode calls the value of `text-mode-hook', then +the value of `vc-log-mode-hook'. Global user options: - vc-initial-comment If non-nil, require user to enter a change + `vc-initial-comment' If non-nil, require user to enter a change comment upon first checkin of the file. - vc-keep-workfiles Non-nil value prevents workfiles from being + `vc-keep-workfiles' Non-nil value prevents workfiles from being deleted when changes are checked in - vc-suppress-confirm Suppresses some confirmation prompts, + `vc-suppress-confirm' Suppresses some confirmation prompts, notably for reversions. - vc-header-alist Which keywords to insert when adding headers + vc-BACKEND-header Which keywords to insert when adding headers with \\[vc-insert-headers]. Defaults to - '(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under + '(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under RCS and CVS. - vc-static-header-alist By default, version headers inserted in C files + `vc-static-header-alist' By default, version headers inserted in C files get stuffed in a static string area so that ident(RCS/CVS) or what(SCCS) can see them in the compiled object code. You can override this by setting this variable to nil, or change the header template by changing it. - vc-command-messages if non-nil, display run messages from the + `vc-command-messages' if non-nil, display run messages from the actual version-control utilities (this is intended primarily for people hacking vc itself). " (interactive) (set-syntax-table text-mode-syntax-table) - (use-local-map vc-log-entry-mode) + (use-local-map vc-log-mode-map) (setq local-abbrev-table text-mode-abbrev-table) (setq major-mode 'vc-log-mode) (setq mode-name "VC-Log") @@ -3148,43 +2577,39 @@ (make-local-variable 'vc-comment-ring-index) (set-buffer-modified-p nil) (setq buffer-file-name nil) - (run-hooks 'text-mode-hook 'vc-log-mode-hook) -) + (run-hooks 'text-mode-hook 'vc-log-mode-hook)) -;; Initialization code, to be done just once at load-time -(if vc-log-entry-mode - nil - (setq vc-log-entry-mode (make-sparse-keymap)) - (define-key vc-log-entry-mode "\M-n" 'vc-next-comment) - (define-key vc-log-entry-mode "\M-p" 'vc-previous-comment) - (define-key vc-log-entry-mode "\M-r" 'vc-comment-search-reverse) - (define-key vc-log-entry-mode "\M-s" 'vc-comment-search-forward) - (define-key vc-log-entry-mode "\C-c\C-c" 'vc-finish-logentry) - ) +(defun vc-log-edit (file) + "Interface between VC and `log-edit'." + (setq default-directory (file-name-directory file)) + (log-edit 'vc-finish-logentry nil + `(lambda () ',(list (file-name-nondirectory file)))) + (set (make-local-variable 'vc-log-file) file) + (make-local-variable 'vc-log-version) + (setq buffer-file-name nil)) ;;; These things should probably be generally available (defun vc-file-tree-walk (dirname func &rest args) "Walk recursively through DIRNAME. -Invoke FUNC f ARGS on each non-directory file f underneath it." +Invoke FUNC f ARGS on each VC-managed file f underneath it." (vc-file-tree-walk-internal (expand-file-name dirname) func args) (message "Traversing directory %s...done" dirname)) (defun vc-file-tree-walk-internal (file func args) (if (not (file-directory-p file)) - (apply func file args) + (if (vc-backend file) (apply func file args)) (message "Traversing directory %s..." (abbreviate-file-name file)) (let ((dir (file-name-as-directory file))) (mapcar - (function - (lambda (f) (or - (string-equal f ".") - (string-equal f "..") - (member f vc-directory-exclusion-list) - (let ((dirf (concat dir f))) - (or - (file-symlink-p dirf) ;; Avoid possible loops - (vc-file-tree-walk-internal dirf func args)))))) + (lambda (f) (or + (string-equal f ".") + (string-equal f "..") + (member f vc-directory-exclusion-list) + (let ((dirf (expand-file-name f dir))) + (or + (file-symlink-p dirf);; Avoid possible loops + (vc-file-tree-walk-internal dirf func args))))) (directory-files dir))))) (provide 'vc) @@ -3195,61 +2620,61 @@ ;;; (Note that this information corresponds to versions 5.x. Some of it ;;; might have been invalidated by the additions to support branching ;;; and RCS keyword lookup. AS, 1995/03/24) -;;; +;;; ;;; A fundamental problem in VC is that there are time windows between ;;; vc-next-action's computations of the file's version-control state and ;;; the actions that change it. This is a window open to lossage in a ;;; multi-user environment; someone else could nip in and change the state ;;; of the master during it. -;;; +;;; ;;; The performance problem is that rlog/prs calls are very expensive; we want ;;; to avoid them as much as possible. -;;; +;;; ;;; ANALYSIS: -;;; +;;; ;;; The performance problem, it turns out, simplifies in practice to the -;;; problem of making vc-locking-user fast. The two other functions that call +;;; problem of making vc-state fast. The two other functions that call ;;; prs/rlog will not be so commonly used that the slowdown is a problem; one ;;; makes snapshots, the other deletes the calling user's last change in the ;;; master. -;;; +;;; ;;; The race condition implies that we have to either (a) lock the master ;;; during the entire execution of vc-next-action, or (b) detect and ;;; recover from errors resulting from dispatch on an out-of-date state. -;;; +;;; ;;; Alternative (a) appears to be infeasible. The problem is that we can't ;;; guarantee that the lock will ever be removed. Suppose a user starts a ;;; checkin, the change message buffer pops up, and the user, having wandered ;;; off to do something else, simply forgets about it? -;;; +;;; ;;; Alternative (b), on the other hand, works well with a cheap way to speed up -;;; vc-locking-user. Usually, if a file is registered, we can read its locked/ +;;; vc-state. Usually, if a file is registered, we can read its locked/ ;;; unlocked state and its current owner from its permissions. -;;; +;;; ;;; This shortcut will fail if someone has manually changed the workfile's ;;; permissions; also if developers are munging the workfile in several ;;; directories, with symlinks to a master (in this latter case, the ;;; permissions shortcut will fail to detect a lock asserted from another ;;; directory). -;;; +;;; ;;; Note that these cases correspond exactly to the errors which could happen ;;; because of a competing checkin/checkout race in between two instances of ;;; vc-next-action. -;;; +;;; ;;; For VC's purposes, a workfile/master pair may have the following states: -;;; +;;; ;;; A. Unregistered. There is a workfile, there is no master. -;;; +;;; ;;; B. Registered and not locked by anyone. -;;; +;;; ;;; C. Locked by calling user and unchanged. -;;; +;;; ;;; D. Locked by the calling user and changed. -;;; +;;; ;;; E. Locked by someone other than the calling user. -;;; +;;; ;;; This makes for 25 states and 20 error conditions. Here's the matrix: -;;; +;;; ;;; VC's idea of state ;;; | ;;; V Actual state RCS action SCCS action Effect @@ -3259,280 +2684,280 @@ ;;; C 9 10 . 11 12 co -u unget; get revert ;;; D 13 14 15 . 16 ci -u -m delta -y; get checkin ;;; E 17 18 19 20 . rcs -u -M -l unget -n ; get -g steal lock -;;; +;;; ;;; All commands take the master file name as a last argument (not shown). -;;; +;;; ;;; In the discussion below, a "self-race" is a pathological situation in ;;; which VC operations are being attempted simultaneously by two or more ;;; Emacsen running under the same username. -;;; +;;; ;;; The vc-next-action code has the following windows: -;;; +;;; ;;; Window P: ;;; Between the check for existence of a master file and the call to ;;; admin/checkin in vc-buffer-admin (apparent state A). This window may ;;; never close if the initial-comment feature is on. -;;; +;;; ;;; Window Q: ;;; Between the call to vc-workfile-unchanged-p in and the immediately ;;; following revert (apparent state C). -;;; +;;; ;;; Window R: ;;; Between the call to vc-workfile-unchanged-p in and the following ;;; checkin (apparent state D). This window may never close. -;;; +;;; ;;; Window S: ;;; Between the unlock and the immediately following checkout during a ;;; revert operation (apparent state C). Included in window Q. -;;; +;;; ;;; Window T: -;;; Between vc-locking-user and the following checkout (apparent state B). -;;; +;;; Between vc-state and the following checkout (apparent state B). +;;; ;;; Window U: -;;; Between vc-locking-user and the following revert (apparent state C). +;;; Between vc-state and the following revert (apparent state C). ;;; Includes windows Q and S. -;;; +;;; ;;; Window V: -;;; Between vc-locking-user and the following checkin (apparent state +;;; Between vc-state and the following checkin (apparent state ;;; D). This window may never be closed if the user fails to complete the ;;; checkin message. Includes window R. -;;; +;;; ;;; Window W: -;;; Between vc-locking-user and the following steal-lock (apparent +;;; Between vc-state and the following steal-lock (apparent ;;; state E). This window may never close if the user fails to complete ;;; the steal-lock message. Includes window X. -;;; +;;; ;;; Window X: ;;; Between the unlock and the immediately following re-lock during a -;;; steal-lock operation (apparent state E). This window may never cloce +;;; steal-lock operation (apparent state E). This window may never close ;;; if the user fails to complete the steal-lock message. -;;; +;;; ;;; Errors: -;;; +;;; ;;; Apparent state A --- ;;; ;;; 1. File looked unregistered but is actually registered and not locked. -;;; +;;; ;;; Potential cause: someone else's admin during window P, with ;;; caller's admin happening before their checkout. -;;; +;;; ;;; RCS: Prior to version 5.6.4, ci fails with message ;;; "no lock set by ". From 5.6.4 onwards, VC uses the new ;;; ci -i option and the message is ",v: already exists". ;;; SCCS: admin will fail with error (ad19). -;;; +;;; ;;; We can let these errors be passed up to the user. -;;; +;;; ;;; 2. File looked unregistered but is actually locked by caller, unchanged. -;;; +;;; ;;; Potential cause: self-race during window P. -;;; +;;; ;;; RCS: Prior to version 5.6.4, reverts the file to the last saved ;;; version and unlocks it. From 5.6.4 onwards, VC uses the new ;;; ci -i option, failing with message ",v: already exists". ;;; SCCS: will fail with error (ad19). -;;; +;;; ;;; Either of these consequences is acceptable. -;;; +;;; ;;; 3. File looked unregistered but is actually locked by caller, changed. -;;; +;;; ;;; Potential cause: self-race during window P. -;;; -;;; RCS: Prior to version 5.6.4, VC registers the caller's workfile as -;;; a delta with a null change comment (the -t- switch will be +;;; +;;; RCS: Prior to version 5.6.4, VC registers the caller's workfile as +;;; a delta with a null change comment (the -t- switch will be ;;; ignored). From 5.6.4 onwards, VC uses the new ci -i option, ;;; failing with message ",v: already exists". ;;; SCCS: will fail with error (ad19). -;;; +;;; ;;; 4. File looked unregistered but is locked by someone else. -;;; +;;; ;;; Potential cause: someone else's admin during window P, with ;;; caller's admin happening *after* their checkout. -;;; -;;; RCS: Prior to version 5.6.4, ci fails with a -;;; "no lock set by " message. From 5.6.4 onwards, -;;; VC uses the new ci -i option, failing with message +;;; +;;; RCS: Prior to version 5.6.4, ci fails with a +;;; "no lock set by " message. From 5.6.4 onwards, +;;; VC uses the new ci -i option, failing with message ;;; ",v: already exists". ;;; SCCS: will fail with error (ad19). -;;; +;;; ;;; We can let these errors be passed up to the user. -;;; +;;; ;;; Apparent state B --- ;;; ;;; 5. File looked registered and not locked, but is actually unregistered. -;;; +;;; ;;; Potential cause: master file got nuked during window P. -;;; +;;; ;;; RCS: will fail with "RCS/: No such file or directory" ;;; SCCS: will fail with error ut4. -;;; +;;; ;;; We can let these errors be passed up to the user. -;;; +;;; ;;; 6. File looked registered and not locked, but is actually locked by the ;;; calling user and unchanged. -;;; +;;; ;;; Potential cause: self-race during window T. -;;; +;;; ;;; RCS: in the same directory as the previous workfile, co -l will fail ;;; with "co error: writable foo exists; checkout aborted". In any other ;;; directory, checkout will succeed. ;;; SCCS: will fail with ge17. -;;; +;;; ;;; Either of these consequences is acceptable. -;;; +;;; ;;; 7. File looked registered and not locked, but is actually locked by the ;;; calling user and changed. -;;; +;;; ;;; As case 6. -;;; +;;; ;;; 8. File looked registered and not locked, but is actually locked by another ;;; user. -;;; +;;; ;;; Potential cause: someone else checks it out during window T. -;;; +;;; ;;; RCS: co error: revision 1.3 already locked by ;;; SCCS: fails with ge4 (in directory) or ut7 (outside it). -;;; +;;; ;;; We can let these errors be passed up to the user. -;;; +;;; ;;; Apparent state C --- ;;; ;;; 9. File looks locked by calling user and unchanged, but is unregistered. -;;; +;;; ;;; As case 5. -;;; +;;; ;;; 10. File looks locked by calling user and unchanged, but is actually not ;;; locked. -;;; +;;; ;;; Potential cause: a self-race in window U, or by the revert's ;;; landing during window X of some other user's steal-lock or window S ;;; of another user's revert. -;;; +;;; ;;; RCS: succeeds, refreshing the file from the identical version in ;;; the master. ;;; SCCS: fails with error ut4 (p file nonexistent). ;;; ;;; Either of these consequences is acceptable. -;;; +;;; ;;; 11. File is locked by calling user. It looks unchanged, but is actually ;;; changed. -;;; +;;; ;;; Potential cause: the file would have to be touched by a self-race ;;; during window Q. -;;; +;;; ;;; The revert will succeed, removing whatever changes came with ;;; the touch. It is theoretically possible that work could be lost. -;;; +;;; ;;; 12. File looks like it's locked by the calling user and unchanged, but ;;; it's actually locked by someone else. -;;; +;;; ;;; Potential cause: a steal-lock in window V. -;;; +;;; ;;; RCS: co error: revision locked by ; use co -r or rcs -u ;;; SCCS: fails with error un2 -;;; +;;; ;;; We can pass these errors up to the user. -;;; +;;; ;;; Apparent state D --- ;;; ;;; 13. File looks like it's locked by the calling user and changed, but it's ;;; actually unregistered. -;;; +;;; ;;; Potential cause: master file got nuked during window P. -;;; -;;; RCS: Prior to version 5.6.4, checks in the user's version as an +;;; +;;; RCS: Prior to version 5.6.4, checks in the user's version as an ;;; initial delta. From 5.6.4 onwards, VC uses the new ci -j ;;; option, failing with message "no such file or directory". ;;; SCCS: will fail with error ut4. ;;; ;;; This case is kind of nasty. Under RCS prior to version 5.6.4, ;;; VC may fail to detect the loss of previous version information. -;;; +;;; ;;; 14. File looks like it's locked by the calling user and changed, but it's ;;; actually unlocked. -;;; +;;; ;;; Potential cause: self-race in window V, or the checkin happening ;;; during the window X of someone else's steal-lock or window S of ;;; someone else's revert. -;;; +;;; ;;; RCS: ci will fail with "no lock set by ". ;;; SCCS: delta will fail with error ut4. -;;; +;;; ;;; 15. File looks like it's locked by the calling user and changed, but it's ;;; actually locked by the calling user and unchanged. -;;; +;;; ;;; Potential cause: another self-race --- a whole checkin/checkout ;;; sequence by the calling user would have to land in window R. -;;; +;;; ;;; SCCS: checks in a redundant delta and leaves the file unlocked as usual. ;;; RCS: reverts to the file state as of the second user's checkin, leaving ;;; the file unlocked. ;;; ;;; It is theoretically possible that work could be lost under RCS. -;;; +;;; ;;; 16. File looks like it's locked by the calling user and changed, but it's ;;; actually locked by a different user. -;;; +;;; ;;; RCS: ci error: no lock set by ;;; SCCS: unget will fail with error un2 -;;; +;;; ;;; We can pass these errors up to the user. -;;; +;;; ;;; Apparent state E --- ;;; ;;; 17. File looks like it's locked by some other user, but it's actually ;;; unregistered. -;;; +;;; ;;; As case 13. -;;; +;;; ;;; 18. File looks like it's locked by some other user, but it's actually ;;; unlocked. -;;; +;;; ;;; Potential cause: someone released a lock during window W. -;;; +;;; ;;; RCS: The calling user will get the lock on the file. ;;; SCCS: unget -n will fail with cm4. -;;; +;;; ;;; Either of these consequences will be OK. -;;; +;;; ;;; 19. File looks like it's locked by some other user, but it's actually ;;; locked by the calling user and unchanged. -;;; +;;; ;;; Potential cause: the other user relinquishing a lock followed by ;;; a self-race, both in window W. -;;; +;;; ;;; Under both RCS and SCCS, both unlock and lock will succeed, making ;;; the sequence a no-op. -;;; +;;; ;;; 20. File looks like it's locked by some other user, but it's actually ;;; locked by the calling user and changed. -;;; +;;; ;;; As case 19. -;;; +;;; ;;; PROBLEM CASES: -;;; +;;; ;;; In order of decreasing severity: -;;; +;;; ;;; Cases 11 and 15 are the only ones that potentially lose work. ;;; They would require a self-race for this to happen. -;;; +;;; ;;; Case 13 in RCS loses information about previous deltas, retaining ;;; only the information in the current workfile. This can only happen ;;; if the master file gets nuked in window P. -;;; +;;; ;;; Case 3 in RCS and case 15 under SCCS insert a redundant delta with ;;; no change comment in the master. This would require a self-race in ;;; window P or R respectively. -;;; +;;; ;;; Cases 2, 10, 19 and 20 do extra work, but make no changes. -;;; +;;; ;;; Unfortunately, it appears to me that no recovery is possible in these ;;; cases. They don't yield error messages, so there's no way to tell that ;;; a race condition has occurred. -;;; +;;; ;;; All other cases don't change either the workfile or the master, and ;;; trigger command errors which the user will see. -;;; +;;; ;;; Thus, there is no explicit recovery code. ;;; vc.el ends here