-;;; vc.el --- drive a version-control system from within Emacs
-
-;; Copyright (C) 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc.
-
-;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
-;; Maintainer: Andre Spiegel <spiegel@inf.fu-berlin.de>
-
-;; $Id: vc.el,v 1.252 1999/09/02 12:50:28 eliz Exp rms $
-
-;; This file is part of GNU Emacs.
-
-;; GNU Emacs is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-
-;; GNU Emacs is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-
-;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Commentary:
-
-;; This mode is fully documented in the Emacs user's manual.
-;;
-;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>.
-;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>,
-;; and Richard Stallman contributed valuable criticism, support, and testing.
-;; CVS support was added by Per Cederqvist <ceder@lysator.liu.se>
-;; in Jan-Feb 1994. Further enhancements came from ttn@netcom.com and
-;; Andre Spiegel <spiegel@inf.fu-berlin.de>.
-;;
-;; 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
-;; 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.
-;;
-;; You can support the RCS -x option by adding pairs to the
-;; vc-master-templates list.
-;;
-;; Proper function of the SCCS diff commands requires the shellscript vcdiff
-;; to be installed somewhere on Emacs's path for executables.
-;;
-;; 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
-;; vc's back is turned, or move/rename master files while vc is running,
-;; vc may get seriously confused. Don't do these things!
-;;
-;; Developer's notes on some concurrency issues are included at the end of
-;; the file.
-
-;;; Code:
-
-(require 'vc-hooks)
-(require 'ring)
-(eval-when-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
- "Version-control system in Emacs."
- :group 'tools)
-
-(defcustom vc-suppress-confirm nil
- "*If non-nil, treat user as expert; suppress yes-no prompts on some things."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-delete-logbuf-window t
- "*If non-nil, delete the *VC-log* buffer and window after each logical action.
-If nil, bury that buffer instead.
-This is most useful if you have multiple windows on a frame and would like to
-preserve the setting."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-initial-comment nil
- "*If non-nil, prompt for initial comment when a file is registered."
- :type 'boolean
- :group 'vc)
-
-(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]."
- :type 'string
- :group 'vc
- :version "20.3")
-
-(defcustom vc-command-messages nil
- "*If non-nil, display run messages from back-end commands."
- :type 'boolean
- :group 'vc)
-
-(defcustom vc-checkin-switches nil
- "*A string or list of strings specifying extra switches for checkin.
-These are passed to the checkin program by \\[vc-checkin]."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :group 'vc)
-
-(defcustom vc-checkout-switches nil
- "*A string or list of strings specifying extra switches for checkout.
-These are passed to the checkout program by \\[vc-checkout]."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :group 'vc)
-
-(defcustom vc-register-switches nil
- "*A string or list of strings; extra switches for registering a file.
-These are passed to the checkin program by \\[vc-register]."
- :type '(choice (const :tag "None" nil)
- (string :tag "Argument String")
- (repeat :tag "Argument List"
- :value ("")
- string))
- :group 'vc)
-
-(defcustom vc-dired-recurse t
- "*If non-nil, show directory trees recursively in VC Dired."
- :type 'boolean
- :group 'vc
- :version "20.3")
-
-(defcustom vc-dired-terse-display t
- "*If non-nil, show only locked files in VC Dired."
- :type 'boolean
- :group 'vc
- :version "20.3")
-
-(defcustom vc-directory-exclusion-list '("SCCS" "RCS" "CVS")
- "*List of directory names to be ignored while recursively walking file trees."
- :type '(repeat string)
- :group 'vc)
-
-(defconst vc-maximum-comment-ring-size 32
- "Maximum number of saved comments in the comment ring.")
-
-;;; This is duplicated in diff.el.
-(defvar diff-switches "-c"
- "*A string or list of strings specifying switches to be be passed to diff.")
-
-(defcustom vc-annotate-color-map
- '(( 26.3672 . "#FF0000")
- ( 52.7344 . "#FF3800")
- ( 79.1016 . "#FF7000")
- (105.4688 . "#FFA800")
- (131.8359 . "#FFE000")
- (158.2031 . "#E7FF00")
- (184.5703 . "#AFFF00")
- (210.9375 . "#77FF00")
- (237.3047 . "#3FFF00")
- (263.6719 . "#07FF00")
- (290.0391 . "#00FF31")
- (316.4063 . "#00FF69")
- (342.7734 . "#00FFA1")
- (369.1406 . "#00FFD9")
- (395.5078 . "#00EEFF")
- (421.8750 . "#00B6FF")
- (448.2422 . "#007EFF"))
- "*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
- :group 'vc)
-
-(defcustom vc-annotate-very-old-color "#0046FF"
- "*Color for lines older than CAR of last cons in `vc-annotate-color-map'."
- :type 'string
- :group 'vc)
-
-(defcustom vc-annotate-background "black"
- "*Background color for \\[vc-annotate].
-Default color is used if nil."
- :type 'string
- :group 'vc)
-
-(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
- :group 'vc)
-
-;;;###autoload
-(defcustom vc-annotate-mode-hook nil
- "*Hooks to run when VC-Annotate mode is turned on."
- :type 'hook
- :group 'vc)
-
-;; 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'."
- :type '(repeat (cons :format "%v"
- (regexp :tag "File Type")
- (string :tag "Header String")))
- :group 'vc)
-
-(defcustom vc-comment-alist
- '((nroff-mode ".\\\"" ""))
- "*Special comment delimiters to be used in generating vc headers only.
-Add an entry in this list if you need to override the normal comment-start
-and comment-end variables. This will only be necessary if the mode language
-is sensitive to blank lines."
- :type '(repeat (list :format "%v"
- (symbol :tag "Mode")
- (string :tag "Comment Start")
- (string :tag "Comment End")))
- :group 'vc)
-
-;; Default is to be extra careful for super-user.
-(defcustom vc-checkout-carefully (= (user-uid) 0)
- "*Non-nil means be extra-careful in checkout.
-Verify that the file really is not locked
-and that its contents match what the master file says."
- :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)
-
-(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)
-
-(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)
-
-;; 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)
-;; 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)
-(defvar vc-parent-buffer-name nil)
-
-(defvar vc-log-file)
-(defvar vc-log-version)
-
-(defconst vc-name-assoc-file "VC-names")
-
-(defvar vc-dired-mode nil)
-(make-variable-buffer-local 'vc-dired-mode)
-
-(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)))
-
-(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
-
-(defun vc-trunk-p (rev)
- ;; 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
- (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
- (substring rev 0 (string-match "\\.[0-9]+\\'" rev)))
-
-(defun vc-minor-part (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
- (let ((branch (vc-branch-part rev))
- (minor-num (string-to-number (vc-minor-part rev))))
- (if (> minor-num 1)
- ;; version does probably not start a branch or release
- (concat branch "." (number-to-string (1- minor-num)))
- (if (vc-trunk-p rev)
- ;; we are at the beginning of the trunk --
- ;; don't know anything to return here
- ""
- ;; we are at the beginning of a branch --
- ;; return version of starting point
- (vc-branch-part branch)))))
-
-;; File property caching
-
-(defun vc-clear-context ()
- "Clear all cached file properties and the comment ring."
- (interactive)
- (fillarray vc-file-prop-obarray nil)
- ;; Note: there is potential for minor lossage here if there is an open
- ;; 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))
-
-;;; 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
-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)))))
- (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.
-This macro uses `with-vc-file', passing args to it.
-However, before executing BODY, find FILE, and after BODY, save buffer."
- `(with-vc-file
- ,file ,comment
- (find-file ,file)
- ,@body
- (save-buffer)))
-
-(defun vc-ensure-vc-buffer ()
- ;; 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
- (pop-to-buffer vc-parent-buffer))
- (if (not (buffer-file-name))
- (error "Buffer %s is not associated with a file" (buffer-name))
- (if (not (vc-backend (buffer-file-name)))
- (error "File %s is not under version control" (buffer-file-name))))))
-
-(defvar vc-binary-assoc nil)
-(defvar vc-binary-suffixes
- (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))
- (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)
-
- (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)
- )
-
-;;; 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)
- (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)
- (let ((context-string (nth 2 context)))
- (if (equal "" context-string)
- (point-max)
- (save-excursion
- (let ((diff (- (nth 1 context) (buffer-size))))
- (if (< diff 0) (setq diff (- diff)))
- (goto-char (nth 0 context))
- (if (or (search-forward context-string nil t)
- ;; Can't use search-backward since the match may continue
- ;; after point.
- (progn (goto-char (- (point) diff (length context-string)))
- ;; goto-char doesn't signal an error at
- ;; beginning of buffer like backward-char would
- (search-forward context-string nil t)))
- ;; to beginning of OSTRING
- (- (point) (length context-string))))))))
-
-(defun vc-context-matches-p (posn context)
- ;; Returns t if POSN matches CONTEXT, nil otherwise.
- (let* ((context-string (nth 2 context))
- (len (length context-string))
- (end (+ posn len)))
- (if (> end (1+ (buffer-size)))
- nil
- (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.
- (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))
- (vc-position-context (mark-marker))))
- ;; Make the right thing happen in transient-mark-mode.
- (mark-active nil)
- ;; We may want to reparse the compilation buffer after revert
- (reparse (and (boundp 'compilation-error-list) ;compile loaded
- (let ((curbuf (current-buffer)))
- ;; Construct a list; each elt is nil or a buffer
- ;; iff that buffer is a compilation output buffer
- ;; that contains markers into the current buffer.
- (save-excursion
- (mapcar (function
- (lambda (buffer)
- (set-buffer buffer)
- (let ((errors (or
- compilation-old-error-list
- compilation-error-list))
- (buffer-error-marked-p nil))
- (while (and (consp errors)
- (not buffer-error-marked-p))
- (and (markerp (cdr (car errors)))
- (eq buffer
- (marker-buffer
- (cdr (car errors))))
- (setq buffer-error-marked-p t))
- (setq errors (cdr errors)))
- (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.
- (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))
- (let ((compilation-last-buffer (current-buffer)) ;select buffer
- ;; Record the position in the compilation buffer of
- ;; the last error next-error went to.
- (error-pos (marker-position
- (car (car-safe compilation-error-list)))))
- ;; Reparse the error messages as far as they were parsed before.
- (compile-reinitialize-errors '(4) compilation-parsing-end)
- ;; Move the pointer up to find the error we were at before
- ;; reparsing. Now next-error should properly go to the next one.
- (while (and compilation-error-list
- (/= error-pos (car (car compilation-error-list))))
- (setq compilation-error-list (cdr compilation-error-list))))))
- (setq reparse (cdr reparse)))
-
- ;; if necessary, restore point and mark
- (if (not (vc-context-matches-p (point) point-context))
- (let ((new-point (vc-find-position-by-context point-context)))
- (if new-point (goto-char new-point))))
- (and mark-active
- mark-context
- (not (vc-context-matches-p (mark) mark-context))
- (let ((new-mark (vc-find-position-by-context mark-context)))
- (if new-mark (set-mark new-mark))))))
-
-(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.
- (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 --
- ;; in this case, vc-restore-buffer-context gives it a second try.
- (save-excursion
- ;; 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.
- (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
- (error "Aborted")))))
-
-
-(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
- ;; 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)))))
-
-(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)
- )))))
-
-(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.
- (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))
- (set-window-configuration vc-dired-window-configuration)
- (message "Processing %s...done" file))
- nil t))
- (dired-move-to-filename))
-
-;; Here's the major entry point.
-
-;;;###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,
-it will operate on the file in the current line.
- 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.
-
-For RCS and SCCS files:
- If the file is not already registered, this registers it for version
-control.
- If the file is registered and not locked by anyone, this checks out
-a writable and locked file ready for editing.
- If the file is checked out and locked by the calling user, this
-first checks to see if the file has changed since checkout. If not,
-it performs a revert.
- If the file has been changed, this pops up a buffer for entry
-of a log message; when the message has been entered, it checks in the
-resulting changes along with the log message as change commentary. If
-the variable `vc-keep-workfiles' is non-nil (which is its default), a
-read-only copy of the changed file is left in place afterwards.
- If the file is registered and locked by someone else, you are given
-the option to steal the lock.
-
-For CVS files:
- If the file is not already registered, this registers it for version
-control. This does a \"cvs add\", but no \"cvs commit\".
- If the file is added but not committed, it is committed.
- If your working file is changed, but the repository file is
-unchanged, this pops up a buffer for entry of a log message; when the
-message has been entered, it checks in the resulting changes along
-with the logmessage as change commentary. A writable file is retained.
- If the repository file is changed, you are asked if you want to
-merge in the changes into your working copy."
-
- (interactive "P")
- (catch 'nogo
- (if vc-dired-mode
- (let ((files (dired-get-marked-files)))
- (set (make-local-variable 'vc-dired-window-configuration)
- (current-window-configuration))
- (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) "@" ""))))
- files ""))
- (vc-next-action-dired nil nil "dummy")
- (vc-start-entry nil nil nil
- "Enter a change comment for the marked files."
- 'vc-next-action-dired))
- (throw 'nogo nil)))
- (while vc-parent-buffer
- (pop-to-buffer vc-parent-buffer))
- (if buffer-file-name
- (vc-next-action-on-file buffer-file-name verbose)
- (error "Buffer %s is not associated with a file" (buffer-name)))))
-
-;;; These functions help the vc-next-action entry point
-
-(defun vc-checkout-writable-buffer (&optional file rev)
- "Retrieve a writable copy of the latest version of the current buffer's file."
- (vc-checkout (or file (buffer-file-name)) t rev)
- )
-
-;;;###autoload
-(defun vc-register (&optional override comment)
- "Register the current file into your version-control system."
- (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")))
- ;; 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))
- (zerop (buffer-size))
- (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)))
- )
-
-(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!
- (and (string= buffer-file-name file)
- (if keep
- (progn
- (vc-revert-buffer1 t noquery)
- (and view-read-only
- (if (file-writable-p file)
- (and view-mode
- (let ((view-old-buffer-read-only nil))
- (view-mode-exit)))
- (and (not view-mode)
- (not (eq (get major-mode 'mode-class) 'special))
- (view-mode-enter))))
- (vc-mode-line buffer-file-name))
- (kill-buffer (current-buffer)))))
-
-(defun vc-resynch-buffer (file &optional keep noquery)
- ;; 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))))))
-
-(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.
- (let ((parent (if file (find-file-noselect file) (current-buffer))))
- (if vc-before-checkin-hook
- (if file
- (save-excursion
- (set-buffer parent)
- (run-hooks 'vc-before-checkin-hook))
- (run-hooks 'vc-before-checkin-hook)))
- (if comment
- (set-buffer (get-buffer-create "*VC-log*"))
- (pop-to-buffer (get-buffer-create "*VC-log*")))
- (set (make-local-variable 'vc-parent-buffer) parent)
- (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)
- (make-local-variable 'vc-log-after-operation-hook)
- (if after-hook
- (setq vc-log-after-operation-hook after-hook))
- (setq vc-log-operation action)
- (setq vc-log-version rev)
- (if comment
- (progn
- (erase-buffer)
- (if (eq comment t)
- (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))
-
-(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)
- (vc-resynch-buffer file t t))
-
-(defun vc-steal-lock (file rev &optional 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*"))
- (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)
- (current-time-string)
- ".\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))))
-
-(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.
-
-Runs the normal hook `vc-checkin-hook'."
- (vc-start-entry file rev comment
- "Enter a change comment." 'vc-backend-checkin
- '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.
-Optional arg (interactive prefix) non-nil means prompt for user name and site.
-Second arg is file name of change log. \
-If nil, uses `change-log-default-name'.
-
-May be useful as a `vc-checkin-hook' to update change logs automatically."
- (interactive (if current-prefix-arg
- (list current-prefix-arg
- (prompt-for-change-log-name))))
- ;; Make sure the defvar for add-log-current-defun-function has been executed
- ;; before binding it.
- (require 'add-log)
- (let (;; Extract the comment first so we get any error before doing anything.
- (comment (ring-ref vc-comment-ring 0))
- ;; Don't let add-change-log-entry insert a defun name.
- (add-log-current-defun-function 'ignore)
- end)
- ;; Call add-log to do half the work.
- (add-change-log-entry whoami file-name t t)
- ;; Insert the VC comment, leaving point before it.
- (setq end (save-excursion (insert comment) (point-marker)))
- (if (looking-at "\\s *\\s(")
- ;; It starts with an open-paren, as in "(foo): Frobbed."
- ;; So remove the ": " add-log inserted.
- (delete-char -2))
- ;; Canonicalize the white space between the file name and comment.
- (just-one-space)
- ;; Indent rest of the text the same way add-log indented the first line.
- (let ((indentation (current-indentation)))
- (save-excursion
- (while (< (point) end)
- (forward-line 1)
- (indent-to indentation))
- (setq end (point))))
- ;; Fill the inserted text, preserving open-parens at bol.
- (let ((paragraph-separate (concat paragraph-separate "\\|\\s *\\s("))
- (paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
- (beginning-of-line)
- (fill-region (point) end))
- ;; Canonicalize the white space at the end of the entry so it is
- ;; separated from the next entry by a single blank line.
- (skip-syntax-forward " " end)
- (delete-char (- (skip-syntax-backward " ")))
- (or (eobp) (looking-at "\n\n")
- (insert "\n"))))
-
-(defun vc-finish-logentry (&optional nocomment)
- "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))
- ))
- ;; 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)))
- (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)
- (log-file vc-log-file)
- (log-version vc-log-version)
- (log-entry (buffer-string))
- (after-hook vc-log-after-operation-hook)
- (tmp-vc-parent-buffer vc-parent-buffer))
- (pop-to-buffer vc-parent-buffer)
- ;; OK, do it to it
- (save-excursion
- (funcall log-operation
- log-file
- log-version
- log-entry))
- ;; Remove checkin window (after the checkin so that if that fails
- ;; we don't zap the *VC-log* buffer and the typing therein).
- (let ((logbuf (get-buffer "*VC-log*")))
- (cond ((and logbuf vc-delete-logbuf-window)
- (delete-windows-on logbuf (selected-frame))
- ;; Kill buffer and delete any other dedicated windows/frames.
- (kill-buffer logbuf))
- (t (pop-to-buffer "*VC-log*")
- (bury-buffer)
- (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
- (dired-move-to-filename))
- (run-hooks after-hook 'vc-finish-logentry-hook)))
-
-;; Code for access to the comment ring
-
-(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))))))
-
-(defun vc-next-comment (arg)
- "Cycle forwards through comment history."
- (interactive "*p")
- (vc-previous-comment (- arg)))
-
-(defun vc-comment-search-reverse (str)
- "Searches backwards 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 -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")))))
-
-(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")))))
-
-;; 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
-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."
- (interactive (list current-prefix-arg t))
- (vc-ensure-vc-buffer)
- (if historic
- (call-interactively 'vc-version-diff)
- (let ((file buffer-file-name)
- unchanged)
- (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))))
-
-(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
- (let ((file (read-file-name (if buffer-file-name
- "File or dir to diff: (default visited file) "
- "File or dir to diff: ")
- default-directory buffer-file-name t))
- (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)
- nil)
- ;; if the file is locked, use current version as older version
- ((vc-locking-user 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)))
- (setq rel2-default (vc-workfile-version file))))
- ;; construct argument list
- (list file
- (read-string (if rel1-default
- (concat "Older version: (default "
- rel1-default ") ")
- "Older version: ")
- nil nil rel1-default)
- (read-string (if rel2-default
- (concat "Newer version: (default "
- rel2-default ") ")
- "Newer version (default: current source): ")
- nil nil rel2-default))))
- (if (string-equal rel1 "") (setq rel1 nil))
- (if (string-equal rel2 "") (setq rel2 nil))
- (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)
- (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)
- (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*"))))
-
-;;;###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): ")
- (vc-ensure-vc-buffer)
- (let* ((version (if (string-equal rev "")
- (vc-latest-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))
- (find-file-other-window filename)))
-
-;; Header-insertion code
-
-;;;###autoload
-(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'."
- (interactive)
- (vc-ensure-vc-buffer)
- (save-excursion
- (save-restriction
- (widen)
- (if (or (not (vc-check-headers))
- (y-or-n-p "Version headers already exist. Insert another set? "))
- (progn
- (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")))
- hdstrings)
- (if vc-static-header-alist
- (mapcar (function (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)))
-
-;;;###autoload
-(defun vc-merge ()
- (interactive)
- (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))))
- (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"))))))
-
-(defvar vc-ediff-windows)
-(defvar vc-ediff-result)
-
-;;;###autoload
-(defun vc-resolve-conflicts (&optional name-A name-B)
- "Invoke ediff to resolve conflicts in the current buffer.
-The conflicts must be marked with rcsmerge conflict markers."
- (interactive)
- (vc-ensure-vc-buffer)
- (let* ((found nil)
- (file-name (file-name-nondirectory buffer-file-name))
- (your-buffer (generate-new-buffer
- (concat "*" file-name
- " " (or name-A "WORKFILE") "*")))
- (other-buffer (generate-new-buffer
- (concat "*" file-name
- " " (or name-B "CHECKED-IN") "*")))
- (result-buffer (current-buffer)))
- (save-excursion
- (set-buffer your-buffer)
- (erase-buffer)
- (insert-buffer result-buffer)
- (goto-char (point-min))
- (while (re-search-forward (concat "^<<<<<<< "
- (regexp-quote file-name) "\n") nil t)
- (setq found t)
- (replace-match "")
- (if (not (re-search-forward "^=======\n" nil t))
- (error "Malformed conflict marker"))
- (replace-match "")
- (let ((start (point)))
- (if (not (re-search-forward "^>>>>>>> [0-9.]+\n" nil t))
- (error "Malformed conflict marker"))
- (delete-region start (point))))
- (if (not found)
- (progn
- (kill-buffer your-buffer)
- (kill-buffer other-buffer)
- (error "No conflict markers found")))
- (set-buffer other-buffer)
- (erase-buffer)
- (insert-buffer result-buffer)
- (goto-char (point-min))
- (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))
- (error "Malformed conflict marker"))
- (delete-region start (point))
- (if (not (re-search-forward "^>>>>>>> [0-9.]+\n" nil t))
- (error "Malformed conflict marker"))
- (replace-match "")))
- (let ((config (current-window-configuration))
- (ediff-default-variant 'default-B))
-
- ;; Fire up ediff.
-
- (set-buffer (ediff-merge-buffers your-buffer other-buffer))
-
- ;; Ediff is now set up, and we are in the control buffer.
- ;; Do a few further adjustments and take precautions for exit.
-
- (make-local-variable 'vc-ediff-windows)
- (setq vc-ediff-windows config)
- (make-local-variable 'vc-ediff-result)
- (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")))))
- (message "Please resolve conflicts now; exit ediff when done")
- nil))))
-
-;; The VC directory major mode. Coopt Dired for this.
-;; All VC commands get mapped into logical equivalents.
-
-(defvar vc-dired-switches)
-(defvar vc-dired-terse-mode)
-
-(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
-`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.
-There is a special command, `*l', to mark all files currently locked."
- (make-local-hook 'dired-after-readin-hook)
- (add-hook 'dired-after-readin-hook 'vc-dired-hook nil t)
- ;; 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*
- ((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.
- ;; The purpose is to match a Kanji character.
- (k "[^\0-\177]")
- ;; (k "[^\x00-\x7f\x80-\xff]")
- (s " ")
- (yyyy "[0-9][0-9][0-9][0-9]")
- (mm "[ 0-1][0-9]")
- (dd "[ 0-3][0-9]")
- (HH:MM "[ 0-2][0-9]:[0-5][0-9]")
- (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)))
- (and (boundp 'vc-dired-switches)
- vc-dired-switches
- (set (make-local-variable 'dired-actual-switches)
- vc-dired-switches))
- (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)
- (if (not vc-dired-mode)
- nil
- (setq vc-dired-terse-mode (not vc-dired-terse-mode))
- (if vc-dired-terse-mode
- (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)))
- "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-dired-reformat-line (x)
- ;; Reformat a directory-listing line, replacing 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)
- (setq limit (point))
- (goto-char pos)
- (when
- (or
- (re-search-forward ;; owner and group
- "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[^ ]+ +[0-9]+\\( .*\\)"
- limit t)
- (re-search-forward ;; only owner displayed
- "^\\(..[drwxlts-]+ \\) *[0-9]+ [^ ]+ +[0-9]+\\( .*\\)"
- limit t)
- (re-search-forward ;; OS/2 -l format, no links, owner, group
- "^\\(..[drwxlts-]+ \\) *[0-9]+\\( .*\\)"
- limit t))
- (setq perm (match-string 1)
- date-and-file (match-string 2))
- (setq x (substring (concat x " ") 0 10))
- (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.
- (message "Getting version information... ")
- (let (subdir filename (buffer-read-only nil) cvs-dir)
- (goto-char (point-min))
- (while (not (eq (point) (point-max)))
- (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))
- (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
- ((setq filename (dired-get-filename nil t))
- (cond
- ;; subdir
- ((file-directory-p filename)
- (cond
- ((member (file-name-nondirectory filename)
- vc-directory-exclusion-list)
- (let ((pos (point)))
- (dired-kill-tree filename)
- (goto-char pos)
- (dired-kill-line)))
- (vc-dired-terse-mode
- ;; 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))
- (progn (forward-line 1) (point))))
- ((string-match "\\`\\.\\.?\\'" (file-name-nondirectory filename))
- (dired-kill-line))
- (t
- (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))
- (forward-line 1))
- (t
- (dired-kill-line))))
- ;; any other line
- (t (forward-line 1))))
- (vc-dired-purge))
- (message "Getting version information... done")
- (save-restriction
- (widen)
- (cond ((eq (count-lines (point-min) (point-max)) 1)
- (goto-char (point-min))
- (message "No files locked under %s" default-directory)))))
-
-(defun vc-dired-purge ()
- ;; Remove empty subdirs
- (let (subdir)
- (goto-char (point-min))
- (while (setq subdir (dired-get-subdir))
- (forward-line 2)
- (if (dired-get-filename nil t)
- (if (not (dired-next-subdir 1 t))
- (goto-char (point-max)))
- (forward-line -2)
- (if (not (string= (dired-current-directory) default-directory))
- (dired-do-kill-lines t "")
- ;; We cannot remove the top level directory.
- ;; Just make it look a little nicer.
- (forward-line 1)
- (kill-line)
- (if (not (dired-next-subdir 1 t))
- (goto-char (point-max))))))
- (goto-char (point-min))))
-
-;;;###autoload
-(defun vc-directory (dirname read-switches)
- (interactive "DDired under VC (directory): \nP")
- (let ((vc-dired-switches (concat dired-listing-switches
- (if vc-dired-recurse "R" ""))))
- (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)
- '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.
- (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)))))))
- 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)))
- (if (stringp result)
- (error "File %s is locked" result)
- (vc-file-tree-walk
- default-directory
- (function (lambda (f) (and
- (vc-name f)
- (vc-backend-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)))))))
- )))))
-
-;; Miscellaneous other entry points
-
-;;;###autoload
-(defun vc-print-log ()
- "List the change log of the current buffer in a window."
- (interactive)
- (vc-ensure-vc-buffer)
- (let ((file buffer-file-name))
- (vc-backend-print-log file)
- (pop-to-buffer (get-buffer-create "*vc*"))
- (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)))))))
-
-;;;###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."
- (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))))
- (set-buffer obuf)
- (vc-backend-revert file)
- (vc-resynch-window file t t)))
-
-;;;###autoload
-(defun vc-cancel-version (norevert)
- "Get rid of most recently checked in version of this file.
-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)))
- (recent (if (vc-trunk-p target) "" (vc-branch-part target)))
- (config (current-window-configuration)) done)
- (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)
- ;; 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.
- (while (not done)
- (condition-case err
- (progn
- (if norevert
- ;; Check out locked, but only to disc, and keep
- ;; modifications in the buffer.
- (vc-backend-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.
- (error (set-buffer "*vc*")
- (goto-char (point-min))
- (if (search-forward "no side branches present for" nil t)
- (progn (setq recent (vc-branch-part recent))
- ;; vc-do-command popped up a window with
- ;; the error message. Get rid of it, by
- ;; restoring the old window configuration.
- (set-window-configuration config))
- ;; No, it was some other error: re-signal it.
- (signal (car err) (cdr err))))))
- ;; If norevert, clear version headers and mark the buffer modified.
- (if norevert
- (progn
- (set-visited-file-name (buffer-file-name))
- (if (not vc-make-backup-files)
- ;; 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)))
- (vc-mode-line (buffer-file-name))))
- (message "Version %s has been removed from the master" target)
- )))
-
-;;;###autoload
-(defun vc-rename-file (old new)
- "Rename file OLD to NEW, and rename its master file likewise."
- (interactive "fVC rename file: \nFRename to: ")
- ;; There are several ways of renaming files under CVS 1.3, but they all
- ;; have serious disadvantages. See the FAQ (available from think.com in
- ;; pub/cvs/). I'd rather send the user an error, than do something he might
- ;; 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)))
- (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....
- (if oldbuf
- (save-excursion
- (set-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
- )
- )
-
-;;;###autoload
-(defun vc-update-change-log (&rest args)
- "Find change log file and add entries from recent RCS/CVS 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.
-
-With prefix arg of C-u, only find log entries for the current buffer's file.
-
-With any numeric prefix arg, find log entries for all currently visited
-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."
- (interactive
- (cond ((consp current-prefix-arg) ;C-u
- (list buffer-file-name))
- (current-prefix-arg ;Numeric argument.
- (let ((files nil)
- (buffers (buffer-list))
- file)
- (while buffers
- (setq file (buffer-file-name (car buffers)))
- (and file (vc-backend file)
- (setq files (cons file files)))
- (setq buffers (cdr buffers)))
- files))
- (t
- ;; `rcs2log' will find the relevant RCS or CVS files
- ;; relative to the curent directory if none supplied.
- nil)))
- (let ((odefault default-directory)
- (changelog (find-change-log))
- ;; Presumably not portable to non-Unixy systems, along with rcs2log:
- (tempfile (make-temp-name
- (expand-file-name "vc"
- (or small-temporary-file-directory
- temporary-file-directory))))
- (full-name (or add-log-full-name
- (user-full-name)
- (user-login-name)
- (format "uid%d" (number-to-string (user-uid)))))
- (mailing-address (or add-log-mailing-address
- user-mail-address)))
- (find-file-other-window changelog)
- (barf-if-buffer-read-only)
- (vc-buffer-sync)
- (undo-boundary)
- (goto-char (point-min))
- (push-mark)
- (message "Computing change log entries...")
- (message "Computing change log entries... %s"
- (unwind-protect
- (progn
- (cd odefault)
- (if (eq 0 (apply 'call-process "rcs2log" 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"
- (pop-to-buffer
- (set-buffer (get-buffer-create "*vc*")))
- (erase-buffer)
- (insert-file tempfile)
- "failed"))
- (cd (file-name-directory changelog))
- (delete-file tempfile)))))
-\f
-;; 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.")
-
-;; Declare globally instead of additional parameter to
-;; temp-buffer-show-function (not possible to pass more than one
-;; parameter).
-(defvar vc-annotate-ratio nil)
-
-(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-mode ()
- "Major mode for buffers displaying output from the CVS `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)
- (message "Redisplaying annotation...")
- (vc-annotate-display (get-buffer (buffer-name)))
- (message "Redisplaying annotation...done"))
-
-(defun vc-annotate-add-menu ()
- "Adds the menu 'Annotate' to the menu bar in VC-Annotate mode."
- (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)
- 0.7585))))
- (setq menu-elements (cdr menu-elements))
- (define-key vc-annotate-mode-menu
- (vector days)
- (cons (format "Span %d days"
- days)
- `(lambda ()
- ,(format "Use colors spanning %d days" days)
- (interactive)
- (message "Redisplaying annotation...")
- (vc-annotate-display
- (get-buffer (buffer-name))
- (vc-annotate-time-span vc-annotate-color-map ,element))
- (message "Redisplaying annotation...done"))))))))
-
-;;;###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.
-
-`vc-annotate-menu-elements' customizes the menu elements of the
-mode-specific menu. `vc-annotate-color-map' and
-`vc-annotate-very-old-color' defines the mapping of time to
-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) "*"))
- (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)))))
- (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)))
- (vc-annotate-car-last-cons (cdr a-list))
- (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 span to each car of every cons
- (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
- 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"
- (let ((i 1)
- (tmp-cons (car a-list)))
- (while (and tmp-cons (< (car tmp-cons) threshold))
- (setq tmp-cons (car (nthcdr i a-list)))
- (setq i (+ i 1)))
- tmp-cons)) ; Return the appropriate value
-
-
-(defun vc-annotate-display (buffer &optional color-map)
- "Do the VC-Annotate display in BUFFER using COLOR-MAP."
-
- ;; 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).
- (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)
-
- (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..69 are 2000..2069.
- ;; Years 70..99 are 1970..1999.
- (year (+ (cond ((> 70 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)
-
- (forward-line 1)
- (setq overlay (make-overlay point (point)))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'vc-annotation t)))))
-
-\f
-;; 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
- (apply 'vc-do-command
- nil 0 "/bin/sh" file 'MASTER "-c"
- ;; Some shells make the "" dummy argument into $0
- ;; while others use the shell's name as $0 and
- ;; use the "" as $1. The if-statement
- ;; converts the latter case to the former.
- (format "if [ x\"$1\" = x ]; then shift; fi; \
- umask %o; exec >\"$1\" || exit; \
- shift; umask %o; exec get \"$@\""
- (logand 511 (lognot vc-modes))
- (logand 511 (lognot (default-file-modes))))
- "" ; dummy argument for shell's $0
- filename
- (if writable "-e")
- "-p"
- (and rev
- (concat "-r" (vc-lookup-triple file rev)))
- switches)
- (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
- (apply 'vc-do-command
- nil 0 "/bin/sh" file 'MASTER "-c"
- ;; See the SCCS case, above, regarding the
- ;; if-statement.
- (format "if [ x\"$1\" = x ]; then shift; fi; \
- umask %o; exec >\"$1\" || exit; \
- shift; umask %o; exec co \"$@\""
- (logand 511 (lognot vc-modes))
- (logand 511 (lognot (default-file-modes))))
- "" ; dummy argument for shell's $0
- filename
- (if writable "-l")
- (concat "-p" rev)
- switches)
- (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
- (apply 'vc-do-command
- nil 0 "/bin/sh" file 'WORKFILE "-c"
- "exec >\"$1\" || exit; shift; exec cvs update \"$@\""
- "" ; dummy argument for shell's $0
- workfile
- (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)
-
- ;; 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)
- (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-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.
- )
- ))
-
-;; 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.
-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-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
-\\[vc-revert-buffer] revert buffer to latest version
-\\[vc-cancel-version] undo latest checkin
-\\[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-update-change-log] add change log entry from recent checkins
-
-While you are entering a change log message for a version, the following
-additional bindings will be in effect.
-
-\\[vc-finish-logentry] proceed with check in, ending log message entry
-
-Whenever you do a checkin, your log comment is added to a ring of
-saved comments. These can be recalled as follows:
-
-\\[vc-next-comment] replace region with next message in comment ring
-\\[vc-previous-comment] replace region with previous message in comment ring
-\\[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.
-
-Global user options:
- 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
- deleted when changes are checked in
-
- vc-suppress-confirm Suppresses some confirmation prompts,
- notably for reversions.
-
- vc-header-alist Which keywords to insert when adding headers
- with \\[vc-insert-headers]. Defaults to
- '(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under
- RCS and CVS.
-
- 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
- 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)
- (setq local-abbrev-table text-mode-abbrev-table)
- (setq major-mode 'vc-log-mode)
- (setq mode-name "VC-Log")
- (make-local-variable 'vc-log-file)
- (setq vc-log-file file)
- (make-local-variable 'vc-log-version)
- (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)
-)
-
-;; 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)
- )
-
-;;; 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."
- (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)
- (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))))))
- (directory-files dir)))))
-
-(provide 'vc)
-
-;;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE
-;;;
-;;; These may be useful to anyone who has to debug or extend the package.
-;;; (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
-;;; 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/
-;;; 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
-;;; A B C D E
-;;; A . 1 2 3 4 ci -u -t- admin -fb -i<file> initial admin
-;;; B 5 . 6 7 8 co -l get -e checkout
-;;; C 9 10 . 11 12 co -u unget; get revert
-;;; D 13 14 15 . 16 ci -u -m<comment> delta -y<comment>; 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).
-;;;
-;;; Window U:
-;;; Between vc-locking-user and the following revert (apparent state C).
-;;; Includes windows Q and S.
-;;;
-;;; Window V:
-;;; Between vc-locking-user 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
-;;; 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
-;;; 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 <user>". From 5.6.4 onwards, VC uses the new
-;;; ci -i option and the message is "<file>,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 "<file>,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
-;;; ignored). From 5.6.4 onwards, VC uses the new ci -i option,
-;;; failing with message "<file>,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 <user>" message. From 5.6.4 onwards,
-;;; VC uses the new ci -i option, failing with message
-;;; "<file>,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/<file>: 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 <user>
-;;; 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 <rev> locked by <user>; 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
-;;; 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 <user>".
-;;; 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 <user>
-;;; 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
+;;; vc.el --- drive a version-control system from within Emacs
+
+;; Copyright (C) 1992,93,94,95,96,97,98,2000,2001 Free Software Foundation, Inc.
+
+;; Author: FSF (see below for full credits)
+;; Maintainer: Andre Spiegel <spiegel@gnu.org>
+;; Keywords: tools
+
+;; $Id: vc.el,v 1.349 2003/02/05 23:13:21 lektu Exp $
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; 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
+;; <esr@snark.thyrsus.com>. Over the years, many people have
+;; contributed substantial amounts of work to VC. These include:
+;; Per Cederqvist <ceder@lysator.liu.se>
+;; Paul Eggert <eggert@twinsun.com>
+;; Sebastian Kremer <sk@thp.uni-koeln.de>
+;; Martin Lorentzson <martinl@gnu.org>
+;; Dave Love <fx@gnu.org>
+;; Stefan Monnier <monnier@cs.yale.edu>
+;; J.D. Smith <jdsmith@alum.mit.edu>
+;; Andre Spiegel <spiegel@gnu.org>
+;; Richard Stallman <rms@gnu.org>
+;; Thien-Thi Nguyen <ttn@gnu.org>
+
+;;; Commentary:
+
+;; This mode is fully documented in the Emacs user's manual.
+;;
+;; 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
+;; 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.
+;;
+;; 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.
+;;
+;; If your site uses the ChangeLog convention supported by Emacs, the
+;; function vc-comment-to-change-log should prove a useful checkin hook.
+;;
+;; 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
+;; vc's back is turned, or move/rename master files while vc is running,
+;; vc may get seriously confused. Don't do these things!
+;;
+;; Developer's notes on some concurrency issues are included at the end of
+;; the file.
+;;
+;; ADDING SUPPORT FOR OTHER BACKENDS
+;;
+;; VC can use arbitrary version control systems as a backend. To add
+;; support for a new backend named SYS, write a library vc-sys.el that
+;; contains functions of the form `vc-sys-...' (note that SYS is in lower
+;; case for the function and library names). VC will use that library if
+;; you put the symbol SYS somewhere into the list of
+;; `vc-handled-backends'. Then, for example, if `vc-sys-registered'
+;; returns non-nil for a file, all SYS-specific versions of VC commands
+;; will be available for that file.
+;;
+;; VC keeps some per-file information in the form of properties (see
+;; vc-file-set/getprop in vc-hooks.el). The backend-specific functions
+;; do not generally need to be aware of these properties. For example,
+;; `vc-sys-workfile-version' should compute the workfile version and
+;; return it; it should not look it up in the property, and it needn't
+;; store it there either. However, if a backend-specific function does
+;; store a value in a property, that value takes precedence over any
+;; value that the generic code might want to set (check for uses of
+;; the macro `with-vc-properties' in vc.el).
+;;
+;; In the list of functions below, each identifier needs to be prepended
+;; with `vc-sys-'. Some of the functions are mandatory (marked with a
+;; `*'), others are optional (`-').
+;;
+;; STATE-QUERYING FUNCTIONS
+;;
+;; * registered (file)
+;;
+;; Return non-nil if FILE is registered in this backend.
+;;
+;; * state (file)
+;;
+;; Return the current version control state of FILE. For a list of
+;; possible values, see `vc-state'. This function should do a full and
+;; reliable state computation; it is usually called immediately after
+;; C-x v v. If you want to use a faster heuristic when visiting a
+;; file, put that into `state-heuristic' below.
+;;
+;; - state-heuristic (file)
+;;
+;; If provided, this function is used to estimate the version control
+;; state of FILE at visiting time. It should be considerably faster
+;; than the implementation of `state'. For a list of possible values,
+;; see the doc string of `vc-state'.
+;;
+;; - dir-state (dir)
+;;
+;; If provided, this function is used to find the version control state
+;; of all files in DIR in a fast way. The function should not return
+;; anything, but rather store the files' states into the corresponding
+;; `vc-state' properties.
+;;
+;; * workfile-version (file)
+;;
+;; Return the current workfile version of FILE.
+;;
+;; - latest-on-branch-p (file)
+;;
+;; Return non-nil if the current workfile version of FILE is the latest
+;; on its branch. The default implementation always returns t, which
+;; means that working with non-current versions is not supported by
+;; default.
+;;
+;; * checkout-model (file)
+;;
+;; Indicate whether FILE needs to be "checked out" before it can be
+;; edited. See `vc-checkout-model' for a list of possible values.
+;;
+;; - 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. (Note that vc-BACKEND-diff must not run
+;; asynchronously in this case.)
+;;
+;; - mode-line-string (file)
+;;
+;; If provided, this function should return the VC-specific mode line
+;; string for FILE. The default implementation deals well with all
+;; states that `vc-state' can return.
+;;
+;; - dired-state-info (file)
+;;
+;; Translate the `vc-state' property of FILE into a string that can be
+;; used in a vc-dired buffer. The default implementation deals well
+;; with all states that `vc-state' can return.
+;;
+;; STATE-CHANGING FUNCTIONS
+;;
+;; * register (file &optional rev comment)
+;;
+;; Register FILE in this backend. Optionally, an initial revision REV
+;; and an initial description of the file, COMMENT, may be specified.
+;; The implementation should pass the value of vc-register-switches
+;; to the backend command.
+;;
+;; - init-version (file)
+;;
+;; The initial version to use when registering FILE if one is not
+;; specified by the user. If not provided, the variable
+;; vc-default-init-version is used instead.
+;;
+;; - responsible-p (file)
+;;
+;; Return non-nil if this backend considers itself "responsible" for
+;; FILE, which can also be a directory. This function is used to find
+;; out what backend to use for registration of new files and for things
+;; like change log generation. The default implementation always
+;; returns nil.
+;;
+;; - could-register (file)
+;;
+;; Return non-nil if FILE could be registered under this backend. The
+;; default implementation always returns t.
+;;
+;; - receive-file (file rev)
+;;
+;; Let this backend "receive" a file that is already registered under
+;; another backend. The default implementation simply calls `register'
+;; for FILE, but it can be overridden to do something more specific,
+;; e.g. keep revision numbers consistent or choose editing modes for
+;; FILE that resemble those of the other backend.
+;;
+;; - unregister (file)
+;;
+;; Unregister FILE from this backend. This is only needed if this
+;; backend may be used as a "more local" backend for temporary editing.
+;;
+;; * checkin (file rev comment)
+;;
+;; Commit changes in FILE to this backend. If REV is non-nil, that
+;; should become the new revision number. COMMENT is used as a
+;; check-in comment. The implementation should pass the value of
+;; vc-checkin-switches to the backend command.
+;;
+;; * find-version (file rev buffer)
+;;
+;; Fetch revision REV of file FILE and put it into BUFFER.
+;; If REV is the empty string, fetch the head of the trunk.
+;; The implementation should pass the value of vc-checkout-switches
+;; to the backend command.
+;;
+;; * checkout (file &optional editable rev)
+;;
+;; Check out revision REV of FILE into the working area. If EDITABLE
+;; is non-nil, FILE should be writable by the user and if locking is
+;; used for FILE, a lock should also be set. If REV is non-nil, that
+;; is the revision to check out (default is current workfile version).
+;; If REV is t, that means to check out the head of the current branch;
+;; if it is the empty string, check out the head of the trunk.
+;; The implementation should pass the value of vc-checkout-switches
+;; to the backend command.
+;;
+;; * revert (file &optional contents-done)
+;;
+;; Revert FILE back to the current workfile version. If optional
+;; arg CONTENTS-DONE is non-nil, then the contents of FILE have
+;; already been reverted from a version backup, and this function
+;; only needs to update the status of FILE within the backend.
+;;
+;; - cancel-version (file editable)
+;;
+;; Cancel the current workfile version of FILE, i.e. remove it from the
+;; master. EDITABLE non-nil means that FILE should be writable
+;; afterwards, and if locking is used for FILE, then a lock should also
+;; be set. If this function is not provided, trying to cancel a
+;; version is caught as an error.
+;;
+;; - merge (file rev1 rev2)
+;;
+;; Merge the changes between REV1 and REV2 into the current working file.
+;;
+;; - merge-news (file)
+;;
+;; Merge recent changes from the current branch into FILE.
+;;
+;; - steal-lock (file &optional version)
+;;
+;; Steal any lock on the current workfile version of FILE, or on
+;; VERSION if that is provided. This function is only needed if
+;; locking is used for files under this backend, and if files can
+;; indeed be locked by other users.
+;;
+;; HISTORY FUNCTIONS
+;;
+;; * print-log (file)
+;;
+;; Insert the revision log of FILE into the *vc* buffer.
+;;
+;; - show-log-entry (version)
+;;
+;; If provided, search the log entry for VERSION in the current buffer,
+;; and make sure it is displayed in the buffer's window. The default
+;; implementation of this function works for RCS-style logs.
+;;
+;; - wash-log (file)
+;;
+;; Remove all non-comment information from the output of print-log. The
+;; default implementation of this function works for RCS-style logs.
+;;
+;; - logentry-check ()
+;;
+;; If defined, this function is run to find out whether the user
+;; entered a valid log entry for check-in. The log entry is in the
+;; current buffer, and if it is not a valid one, the function should
+;; throw an error.
+;;
+;; - comment-history (file)
+;;
+;; Return a string containing all log entries that were made for FILE.
+;; This is used for transferring a file from one backend to another,
+;; retaining comment information. The default implementation of this
+;; function does this by calling print-log and then wash-log, and
+;; returning the resulting buffer contents as a string.
+;;
+;; - update-changelog (files)
+;;
+;; Using recent log entries, create ChangeLog entries for FILES, or for
+;; all files at or below the default-directory if FILES is nil. The
+;; default implementation runs rcs2log, which handles RCS- and
+;; CVS-style logs.
+;;
+;; * diff (file &optional rev1 rev2)
+;;
+;; Insert the diff for FILE into the *vc-diff* buffer. If REV1 and
+;; REV2 are non-nil, report differences from REV1 to REV2. If REV1
+;; is nil, use the current workfile version (as found in the
+;; repository) as the older version; if REV2 is nil, use the current
+;; workfile contents as the newer version. This function should
+;; pass the value of (vc-diff-switches-list BACKEND) to the backend
+;; command. It should return a status of either 0 (no differences
+;; found), or 1 (either non-empty diff or the diff is run
+;; asynchronously).
+;;
+;; - diff-tree (dir &optional rev1 rev2)
+;;
+;; Insert the diff for all files at and below DIR into the *vc-diff*
+;; buffer. The meaning of REV1 and REV2 is the same as for
+;; vc-BACKEND-diff. The default implementation does an explicit tree
+;; walk, calling vc-BACKEND-diff for each individual file.
+;;
+;; - annotate-command (file buf rev)
+;;
+;; If this function is provided, it should produce an annotated version
+;; of FILE in BUF, relative to version REV. This is currently only
+;; implemented for CVS, using the `cvs annotate' command.
+;;
+;; - annotate-time ()
+;;
+;; Only required if `annotate-command' is defined for the backend.
+;; Return the time of the next line of annotation at or after point,
+;; as a floating point fractional number of days. The helper
+;; function `vc-annotate-convert-time' may be useful for converting
+;; multi-part times as returned by `current-time' and `encode-time'
+;; to this format. Return nil if no more lines of annotation appear
+;; in the buffer. 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.
+;;
+;; - annotate-current-time ()
+;;
+;; Only required if `annotate-command' is defined for the backend,
+;; AND you'd like the current time considered to be anything besides
+;; (vs-annotate-convert-time (current-time)) -- i.e. the current
+;; time with hours, minutes, and seconds included. Probably safe to
+;; ignore. Return the current-time, in units of fractional days.
+;;
+;; SNAPSHOT SYSTEM
+;;
+;; - 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 implementation 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. The default implementation
+;; does a sanity check whether there aren't any uncommitted changes at
+;; or below DIR, and then performs a tree walk, using the `checkout'
+;; function to retrieve the corresponding versions.
+;;
+;; MISCELLANEOUS
+;;
+;; - make-version-backups-p (file)
+;;
+;; Return non-nil if unmodified repository versions of FILE should be
+;; backed up locally. If this is done, VC can perform `diff' and
+;; `revert' operations itself, without calling the backend system. The
+;; default implementation always returns nil.
+;;
+;; - previous-version (file rev)
+;;
+;; Return the version number that precedes REV for FILE.
+;;
+;; - check-headers ()
+;;
+;; Return non-nil if the current buffer contains any version headers.
+;;
+;; - clear-headers ()
+;;
+;; In the current buffer, reset all version headers to their unexpanded
+;; form. This function should be provided if the state-querying code
+;; for this backend uses the version headers to determine the state of
+;; a file. This function will then be called whenever VC changes the
+;; version control state in such a way that the headers would give
+;; wrong information.
+;;
+;; - rename-file (old new)
+;;
+;; Rename file OLD to NEW, both in the working area and in the
+;; repository. If this function is not provided, the command
+;; `vc-rename-file' will signal an error.
+
+;;; Code:
+
+(require 'vc-hooks)
+(require 'ring)
+(eval-when-compile
+ (require 'cl)
+ (require 'compile)
+ (require 'dired) ; for dired-map-over-marks macro
+ (require 'dired-aux)) ; for dired-kill-{line,tree}
+
+(if (not (assoc 'vc-parent-buffer minor-mode-alist))
+ (setq minor-mode-alist
+ (cons '(vc-parent-buffer vc-parent-buffer-name)
+ minor-mode-alist)))
+
+;; General customization
+
+(defgroup vc nil
+ "Version-control system in Emacs."
+ :group 'tools)
+
+(defcustom vc-suppress-confirm nil
+ "*If non-nil, treat user as expert; suppress yes-no prompts on some things."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-delete-logbuf-window t
+ "*If non-nil, delete the *VC-log* buffer and window after each logical action.
+If nil, bury that buffer instead.
+This is most useful if you have multiple windows on a frame and would like to
+preserve the setting."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-initial-comment nil
+ "*If non-nil, prompt for initial comment when a file is registered."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-default-init-version "1.1"
+ "*A string used as the default version number when a new file is registered.
+This can be overridden by giving a prefix argument to \\[vc-register]. This
+can also be overridden by a particular VC backend."
+ :type 'string
+ :group 'vc
+ :version "20.3")
+
+(defcustom vc-command-messages nil
+ "*If non-nil, display run messages from back-end commands."
+ :type 'boolean
+ :group 'vc)
+
+(defcustom vc-checkin-switches nil
+ "*A string or list of strings specifying extra switches for checkin.
+These are passed to the checkin program by \\[vc-checkin]."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :group 'vc)
+
+(defcustom vc-checkout-switches nil
+ "*A string or list of strings specifying extra switches for checkout.
+These are passed to the checkout program by \\[vc-checkout]."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :group 'vc)
+
+(defcustom vc-register-switches nil
+ "*A string or list of strings; extra switches for registering a file.
+These are passed to the checkin program by \\[vc-register]."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ 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.1")
+
+(defcustom vc-dired-recurse t
+ "*If non-nil, show directory trees recursively in VC Dired."
+ :type 'boolean
+ :group 'vc
+ :version "20.3")
+
+(defcustom vc-dired-terse-display t
+ "*If non-nil, show only locked files in VC Dired."
+ :type 'boolean
+ :group 'vc
+ :version "20.3")
+
+(defcustom vc-directory-exclusion-list '("SCCS" "RCS" "CVS")
+ "*List of directory names to be ignored when walking directory trees."
+ :type '(repeat string)
+ :group 'vc)
+
+(defconst vc-maximum-comment-ring-size 32
+ "Maximum number of saved comments in the comment ring.")
+
+(defcustom vc-diff-switches nil
+ "*A string or list of strings specifying switches for diff under VC.
+When running diff under a given BACKEND, VC concatenates the values of
+`diff-switches', `vc-diff-switches', and `vc-BACKEND-diff-switches' to
+get the switches for that command. Thus, `vc-diff-switches' should
+contain switches that are specific to version control, but not
+specific to any particular backend."
+ :type '(choice (const :tag "None" nil)
+ (string :tag "Argument String")
+ (repeat :tag "Argument List"
+ :value ("")
+ string))
+ :group 'vc
+ :version "21.1")
+
+;;;###autoload
+(defcustom vc-checkout-hook nil
+ "*Normal hook (list of functions) run after checking out a file.
+See `run-hooks'."
+ :type 'hook
+ :group 'vc
+ :version "21.1")
+
+(defcustom vc-annotate-display-mode nil
+ "Which mode to color the output of \\[vc-annotate] with by default."
+ :type '(choice (const :tag "Default" nil)
+ (const :tag "Scale to Oldest" scale)
+ (const :tag "Scale Oldest->Newest" fullscale)
+ (number :tag "Specify Fractional Number of Days"
+ :value "20.5"))
+ :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 is 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
+ '(( 20. . "#FF0000")
+ ( 40. . "#FF3800")
+ ( 60. . "#FF7000")
+ ( 80. . "#FFA800")
+ (100. . "#FFE000")
+ (120. . "#E7FF00")
+ (140. . "#AFFF00")
+ (160. . "#77FF00")
+ (180. . "#3FFF00")
+ (200. . "#07FF00")
+ (220. . "#00FF31")
+ (240. . "#00FF69")
+ (260. . "#00FFA1")
+ (280. . "#00FFD9")
+ (300. . "#00EEFF")
+ (320. . "#00B6FF")
+ (340. . "#007EFF"))
+ "*Association list of age versus color, for \\[vc-annotate].
+Ages are given in units of fractional days. Default is eighteen steps
+using a twenty day increment."
+ :type 'alist
+ :group 'vc)
+
+(defcustom vc-annotate-very-old-color "#0046FF"
+ "*Color for lines older than the current color range in \\[vc-annotate]]."
+ :type 'string
+ :group 'vc)
+
+(defcustom vc-annotate-background "black"
+ "*Background color for \\[vc-annotate].
+Default color is used if nil."
+ :type 'string
+ :group 'vc)
+
+(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 '(repeat number)
+ :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-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'."
+ :type '(repeat (cons :format "%v"
+ (regexp :tag "File Type")
+ (string :tag "Header String")))
+ :group 'vc)
+
+(defcustom vc-comment-alist
+ '((nroff-mode ".\\\"" ""))
+ "*Special comment delimiters for generating VC headers.
+Add an entry in this list if you need to override the normal `comment-start'
+and `comment-end' variables. This will only be necessary if the mode language
+is sensitive to blank lines."
+ :type '(repeat (list :format "%v"
+ (symbol :tag "Mode")
+ (string :tag "Comment Start")
+ (string :tag "Comment End")))
+ :group 'vc)
+
+(defcustom vc-checkout-carefully (= (user-uid) 0)
+ "*Non-nil means be extra-careful in checkout.
+Verify that the file really is not locked
+and that its contents match what the master file says."
+ :type 'boolean
+ :group 'vc)
+(make-obsolete-variable 'vc-checkout-carefully
+ "the corresponding checks are always done now."
+ "21.1")
+
+\f
+;; The main keymap
+
+;; Initialization code, to be done just once at load-time
+(defvar vc-log-mode-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map text-mode-map)
+ (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)
+
+\f
+;; Variables the user doesn't need to know about.
+(defvar vc-log-operation nil)
+(defvar vc-log-after-operation-hook nil)
+(defvar vc-annotate-buffers nil
+ "Alist 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)
+
+(defvar vc-dired-mode nil)
+(make-variable-buffer-local 'vc-dired-mode)
+
+(defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size))
+(defvar vc-comment-ring-index nil)
+(defvar vc-last-comment-match "")
+
+;; 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."
+ (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
+
+(defun vc-branch-p (rev)
+ "Return t if REV is a branch revision."
+ (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev))))
+
+;;;###autoload
+(defun vc-branch-part (rev)
+ "Return the branch part of a revision number REV."
+ (let ((index (string-match "\\.[0-9]+\\'" rev)))
+ (if index
+ (substring rev 0 index))))
+
+(defun vc-minor-part (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-default-previous-version (backend file rev)
+ "Guess the version number immediately preceding REV for FILE.
+This default implementation works for <major>.<minor>-style version numbers
+as used by RCS and CVS."
+ (let ((branch (vc-branch-part rev))
+ (minor-num (string-to-number (vc-minor-part rev))))
+ (when branch
+ (if (> minor-num 1)
+ ;; version does probably not start a branch or release
+ (concat branch "." (number-to-string (1- minor-num)))
+ (if (vc-trunk-p rev)
+ ;; we are at the beginning of the trunk --
+ ;; don't know anything to return here
+ nil
+ ;; we are at the beginning of a branch --
+ ;; return version of starting point
+ (vc-branch-part branch))))))
+
+;; File property caching
+
+(defun vc-clear-context ()
+ "Clear all cached file properties and the comment ring."
+ (interactive)
+ (fillarray vc-file-prop-obarray 0)
+ ;; Note: there is potential for minor lossage here if there is an open
+ ;; log buffer with a nonzero local value of vc-comment-ring-index.
+ (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
+
+(defmacro with-vc-properties (file form settings)
+ "Execute FORM, then maybe set per-file properties for FILE.
+SETTINGS is an association list of property/value pairs. After
+executing FORM, set those properties from SETTINGS that have not yet
+been updated to their corresponding values."
+ `(let ((vc-touched-properties (list t)))
+ ,form
+ (mapcar (lambda (setting)
+ (let ((property (car setting)))
+ (unless (memq property vc-touched-properties)
+ (put (intern ,file vc-file-prop-obarray)
+ property (cdr setting)))))
+ ,settings)))
+
+;; Random helper functions
+
+(defsubst vc-editable-p (file)
+ "Return non-nil if FILE can be edited."
+ (or (eq (vc-checkout-model file) 'implicit)
+ (memq (vc-state file) '(edited needs-merge))))
+
+;; Two macros for elisp programming
+;;;###autoload
+(defmacro with-vc-file (file comment &rest body)
+ "Check out a writable copy of FILE if necessary, then execute 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 ((filevar (make-symbol "file")))
+ `(let ((,filevar (expand-file-name ,file)))
+ (or (vc-backend ,filevar)
+ (error (format "File not under version control: `%s'" file)))
+ (unless (vc-editable-p ,filevar)
+ (let ((state (vc-state ,filevar)))
+ (if (stringp state)
+ (error (format "`%s' is locking `%s'" state ,filevar))
+ (vc-checkout ,filevar t))))
+ (save-excursion
+ ,@body)
+ (vc-checkin ,filevar nil ,comment))))
+
+(put 'with-vc-file 'lisp-indent-function 2)
+
+;;;###autoload
+(defmacro edit-vc-file (file comment &rest body)
+ "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."
+ (let ((filevar (make-symbol "file")))
+ `(let ((,filevar (expand-file-name ,file)))
+ (with-vc-file
+ ,filevar ,comment
+ (set-buffer (find-file-noselect ,filevar))
+ ,@body
+ (save-buffer)))))
+
+(put 'edit-vc-file 'lisp-indent-function 2)
+
+(defun vc-ensure-vc-buffer ()
+ "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
+ (pop-to-buffer vc-parent-buffer))
+ (if (not (buffer-file-name))
+ (error "Buffer %s is not associated with a file" (buffer-name))
+ (if (not (vc-backend (buffer-file-name)))
+ (error "File %s is not under version control" (buffer-file-name))))))
+
+(defun vc-process-filter (p s)
+ "An alternative output filter for async process P.
+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 current.
+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)
+ (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 arguments: the COMMAND, the FILE and the FLAGS.")
+
+;;;###autoload
+(defun vc-do-command (buffer okstatus command file &rest flags)
+ "Execute a VC command, notifying user and checking for errors.
+Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil or the
+current buffer if BUFFER is t. If the destination buffer is not
+already current, set it up properly and erase it. 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 (or (eq buffer t)
+ (and (stringp buffer)
+ (string= (buffer-name) buffer))
+ (eq buffer (current-buffer)))
+ (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)))
+ (unless (active-minibuffer-window)
+ (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
+ `(unless (active-minibuffer-window)
+ (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)))
+
+(defun vc-position-context (posn)
+ "Save a bit of the text around POSN in the current buffer.
+Used to help us find the corresponding position again later
+if 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)))))
+
+(defun vc-find-position-by-context (context)
+ "Return the position of CONTEXT in the current buffer.
+If CONTEXT cannot be found, return nil."
+ (let ((context-string (nth 2 context)))
+ (if (equal "" context-string)
+ (point-max)
+ (save-excursion
+ (let ((diff (- (nth 1 context) (buffer-size))))
+ (if (< diff 0) (setq diff (- diff)))
+ (goto-char (nth 0 context))
+ (if (or (search-forward context-string nil t)
+ ;; Can't use search-backward since the match may continue
+ ;; after point.
+ (progn (goto-char (- (point) diff (length context-string)))
+ ;; goto-char doesn't signal an error at
+ ;; beginning of buffer like backward-char would
+ (search-forward context-string nil t)))
+ ;; to beginning of OSTRING
+ (- (point) (length context-string))))))))
+
+(defun vc-context-matches-p (posn context)
+ "Return t if POSN matches CONTEXT, nil otherwise."
+ (let* ((context-string (nth 2 context))
+ (len (length context-string))
+ (end (+ posn len)))
+ (if (> end (1+ (buffer-size)))
+ nil
+ (string= context-string (buffer-substring posn end)))))
+
+(defun vc-buffer-context ()
+ "Return a list (POINT-CONTEXT MARK-CONTEXT REPARSE).
+Used by `vc-restore-buffer-context' to 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))
+ (vc-position-context (mark-marker))))
+ ;; Make the right thing happen in transient-mark-mode.
+ (mark-active nil)
+ ;; We may want to reparse the compilation buffer after revert
+ (reparse (and (boundp 'compilation-error-list) ;compile loaded
+ (let ((curbuf (current-buffer)))
+ ;; Construct a list; each elt is nil or a buffer
+ ;; iff that buffer is a compilation output buffer
+ ;; that contains markers into the current buffer.
+ (save-excursion
+ (mapcar (lambda (buffer)
+ (set-buffer buffer)
+ (let ((errors (or
+ compilation-old-error-list
+ compilation-error-list))
+ (buffer-error-marked-p nil))
+ (while (and (consp errors)
+ (not buffer-error-marked-p))
+ (and (markerp (cdr (car errors)))
+ (eq buffer
+ (marker-buffer
+ (cdr (car errors))))
+ (setq buffer-error-marked-p t))
+ (setq errors (cdr errors)))
+ (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."
+ (let ((point-context (nth 0 context))
+ (mark-context (nth 1 context))
+ (reparse (nth 2 context)))
+ ;; Reparse affected compilation buffers.
+ (while reparse
+ (if (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.
+ (error-pos (marker-position
+ (car (car-safe compilation-error-list)))))
+ ;; Reparse the error messages as far as they were parsed before.
+ (compile-reinitialize-errors '(4) compilation-parsing-end)
+ ;; Move the pointer up to find the error we were at before
+ ;; reparsing. Now next-error should properly go to the next one.
+ (while (and compilation-error-list
+ (/= error-pos (car (car compilation-error-list))))
+ (setq compilation-error-list (cdr compilation-error-list))))))
+ (setq reparse (cdr reparse)))
+
+ ;; if necessary, restore point and mark
+ (if (not (vc-context-matches-p (point) point-context))
+ (let ((new-point (vc-find-position-by-context point-context)))
+ (if new-point (goto-char new-point))))
+ (and mark-active
+ mark-context
+ (not (vc-context-matches-p (mark) mark-context))
+ (let ((new-mark (vc-find-position-by-context mark-context)))
+ (if new-mark (set-mark new-mark))))))
+
+(defun vc-revert-buffer1 (&optional arg no-confirm)
+ "Revert buffer, keeping point and mark where user expects them.
+Try to be clever in the face of changes due to expanded version control
+key words. This is important for typeahead to work as expected.
+ARG and NO-CONFIRM are passed on to `revert-buffer'."
+ (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 --
+ ;; in this case, vc-restore-buffer-context gives it a second try.
+ (save-excursion
+ ;; 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."
+ (if (buffer-modified-p)
+ (if (or vc-suppress-confirm
+ (y-or-n-p (format "Buffer %s modified; save it? " (buffer-name))))
+ (save-buffer)
+ (unless not-urgent
+ (error "Aborted")))))
+
+(defun vc-default-latest-on-branch-p (backend file)
+ "Return non-nil if FILE is the latest on its branch.
+This default implementation always returns non-nil, which means that
+editing non-current versions is not supported by default."
+ t)
+
+(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)
+ "Do The Right Thing for a given FILE under version control.
+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
+ (if vc-dired-mode
+ (switch-to-buffer-other-window visited)
+ (set-buffer 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.
+ ;; Ignore buffer-read-only during this test, and
+ ;; preserve find-file-literally.
+ (let ((buffer-read-only (not (file-writable-p file))))
+ (find-file-noselect file nil find-file-literally))
+ (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)
+ (if visited (vc-mode-line 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, version, or backend to move to: "))
+ (let ((vsym (intern-soft (upcase version))))
+ (if (member vsym vc-handled-backends)
+ (vc-transfer-file file vsym)
+ (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 (not (file-writable-p file)))
+ ;; 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 (not verbose)
+ (vc-checkin file nil comment)
+ (setq version (read-string "New version or backend: "))
+ (let ((vsym (intern (upcase version))))
+ (if (member vsym vc-handled-backends)
+ (vc-transfer-file file vsym)
+ (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) t)
+ (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))
+ (let ((inhibit-read-only t))
+ (insert
+ (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)
+ (clear-visited-file-modtime)
+ ;; Must clear any headers here because they wouldn't
+ ;; show that the file is locked now.
+ (vc-clear-headers file)
+ (write-file (buffer-file-name))
+ (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)
+ "Call `vc-next-action-on-file' on all the marked files.
+Ignores FILE and REV, but passes on COMMENT."
+ (let ((dired-buffer (current-buffer))
+ (dired-dir default-directory))
+ (dired-map-over-marks
+ (let ((file (dired-get-filename)))
+ (message "Processing %s..." 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))
+ (dired-move-to-filename))
+
+;; Here's the major entry point.
+
+;;;###autoload
+(defun vc-next-action (verbose)
+ "Do the next logical version control operation on the current file.
+
+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
+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.
+
+For RCS and SCCS files:
+ If the file is not already registered, this registers it for version
+control.
+ If the file is registered and not locked by anyone, this checks out
+a writable and locked file ready for editing.
+ If the file is checked out and locked by the calling user, this
+first checks to see if the file has changed since checkout. If not,
+it performs a revert.
+ If the file has been changed, this pops up a buffer for entry
+of a log message; when the message has been entered, it checks in the
+resulting changes along with the log message as change commentary. If
+the variable `vc-keep-workfiles' is non-nil (which is its default), a
+read-only copy of the changed file is left in place afterwards.
+ If the file is registered and locked by someone else, you are given
+the option to steal the lock.
+
+For CVS files:
+ If the file is not already registered, this registers it for version
+control. This does a \"cvs add\", but no \"cvs commit\".
+ If the file is added but not committed, it is committed.
+ If your working file is changed, but the repository file is
+unchanged, this pops up a buffer for entry of a log message; when the
+message has been entered, it checks in the resulting changes along
+with the logmessage as change commentary. A writable file is retained.
+ If the repository file is changed, you are asked if you want to
+merge in the changes into your working copy."
+
+ (interactive "P")
+ (catch 'nogo
+ (if vc-dired-mode
+ (let ((files (dired-get-marked-files)))
+ (set (make-local-variable 'vc-dired-window-configuration)
+ (current-window-configuration))
+ (if (string= ""
+ (mapconcat
+ (lambda (f)
+ (if (not (vc-up-to-date-p f)) "@" ""))
+ files ""))
+ (vc-next-action-dired nil nil "dummy")
+ (vc-start-entry nil nil nil nil
+ "Enter a change comment for the marked files."
+ 'vc-next-action-dired))
+ (throw 'nogo nil)))
+ (while vc-parent-buffer
+ (pop-to-buffer vc-parent-buffer))
+ (if buffer-file-name
+ (vc-next-action-on-file buffer-file-name verbose)
+ (error "Buffer %s is not associated with a file" (buffer-name)))))
+
+;; These functions help the vc-next-action entry point
+
+;;;###autoload
+(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")
+ (unless buffer-file-name (error "No visited file"))
+ (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))
+ (zerop (buffer-size))
+ (not (file-exists-p buffer-file-name)))
+ (set-buffer-modified-p t))
+ (vc-buffer-sync)
+
+ (vc-start-entry buffer-file-name
+ (if set-version
+ (read-string (format "Initial version level for %s: "
+ (buffer-name)))
+ (let ((backend (vc-responsible-backend buffer-file-name)))
+ (if (vc-find-backend-function backend 'init-version)
+ (vc-call-backend backend 'init-version)
+ vc-default-init-version)))
+ (or comment (not vc-initial-comment))
+ nil
+ "Enter initial comment."
+ (lambda (file rev comment)
+ (message "Registering %s... " file)
+ (let ((backend (vc-responsible-backend file t)))
+ (vc-file-clearprops 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 a backend system that is responsible for FILE.
+The optional argument REGISTER means that a backend suitable for
+registration should be found.
+
+If REGISTER is nil, then if FILE is already registered, return the
+backend of FILE. If FILE is not registered, or a directory, then the
+first backend in `vc-handled-backends' that declares itself
+responsible for FILE is returned. If no backend declares itself
+responsible, return the first backend.
+
+If REGISTER is non-nil, return the first responsible backend under
+which FILE is not yet registered. If there is no such backend, return
+the first backend under which FILE is not yet registered, but could
+be registered."
+ (if (not vc-handled-backends)
+ (error "No handled backends"))
+ (or (and (not (file-directory-p file)) (not register) (vc-backend file))
+ (catch 'found
+ ;; First try: find a responsible backend. If this is for registration,
+ ;; it must be a backend under which FILE is not yet registered.
+ (dolist (backend vc-handled-backends)
+ (and (or (not register)
+ (not (vc-call-backend backend 'registered file)))
+ (vc-call-backend backend 'responsible-p file)
+ (throw 'found backend)))
+ ;; no responsible backend
+ (if (not register)
+ ;; if this is not for registration, the first backend must do
+ (car vc-handled-backends)
+ ;; for registration, we need to find a new backend that
+ ;; could register FILE
+ (dolist (backend vc-handled-backends)
+ (and (not (vc-call-backend backend 'registered file))
+ (vc-call-backend backend 'could-register file)
+ (throw 'found backend)))
+ (error "No backend that could register")))))
+
+(defun vc-default-responsible-p (backend file)
+ "Indicate whether BACKEND is reponsible for FILE.
+The default is to return nil always."
+ nil)
+
+(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 FILE is in the current buffer, either revert or unvisit it.
+The choice between revert (to see expanded keywords) and unvisit depends 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
+ (let ((view-old-buffer-read-only nil))
+ (view-mode-exit)))
+ (and (not view-mode)
+ (not (eq (get major-mode 'mode-class) 'special))
+ (view-mode-enter))))
+ (vc-mode-line buffer-file-name))
+ (kill-buffer (current-buffer)))))
+
+(defun vc-resynch-buffer (file &optional keep noquery)
+ "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
+ (with-current-buffer buffer
+ (vc-resynch-window file keep noquery)))))
+ (vc-dired-resynch-file file))
+
+(defun vc-start-entry (file rev comment initial-contents 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. If COMMENT is a string and
+INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial
+contents of the log entry buffer. If COMMENT is a string and
+INITIAL-CONTENTS is nil, do action immediately as if the user had
+entered COMMENT. If COMMENT is t, also do action immediately with an
+empty comment. 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 (or (and file (get-file-buffer file)) (current-buffer))))
+ (if vc-before-checkin-hook
+ (if file
+ (with-current-buffer parent
+ (run-hooks 'vc-before-checkin-hook))
+ (run-hooks 'vc-before-checkin-hook)))
+ (if (and comment (not initial-contents))
+ (set-buffer (get-buffer-create "*VC-log*"))
+ (pop-to-buffer (get-buffer-create "*VC-log*")))
+ (set (make-local-variable 'vc-parent-buffer) parent)
+ (set (make-local-variable 'vc-parent-buffer-name)
+ (concat " from " (buffer-name vc-parent-buffer)))
+ (if file (vc-mode-line file))
+ (vc-log-edit file)
+ (make-local-variable 'vc-log-after-operation-hook)
+ (if after-hook
+ (setq vc-log-after-operation-hook after-hook))
+ (setq vc-log-operation action)
+ (setq vc-log-version rev)
+ (when comment
+ (erase-buffer)
+ (when (stringp comment) (insert comment)))
+ (if (or (not comment) initial-contents)
+ (message "%s Type C-c C-c when done" msg)
+ (vc-finish-logentry (eq comment t)))))
+
+(defun vc-checkout (file &optional writable rev)
+ "Retrieve a copy of the revision REV of FILE.
+If WRITABLE is non-nil, make sure the retrieved file is writable.
+REV defaults to the latest revision.
+
+After check-out, runs the normal hook `vc-checkout-hook'."
+ (and writable
+ (not rev)
+ (vc-call make-version-backups-p file)
+ (vc-up-to-date-p file)
+ (vc-make-version-backup file))
+ (with-vc-properties
+ file
+ (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-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-checkout-time . ,(nth 5 (file-attributes file)))))
+ (vc-resynch-buffer file t t)
+ (run-hooks 'vc-checkout-hook))
+
+(defun vc-steal-lock (file rev owner)
+ "Steal the lock on FILE."
+ (let (file-description)
+ (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 canceled"))
+ (message "Stealing lock on %s..." file)
+ (with-vc-properties
+ file
+ (vc-call steal-lock file rev)
+ `((vc-state . edited)))
+ (vc-resynch-buffer file t t)
+ (message "Stealing lock on %s...done" file)
+ ;; Write mail after actually stealing, because if the stealing
+ ;; goes wrong, we don't want to send any mail.
+ (compose-mail owner (format "Stolen lock on %s" file-description))
+ (setq default-directory (expand-file-name "~/"))
+ (goto-char (point-max))
+ (insert
+ (format "I stole the lock on %s, " file-description)
+ (current-time-string)
+ ".\n")
+ (message "Please explain why you stole the lock. Type C-c C-c when done.")))
+
+(defun vc-checkin (file &optional rev comment initial-contents)
+ "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
+INITIAL-CONTENTS is non-nil, then COMMENT is used as the initial contents
+of the log entry buffer.
+
+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 initial-contents
+ "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 ***"))
+ (with-vc-properties
+ file
+ ;; Change buffers to get local value of vc-checkin-switches.
+ (with-current-buffer (or (get-file-buffer file) (current-buffer))
+ (progn
+ (vc-call checkin file rev comment)
+ (vc-delete-automatic-version-backups file)))
+ `((vc-state . up-to-date)
+ (vc-checkout-time . ,(nth 5 (file-attributes file)))
+ (vc-workfile-version . nil)))
+ (message "Checking in %s...done" file))
+ 'vc-checkin-hook))
+
+(defun vc-comment-to-change-log (&optional whoami file-name)
+ "Enter last VC comment into the change log for the current file.
+WHOAMI (interactive prefix) non-nil means prompt for user name
+and site. FILE-NAME is the name of the change log; if nil, use
+`change-log-default-name'.
+
+This may be useful as a `vc-checkin-hook' to update change logs
+automatically."
+ (interactive (if current-prefix-arg
+ (list current-prefix-arg
+ (prompt-for-change-log-name))))
+ ;; Make sure the defvar for add-log-current-defun-function has been executed
+ ;; before binding it.
+ (require 'add-log)
+ (let (;; Extract the comment first so we get any error before doing anything.
+ (comment (ring-ref vc-comment-ring 0))
+ ;; Don't let add-change-log-entry insert a defun name.
+ (add-log-current-defun-function 'ignore)
+ end)
+ ;; Call add-log to do half the work.
+ (add-change-log-entry whoami file-name t t)
+ ;; Insert the VC comment, leaving point before it.
+ (setq end (save-excursion (insert comment) (point-marker)))
+ (if (looking-at "\\s *\\s(")
+ ;; It starts with an open-paren, as in "(foo): Frobbed."
+ ;; So remove the ": " add-log inserted.
+ (delete-char -2))
+ ;; Canonicalize the white space between the file name and comment.
+ (just-one-space)
+ ;; Indent rest of the text the same way add-log indented the first line.
+ (let ((indentation (current-indentation)))
+ (save-excursion
+ (while (< (point) end)
+ (forward-line 1)
+ (indent-to indentation))
+ (setq end (point))))
+ ;; Fill the inserted text, preserving open-parens at bol.
+ (let ((paragraph-separate (concat paragraph-separate "\\|\\s *\\s("))
+ (paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
+ (beginning-of-line)
+ (fill-region (point) end))
+ ;; Canonicalize the white space at the end of the entry so it is
+ ;; separated from the next entry by a single blank line.
+ (skip-syntax-forward " " end)
+ (delete-char (- (skip-syntax-backward " ")))
+ (or (eobp) (looking-at "\n\n")
+ (insert "\n"))))
+
+(defun vc-finish-logentry (&optional nocomment)
+ "Complete the operation implied by the current log entry.
+Use the contents of the current buffer as a check-in or registration
+comment. If the optional arg NOCOMMENT is non-nil, then don't check
+the buffer contents as a comment, and don't add it to
+`vc-comment-ring'."
+ (interactive)
+ ;; Check and record the comment, if any.
+ (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.
+ (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)
+ (log-file vc-log-file)
+ (log-version vc-log-version)
+ (log-entry (buffer-string))
+ (after-hook vc-log-after-operation-hook)
+ (tmp-vc-parent-buffer vc-parent-buffer))
+ (pop-to-buffer vc-parent-buffer)
+ ;; OK, do it to it
+ (save-excursion
+ (funcall log-operation
+ log-file
+ log-version
+ log-entry))
+ ;; Remove checkin window (after the checkin so that if that fails
+ ;; we don't zap the *VC-log* buffer and the typing therein).
+ (let ((logbuf (get-buffer "*VC-log*")))
+ (cond ((and logbuf vc-delete-logbuf-window)
+ (delete-windows-on logbuf (selected-frame))
+ ;; Kill buffer and delete any other dedicated windows/frames.
+ (kill-buffer logbuf))
+ (logbuf (pop-to-buffer "*VC-log*")
+ (bury-buffer)
+ (pop-to-buffer tmp-vc-parent-buffer))))
+ ;; Now make sure we see the expanded headers
+ (if log-file
+ (vc-resynch-buffer log-file 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)
+ "Return the comment index STRIDE elements from the current one.
+LEN is the length of `vc-comment-ring'."
+ (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.
+With a numeric prefix ARG, go back ARG comments."
+ (interactive "*p")
+ (let ((len (ring-length vc-comment-ring)))
+ (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.
+With a numeric prefix ARG, go forward ARG comments."
+ (interactive "*p")
+ (vc-previous-comment (- arg)))
+
+(defun vc-comment-search-reverse (str &optional stride)
+ "Search backwards through comment history for substring match of STR.
+If the optional argument STRIDE is present, that is a step-width to use
+when going through the comment ring."
+ ;; 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))
+ (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)
+ "Search forwards through comment history for a substring match of STR."
+ (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 checked in version of that file. This uses no arguments. With
+a prefix argument HISTORIC, it reads the file name to use and two
+version designators specifying which versions to compare. The
+optional argument NOT-URGENT non-nil means it is ok to say no to
+saving the buffer."
+ (interactive (list current-prefix-arg t))
+ (if historic
+ (call-interactively 'vc-version-diff)
+ (vc-ensure-vc-buffer)
+ (let ((file buffer-file-name))
+ (vc-buffer-sync not-urgent)
+ (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)
+ "List the differences between FILE's versions REL1 and REL2.
+If REL1 is empty or nil it means to use the current workfile version;
+REL2 empty or nil means the current file contents. FILE may also be
+a directory, in that case, generate diffs between the correponding
+versions of all registered files in or below it."
+ (interactive
+ (let ((file (expand-file-name
+ (read-file-name (if buffer-file-name
+ "File or dir to diff: (default visited file) "
+ "File or dir to diff: ")
+ default-directory buffer-file-name t)))
+ (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 default
+ ((file-directory-p file)
+ nil)
+ ;; 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-call previous-version file
+ (vc-workfile-version file)))
+ (if (string= rel1-default "") (setq rel1-default nil))
+ (setq rel2-default (vc-workfile-version file))))
+ ;; construct argument list
+ (list file
+ (read-string (if rel1-default
+ (concat "Older version: (default "
+ rel1-default ") ")
+ "Older version: ")
+ nil nil rel1-default)
+ (read-string (if rel2-default
+ (concat "Newer version: (default "
+ rel2-default ") ")
+ "Newer version (default: current source): ")
+ nil nil rel2-default))))
+ (if (file-directory-p file)
+ ;; recursive directory diff
+ (progn
+ (vc-setup-buffer "*vc-diff*")
+ (if (string-equal rel1 "") (setq rel1 nil))
+ (if (string-equal rel2 "") (setq rel2 nil))
+ (let ((inhibit-read-only t))
+ (insert "Diffs between "
+ (or rel1 "last version checked in")
+ " and "
+ (or rel2 "current workfile(s)")
+ ":\n\n"))
+ (let ((dir (file-name-as-directory file)))
+ (vc-call-backend (vc-responsible-backend dir)
+ 'diff-tree dir rel1 rel2))
+ (vc-exec-after `(let ((inhibit-read-only t))
+ (insert "\nEnd of diffs.\n"))))
+ ;; single file diff
+ (vc-diff-internal file rel1 rel2))
+ (set-buffer "*vc-diff*")
+ (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 '(let ((inhibit-read-only t))
+ (if (eq (buffer-size) 0)
+ (insert "No differences found.\n"))
+ (goto-char (point-min))
+ (shrink-window-if-larger-than-buffer)))
+ t))
+
+(defun vc-diff-internal (file rel1 rel2)
+ "Run diff to compare FILE's revisions REL1 and REL2.
+Output goes to the current buffer, which is assumed properly set up.
+The exit status of the diff command is returned.
+
+This function takes care to set up a proper coding system for diff output.
+If both revisions are available as local files, then it also does not
+actually call the backend, but performs a local diff."
+ (if (or (not rel1) (string-equal rel1 ""))
+ (setq rel1 (vc-workfile-version file)))
+ (if (string-equal rel2 "")
+ (setq rel2 nil))
+ (let ((file-rel1 (vc-version-backup-file file rel1))
+ (file-rel2 (if (not rel2)
+ file
+ (vc-version-backup-file file rel2)))
+ (coding-system-for-read (vc-coding-system-for-diff file)))
+ (if (and file-rel1 file-rel2)
+ (apply 'vc-do-command "*vc-diff*" 1 "diff" nil
+ (append (if (listp diff-switches)
+ diff-switches
+ (list diff-switches))
+ (if (listp vc-diff-switches)
+ vc-diff-switches
+ (list vc-diff-switches))
+ (list (file-relative-name file-rel1)
+ (file-relative-name file-rel2))))
+ (vc-call diff file rel1 rel2))))
+
+(defmacro vc-diff-switches-list (backend)
+ "Return the list of switches to use for executing diff under BACKEND."
+ `(append
+ (if (listp diff-switches) diff-switches (list diff-switches))
+ (if (listp vc-diff-switches) vc-diff-switches (list vc-diff-switches))
+ (let* ((backend-switches-symbol
+ (intern (concat "vc-" (downcase (symbol-name ,backend))
+ "-diff-switches")))
+ (backend-switches
+ (if (boundp backend-switches-symbol)
+ (eval backend-switches-symbol)
+ nil)))
+ (if (listp backend-switches) backend-switches (list backend-switches)))))
+
+(defun vc-default-diff-tree (backend dir rel1 rel2)
+ "List differences for all registered files at and below DIR.
+The meaning of REL1 and REL2 is the same as for `vc-version-diff'."
+ ;; This implementation does an explicit tree walk, and calls
+ ;; vc-BACKEND-diff directly for each file. An optimization
+ ;; would be to use `vc-diff-internal', so that diffs can be local,
+ ;; and to call it only for files that are actually changed.
+ ;; However, this is expensive for some backends, and so it is left
+ ;; to backend-specific implementations.
+ (setq default-directory dir)
+ (vc-file-tree-walk
+ default-directory
+ (lambda (f)
+ (vc-exec-after
+ `(let ((coding-system-for-read (vc-coding-system-for-diff ',f)))
+ (message "Looking at %s" ',f)
+ (vc-call-backend ',(vc-backend f)
+ 'diff ',f ',rel1 ',rel2))))))
+
+(defun vc-coding-system-for-diff (file)
+ "Return the coding system for reading diff output for FILE."
+ (or coding-system-for-read
+ ;; if we already have this file open,
+ ;; use the buffer's coding system
+ (let ((buf (find-buffer-visiting file)))
+ (if buf (with-current-buffer buf
+ buffer-file-coding-system)))
+ ;; otherwise, try to find one based on the file name
+ (car (find-operation-coding-system 'insert-file-contents file))
+ ;; and a final fallback
+ 'undecided))
+
+;;;###autoload
+(defun vc-version-other-window (rev)
+ "Visit version REV of the current file in another window.
+If the current file is named `F', the version is named `F.~REV~'.
+If `F.~REV~' already exists, use it instead of checking it out again."
+ (interactive "sVersion to visit (default is workfile version): ")
+ (vc-ensure-vc-buffer)
+ (let* ((file buffer-file-name)
+ (version (if (string-equal rev "")
+ (vc-workfile-version file)
+ rev)))
+ (switch-to-buffer-other-window (vc-find-version file version))))
+
+(defun vc-find-version (file version)
+ "Read VERSION of FILE into a buffer and return the buffer."
+ (let ((automatic-backup (vc-version-backup-file-name file version))
+ (filebuf (or (get-file-buffer file) (current-buffer)))
+ (filename (vc-version-backup-file-name file version 'manual)))
+ (unless (file-exists-p filename)
+ (if (file-exists-p automatic-backup)
+ (rename-file automatic-backup filename nil)
+ (message "Checking out %s..." filename)
+ (with-current-buffer filebuf
+ (let ((failed t))
+ (unwind-protect
+ (let ((coding-system-for-read 'no-conversion)
+ (coding-system-for-write 'no-conversion))
+ (with-temp-file filename
+ (let ((outbuf (current-buffer)))
+ ;; Change buffer to get local value of
+ ;; vc-checkout-switches.
+ (with-current-buffer filebuf
+ (vc-call find-version file version outbuf))))
+ (setq failed nil))
+ (if (and failed (file-exists-p filename))
+ (delete-file filename))))
+ (vc-mode-line file))
+ (message "Checking out %s...done" filename)))
+ (find-file-noselect filename)))
+
+(defun vc-default-find-version (backend file rev buffer)
+ "Provide the new `find-version' op based on the old `checkout' op.
+This is only for compatibility with old backends. They should be updated
+to provide the `find-version' operation instead."
+ (let ((tmpfile (make-temp-file (expand-file-name file))))
+ (unwind-protect
+ (progn
+ (vc-call-backend backend 'checkout file nil rev tmpfile)
+ (with-current-buffer buffer
+ (insert-file-contents-literally tmpfile)))
+ (delete-file tmpfile))))
+
+;; Header-insertion code
+
+;;;###autoload
+(defun vc-insert-headers ()
+ "Insert headers into a file for use with a version control system.
+Headers desired are inserted at point, and are pulled from
+the variable `vc-BACKEND-header'."
+ (interactive)
+ (vc-ensure-vc-buffer)
+ (save-excursion
+ (save-restriction
+ (widen)
+ (if (or (not (vc-check-headers))
+ (y-or-n-p "Version headers already exist. Insert another set? "))
+ (progn
+ (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 ""))
+ (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 (lambda (f)
+ (if (string-match (car f) buffer-file-name)
+ (insert (format (cdr f) (car hdstrings)))))
+ vc-static-header-alist))
+ )
+ )))))
+
+(defun vc-clear-headers (&optional file)
+ "Clear all version headers in the current buffer (or FILE).
+The headers are reset to their 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))
+ (set-buffer (find-file-noselect filename))
+ (vc-call-backend backend 'clear-headers)
+ (kill-buffer filename)))))
+
+;;;###autoload
+(defun vc-merge ()
+ "Merge changes between two versions into the current buffer's file.
+This asks for two versions to merge from in the minibuffer. If the
+first version is a branch number, then merge all changes from that
+branch. If the first version is empty, merge news, i.e. recent changes
+from the current branch.
+
+See Info node `Merging'."
+ (interactive)
+ (vc-ensure-vc-buffer)
+ (vc-buffer-sync)
+ (let* ((file buffer-file-name)
+ (backend (vc-backend file))
+ (state (vc-state file))
+ first-version second-version status)
+ (cond
+ ((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"))))
+ (setq first-version
+ (read-string (concat "Branch or version to merge from "
+ "(default: news on current branch): ")))
+ (if (string= first-version "")
+ (if (not (vc-find-backend-function backend 'merge-news))
+ (error "Sorry, merging news is not implemented for %s" backend)
+ (setq status (vc-call merge-news file)))
+ (if (not (vc-find-backend-function backend 'merge))
+ (error "Sorry, merging is not implemented for %s" backend)
+ (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)))
+ (setq status (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")
+ (smerge-mode 1)
+ (if (y-or-n-p "Conflicts detected. Resolve them now? ")
+ (vc-resolve-conflicts name-A name-B)
+ (message "File contains conflict markers"))))
+
+;;;###autoload
+(defalias 'vc-resolve-conflicts 'smerge-ediff)
+
+;; The VC directory major mode. Coopt Dired for this.
+;; All VC commands get mapped into logical equivalents.
+
+(defvar vc-dired-switches)
+(defvar vc-dired-terse-mode)
+
+(defvar vc-dired-mode-map
+ (let ((map (make-sparse-keymap))
+ (vmap (make-sparse-keymap)))
+ (define-key map "\C-xv" vmap)
+ (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
+`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.
+There is a special command, `*l', to mark all files currently locked."
+ ;; define-derived-mode does it for us in Emacs-21, but not in Emacs-20.
+ ;; We do it here because dired might not be loaded yet
+ ;; when vc-dired-mode-map is initialized.
+ (set-keymap-parent vc-dired-mode-map dired-mode-map)
+ (add-hook 'dired-after-readin-hook 'vc-dired-hook nil t)
+ ;; The following is slightly modified from dired.el,
+ ;; because file lines look a bit different in vc-dired-mode
+ ;; (the column before the date does not end in a digit).
+ (set (make-local-variable 'dired-move-to-filename-regexp)
+ (let* ((l "\\([A-Za-z]\\|[^\0-\177]\\)")
+ ;; In some locales, month abbreviations are as short as 2 letters,
+ ;; and they can be followed by ".".
+ (month (concat l l "+\\.?"))
+ (s " ")
+ (yyyy "[0-9][0-9][0-9][0-9]")
+ (dd "[ 0-3][0-9]")
+ (HH:MM "[ 0-2][0-9]:[0-5][0-9]")
+ (seconds "[0-6][0-9]\\([.,][0-9]+\\)?")
+ (zone "[-+][0-2][0-9][0-5][0-9]")
+ (iso-mm-dd "[01][0-9]-[0-3][0-9]")
+ (iso-time (concat HH:MM "\\(:" seconds "\\( ?" zone "\\)?\\)?"))
+ (iso (concat "\\(\\(" yyyy "-\\)?" iso-mm-dd "[ T]" iso-time
+ "\\|" yyyy "-" iso-mm-dd "\\)"))
+ (western (concat "\\(" month s "+" dd "\\|" dd "\\.?" s month "\\)"
+ s "+"
+ "\\(" HH:MM "\\|" yyyy "\\)"))
+ (western-comma (concat month s "+" dd "," s "+" yyyy))
+ ;; Japanese MS-Windows ls-lisp has one-digit months, and
+ ;; omits the Kanji characters after month and day-of-month.
+ (mm "[ 0-1]?[0-9]")
+ (japanese
+ (concat mm l "?" s dd l "?" s "+"
+ "\\(" HH:MM "\\|" yyyy l "?" "\\)")))
+ ;; the .* below ensures that we find the last match on a line
+ (concat ".*" s
+ "\\(" western "\\|" western-comma "\\|" japanese "\\|" iso "\\)"
+ s "+")))
+ (and (boundp 'vc-dired-switches)
+ vc-dired-switches
+ (set (make-local-variable 'dired-actual-switches)
+ vc-dired-switches))
+ (set (make-local-variable 'vc-dired-terse-mode) vc-dired-terse-display)
+ (setq vc-dired-mode t))
+
+(defun vc-dired-toggle-terse-mode ()
+ "Toggle terse display in VC Dired."
+ (interactive)
+ (if (not vc-dired-mode)
+ nil
+ (setq vc-dired-terse-mode (not vc-dired-terse-mode))
+ (if vc-dired-terse-mode
+ (vc-dired-hook)
+ (revert-buffer))))
+
+(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))
+ (not (vc-up-to-date-p f))))
+ "locked file"))
+
+(define-key vc-dired-mode-map "*l" 'vc-dired-mark-locked)
+
+(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 (vc-info)
+ "Reformat a directory-listing line.
+Replace various columns with version control information, VC-INFO.
+This code, like dired, assumes UNIX -l format."
+ (beginning-of-line)
+ (when (re-search-forward
+ ;; Match link count, owner, group, size. Group may be missing,
+ ;; and only the size is present in OS/2 -l format.
+ "^..[drwxlts-]+ \\( *[0-9]+\\( [^ ]+ +\\([^ ]+ +\\)?[0-9]+\\)?\\) "
+ (line-end-position) t)
+ (replace-match (substring (concat vc-info " ") 0 10)
+ t t nil 1)))
+
+(defun vc-dired-hook ()
+ "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 (eobp))
+ (cond
+ ;; subdir header line
+ ((setq subdir (dired-get-subdir))
+ ;; 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
+ (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)
+ vc-directory-exclusion-list)
+ (let ((pos (point)))
+ (dired-kill-tree filename)
+ (goto-char pos)
+ (dired-kill-line)))
+ (vc-dired-terse-mode
+ ;; 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 (line-beginning-position)
+ (progn (forward-line 1) (point))))
+ ((string-match "\\`\\.\\.?\\'" (file-name-nondirectory filename))
+ (dired-kill-line))
+ (t
+ (vc-dired-reformat-line nil)
+ (forward-line 1))))
+ ;; ordinary file
+ ((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
+ (dired-kill-line))))
+ ;; any other line
+ (t (forward-line 1))))
+ (vc-dired-purge))
+ (message "Getting version information... done")
+ (save-restriction
+ (widen)
+ (cond ((eq (count-lines (point-min) (point-max)) 1)
+ (goto-char (point-min))
+ (message "No files locked under %s" default-directory)))))
+
+(defun vc-dired-purge ()
+ "Remove empty subdirs."
+ (let (subdir)
+ (goto-char (point-min))
+ (while (setq subdir (dired-get-subdir))
+ (forward-line 2)
+ (if (dired-get-filename nil t)
+ (if (not (dired-next-subdir 1 t))
+ (goto-char (point-max)))
+ (forward-line -2)
+ (if (not (string= (dired-current-directory) default-directory))
+ (dired-do-kill-lines t "")
+ ;; We cannot remove the top level directory.
+ ;; Just make it look a little nicer.
+ (forward-line 1)
+ (kill-line)
+ (if (not (dired-next-subdir 1 t))
+ (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)
+ ;; Check whether dired is loaded.
+ (when (fboundp 'dired-buffers-for-dir)
+ (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 (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 vc-dired-listing-switches
+ (if vc-dired-recurse "R" ""))))
+ (if read-switches
+ (setq vc-dired-switches
+ (read-string "Dired listing switches: "
+ vc-dired-switches)))
+ (require 'dired)
+ (require 'dired-aux)
+ (switch-to-buffer
+ (dired-internal-noselect (expand-file-name (file-name-as-directory dir))
+ vc-dired-switches
+ 'vc-dired-mode))))
+
+
+;; Named-configuration entry points
+
+(defun vc-snapshot-precondition (dir)
+ "Scan the tree below DIR, looking for files not up-to-date.
+If any file is not up-to-date, 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
+ 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 (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 not up-to-date" result)
+ (vc-file-tree-walk
+ dir
+ (lambda (f)
+ (vc-call assign-name f name))))))
+
+;;;###autoload
+(defun vc-retrieve-snapshot (dir name)
+ "Descending recursively from DIR, retrieve the snapshot called NAME.
+If NAME is empty, it refers to the latest versions.
+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) (vc-error-occurred
+ (vc-call checkout f nil name)
+ (if update (vc-resynch-buffer f t t)))))))))
+
+;; Miscellaneous other entry points
+
+;;;###autoload
+(defun vc-print-log ()
+ "List the change log of the current buffer in a window."
+ (interactive)
+ (vc-ensure-vc-buffer)
+ (let ((file buffer-file-name))
+ (vc-call print-log file)
+ (set-buffer "*vc*")
+ (pop-to-buffer (current-buffer))
+ (log-view-mode)
+ (vc-exec-after
+ `(let ((inhibit-read-only t))
+ (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
+ (vc-call-backend ',(vc-backend file)
+ 'show-log-entry
+ ',(vc-workfile-version file))
+ (set-buffer-modified-p nil)))))
+
+(defun vc-default-show-log-entry (backend rev)
+ (log-view-goto-rev rev))
+
+(defun vc-default-comment-history (backend file)
+ "Return a string with all log entries stored in BACKEND for FILE."
+ (if (vc-find-backend-function backend 'print-log)
+ (with-current-buffer "*vc*"
+ (vc-call print-log file)
+ (vc-call wash-log file)
+ (buffer-string))))
+
+(defun vc-default-wash-log (backend file)
+ "Remove all non-comment information from log output.
+This default implementation works for RCS logs; backends should override
+it if their logs are not in RCS format."
+ (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n"
+ "\\(branches: .*;\n\\)?"
+ "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?")))
+ (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))))
+ (goto-char (point-min))
+ (re-search-forward separator nil t)
+ (delete-region (point-min) (point))
+ (while (re-search-forward separator nil t)
+ (delete-region (match-beginning 0) (match-end 0)))))
+
+;;;###autoload
+(defun vc-revert-buffer ()
+ "Revert the current buffer's file to the version it was based on.
+This asks for confirmation if the buffer contents are not identical
+to that version. 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)
+ ;; Make sure buffer is saved. If the user says `no', abort since
+ ;; we cannot show the changes and ask for confirmation to discard them.
+ (vc-buffer-sync nil)
+ (let ((file buffer-file-name)
+ ;; This operation should always ask for confirmation.
+ (vc-suppress-confirm nil)
+ (obuf (current-buffer))
+ status)
+ (if (vc-up-to-date-p file)
+ (unless (yes-or-no-p "File seems up-to-date. Revert anyway? ")
+ (error "Revert canceled")))
+ (unless (vc-workfile-unchanged-p file)
+ ;; vc-diff selects the new window, which is not what we want:
+ ;; if the new window is on another frame, that'd require the user
+ ;; moving her mouse to answer the yes-or-no-p question.
+ (let ((win (save-selected-window
+ (setq status (vc-diff nil t)) (selected-window))))
+ (vc-exec-after `(message nil))
+ (when status
+ (unwind-protect
+ (unless (yes-or-no-p "Discard changes? ")
+ (error "Revert canceled"))
+ (select-window win)
+ (if (one-window-p t)
+ (if (window-dedicated-p (selected-window))
+ (make-frame-invisible))
+ (delete-window))))))
+ (set-buffer obuf)
+ ;; Do the reverting
+ (message "Reverting %s..." file)
+ (vc-revert-file file)
+ (message "Reverting %s...done" file)))
+
+;;;###autoload
+(defun vc-update ()
+ "Update the current buffer's file to the latest version on its branch.
+If the file contains no changes, and is not locked, then this simply replaces
+the working file with the latest version on its branch. If the file contains
+changes, and the backend supports merging news, then any recent changes from
+the current branch are merged into the working file."
+ (interactive)
+ (vc-ensure-vc-buffer)
+ (vc-buffer-sync nil)
+ (let ((file buffer-file-name))
+ (if (vc-up-to-date-p file)
+ (vc-checkout file nil "")
+ (if (eq (vc-checkout-model file) 'locking)
+ (if (eq (vc-state file) 'edited)
+ (error
+ (substitute-command-keys
+ "File is locked--type \\[vc-revert-buffer] to discard changes"))
+ (error
+ (substitute-command-keys
+ "Unexpected file state (%s)--type \\[vc-next-action] to correct")
+ (vc-state file)))
+ (if (not (vc-find-backend-function (vc-backend file) 'merge-news))
+ (error "Sorry, merging news is not implemented for %s"
+ (vc-backend file))
+ (vc-call merge-news file)
+ (vc-resynch-window file t t))))))
+
+(defun vc-version-backup-file (file &optional rev)
+ "Return name of backup file for revision REV of FILE.
+If version backups should be used for FILE, and there exists
+such a backup for REV or the current workfile version of file,
+return its name; otherwise return nil."
+ (when (vc-call make-version-backups-p file)
+ (let ((backup-file (vc-version-backup-file-name file rev)))
+ (if (file-exists-p backup-file)
+ backup-file
+ ;; there is no automatic backup, but maybe the user made one manually
+ (setq backup-file (vc-version-backup-file-name file rev 'manual))
+ (if (file-exists-p backup-file)
+ backup-file)))))
+
+(defun vc-revert-file (file)
+ "Revert FILE back to the version it was based on."
+ (with-vc-properties
+ file
+ (let ((backup-file (vc-version-backup-file file)))
+ (when backup-file
+ (copy-file backup-file file 'ok-if-already-exists 'keep-date)
+ (vc-delete-automatic-version-backups file))
+ (vc-call revert file backup-file))
+ `((vc-state . up-to-date)
+ (vc-checkout-time . ,(nth 5 (file-attributes file)))))
+ (vc-resynch-buffer file t t))
+
+;;;###autoload
+(defun vc-cancel-version (norevert)
+ "Get rid of most recently checked in version of this file.
+A prefix argument NOREVERT means do not revert the buffer afterwards."
+ (interactive "P")
+ (vc-ensure-vc-buffer)
+ (let* ((file (buffer-file-name))
+ (backend (vc-backend file))
+ (target (vc-workfile-version file))
+ (config (current-window-configuration)) done)
+ (cond
+ ((not (vc-find-backend-function backend 'cancel-version))
+ (error "Sorry, canceling versions is not supported under %s" backend))
+ ((not (vc-call latest-on-branch-p file))
+ (error "This is not the latest version; VC cannot cancel it"))
+ ((not (vc-up-to-date-p file))
+ (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)))
+ (error "Aborted")
+ (setq norevert (or norevert (not
+ (yes-or-no-p "Revert buffer to most recent remaining version? "))))
+
+ (message "Removing last change from %s..." file)
+ (with-vc-properties
+ file
+ (vc-call cancel-version file norevert)
+ `((vc-state . ,(if norevert 'edited 'up-to-date))
+ (vc-checkout-time . ,(if norevert
+ 0
+ (nth 5 (file-attributes file))))
+ (vc-workfile-version . nil)))
+ (message "Removing last change from %s...done" file)
+
+ (cond
+ (norevert ;; clear version headers and mark the buffer modified
+ (set-visited-file-name file)
+ (when (not vc-make-backup-files)
+ ;; inhibit backup for this buffer
+ (make-local-variable 'backup-inhibited)
+ (setq backup-inhibited t))
+ (setq buffer-read-only nil)
+ (vc-clear-headers)
+ (vc-mode-line file)
+ (vc-dired-resynch-file file))
+ (t ;; revert buffer to file on disk
+ (vc-resynch-buffer file t t)))
+ (message "Version %s has been removed from the master" target))))
+
+;;;###autoload
+(defun vc-switch-backend (file backend)
+ "Make BACKEND the current version control system for FILE.
+FILE must already be registered in BACKEND. The change is not
+permanent, only for the current session. This function only changes
+VC's perspective on FILE, it does not register or unregister it.
+By default, this command cycles through the registered backends.
+To get a prompt, use a prefix argument."
+ (interactive
+ (list
+ buffer-file-name
+ (let ((backend (vc-backend buffer-file-name))
+ (backends nil))
+ ;; Find the registered backends.
+ (dolist (backend vc-handled-backends)
+ (when (vc-call-backend backend 'registered buffer-file-name)
+ (push backend backends)))
+ ;; Find the next backend.
+ (let ((def (car (delq backend (append (memq backend backends) backends))))
+ (others (delete backend backends)))
+ (cond
+ ((null others) (error "No other backend to switch to"))
+ (current-prefix-arg
+ (intern
+ (upcase
+ (completing-read
+ (format "Switch to backend [%s]: " def)
+ (mapcar (lambda (b) (list (downcase (symbol-name b)))) backends)
+ nil t nil nil (downcase (symbol-name def))))))
+ (t def))))))
+ (unless (eq backend (vc-backend file))
+ (vc-file-clearprops file)
+ (vc-file-setprop file 'vc-backend backend)
+ ;; Force recomputation of the state
+ (unless (vc-call-backend backend 'registered file)
+ (vc-file-clearprops file)
+ (error "%s is not registered in %s" file backend))
+ (vc-mode-line file)))
+
+;;;###autoload
+(defun vc-transfer-file (file new-backend)
+ "Transfer FILE to another version control system NEW-BACKEND.
+If NEW-BACKEND has a higher precedence than FILE's current backend
+\(i.e. it comes earlier in `vc-handled-backends'), then register FILE in
+NEW-BACKEND, using the version number from the current backend as the
+base level. If NEW-BACKEND has a lower precedence than the current
+backend, then commit all changes that were made under the current
+backend to NEW-BACKEND, and unregister FILE from the current backend.
+\(If FILE is not yet registered under NEW-BACKEND, register it.)"
+ (let* ((old-backend (vc-backend file))
+ (edited (memq (vc-state file) '(edited needs-merge)))
+ (registered (vc-call-backend new-backend 'registered file))
+ (move
+ (and registered ; Never move if not registered in new-backend yet.
+ ;; move if new-backend comes later in vc-handled-backends
+ (or (memq new-backend (memq old-backend vc-handled-backends))
+ (y-or-n-p "Final transfer? "))))
+ (comment nil))
+ (if (eq old-backend new-backend)
+ (error "%s is the current backend of %s" new-backend file))
+ (if registered
+ (set-file-modes file (logior (file-modes file) 128))
+ ;; `registered' might have switched under us.
+ (vc-switch-backend file old-backend)
+ (let* ((rev (vc-workfile-version file))
+ (modified-file (and edited (make-temp-file file)))
+ (unmodified-file (and modified-file (vc-version-backup-file file))))
+ ;; Go back to the base unmodified file.
+ (unwind-protect
+ (progn
+ (when modified-file
+ (copy-file file modified-file 'ok-if-already-exists)
+ ;; If we have a local copy of the unmodified file, handle that
+ ;; here and not in vc-revert-file because we don't want to
+ ;; delete that copy -- it is still useful for OLD-BACKEND.
+ (if unmodified-file
+ (copy-file unmodified-file file 'ok-if-already-exists)
+ (if (y-or-n-p "Get base version from master? ")
+ (vc-revert-file file))))
+ (vc-call-backend new-backend 'receive-file file rev))
+ (when modified-file
+ (vc-switch-backend file new-backend)
+ (unless (eq (vc-checkout-model file) 'implicit)
+ (vc-checkout file t nil))
+ (rename-file modified-file file 'ok-if-already-exists)
+ (vc-file-setprop file 'vc-checkout-time nil)))))
+ (when move
+ (vc-switch-backend file old-backend)
+ (setq comment (vc-call comment-history file))
+ (vc-call unregister file))
+ (vc-switch-backend file new-backend)
+ (when (or move edited)
+ (vc-file-setprop file 'vc-state 'edited)
+ (vc-mode-line file)
+ (vc-checkin file nil comment (stringp comment)))))
+
+(defun vc-default-unregister (backend file)
+ "Default implementation of `vc-unregister', signals an error."
+ (error "Unregistering files is not supported for %s" backend))
+
+(defun vc-default-receive-file (backend file rev)
+ "Let BACKEND receive FILE from another version control system."
+ (vc-call-backend backend 'register file rev ""))
+
+(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 is 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)
+ "Rename file OLD to NEW, and rename its master file likewise."
+ (interactive "fVC rename file: \nFRename to: ")
+ (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"))
+ (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
+ (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)))))
+
+;; 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 version control logs.
+Normally, find log entries for all registered files in the default
+directory.
+
+With prefix arg of \\[universal-argument], only find log entries for the current buffer's file.
+
+With any numeric prefix arg, find log entries for all currently visited
+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 ARGS are assumed to be filenames for which
+log entries should be gathered."
+ (interactive
+ (cond ((consp current-prefix-arg) ;C-u
+ (list buffer-file-name))
+ (current-prefix-arg ;Numeric argument.
+ (let ((files nil)
+ (buffers (buffer-list))
+ file)
+ (while buffers
+ (setq file (buffer-file-name (car buffers)))
+ (and file (vc-backend file)
+ (setq files (cons file files)))
+ (setq buffers (cdr buffers)))
+ files))
+ (t
+ ;; 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
+ (expand-file-name "vc"
+ (or small-temporary-file-directory
+ temporary-file-directory))))
+ (full-name (or add-log-full-name
+ (user-full-name)
+ (user-login-name)
+ (format "uid%d" (number-to-string (user-uid)))))
+ (mailing-address (or add-log-mailing-address
+ user-mail-address)))
+ (find-file-other-window changelog)
+ (barf-if-buffer-read-only)
+ (vc-buffer-sync)
+ (undo-boundary)
+ (goto-char (point-min))
+ (push-mark)
+ (message "Computing change log entries...")
+ (message "Computing change log entries... %s"
+ (unwind-protect
+ (progn
+ (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"))
+ (setq default-directory (file-name-directory changelog))
+ (delete-file tempfile)))))
+
+;; Annotate functionality
+
+;; Declare globally instead of additional parameter to
+;; temp-buffer-show-function (not possible to pass more than one
+;; parameter). The use of annotate-ratio is deprecated in favor of
+;; annotate-mode, which replaces it with the more sensible "span-to
+;; days", along with autoscaling support.
+(defvar vc-annotate-ratio nil "Global variable.")
+(defvar vc-annotate-backend nil "Global variable.")
+
+(defconst vc-annotate-font-lock-keywords
+ ;; The fontification is done by vc-annotate-lines instead of font-lock.
+ '((vc-annotate-lines)))
+
+(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)))
+
+(define-derived-mode vc-annotate-mode fundamental-mode "Annotate"
+ "Major mode for output buffers of the `vc-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."
+ (set (make-local-variable 'truncate-lines) t)
+ (set (make-local-variable 'font-lock-defaults)
+ '(vc-annotate-font-lock-keywords t))
+ (vc-annotate-add-menu))
+
+(defun vc-annotate-display-default (&optional ratio)
+ "Display the output of \\[vc-annotate] using the default color range.
+The color range is given by `vc-annotate-color-map', scaled by RATIO
+if present. The current time is used as the offset."
+ (interactive "e")
+ (message "Redisplaying annotation...")
+ (vc-annotate-display
+ (if ratio (vc-annotate-time-span vc-annotate-color-map ratio)))
+ (message "Redisplaying annotation...done"))
+
+(defun vc-annotate-display-autoscale (&optional full)
+ "Highlight the output of \\[vc-annotate]] using an autoscaled color map.
+Autoscaling means that the map is scaled from the current time to the
+oldest annotation in the buffer, or, with argument FULL non-nil, to
+cover the range from the oldest annotation to the newest."
+ (interactive)
+ (let ((newest 0.0)
+ (oldest 999999.) ;Any CVS users at the founding of Rome?
+ (current (vc-annotate-convert-time (current-time)))
+ date)
+ (message "Redisplaying annotation...")
+ ;; Run through this file and find the oldest and newest dates annotated.
+ (save-excursion
+ (goto-char (point-min))
+ (while (setq date (vc-call-backend vc-annotate-backend 'annotate-time))
+ (if (> date newest)
+ (setq newest date))
+ (if (< date oldest)
+ (setq oldest date))))
+ (vc-annotate-display
+ (vc-annotate-time-span ;return the scaled colormap.
+ vc-annotate-color-map
+ (/ (- (if full newest current) oldest)
+ (vc-annotate-car-last-cons vc-annotate-color-map)))
+ (if full newest))
+ (message "Redisplaying annotation...done \(%s\)"
+ (if full
+ (format "Spanned from %.1f to %.1f days old"
+ (- current oldest)
+ (- current newest))
+ (format "Spanned to %.1f days old" (- current oldest))))))
+
+;; Menu -- Using easymenu.el
+(defun vc-annotate-add-menu ()
+ "Add the menu 'Annotate' to the menu bar in VC-Annotate mode."
+ (let ((menu-elements vc-annotate-menu-elements)
+ (menu-def
+ '("VC-Annotate"
+ ["Default" (unless (null vc-annotate-display-mode)
+ (setq vc-annotate-display-mode nil)
+ (vc-annotate-display-select))
+ :style toggle :selected (null vc-annotate-display-mode)]))
+ (oldest-in-map (vc-annotate-car-last-cons vc-annotate-color-map)))
+ (while menu-elements
+ (let* ((element (car menu-elements))
+ (days (* element oldest-in-map)))
+ (setq menu-elements (cdr menu-elements))
+ (setq menu-def
+ (append menu-def
+ `([,(format "Span %.1f days" days)
+ (unless (and (numberp vc-annotate-display-mode)
+ (= vc-annotate-display-mode ,days))
+ (vc-annotate-display-select nil ,days))
+ :style toggle :selected
+ (and (numberp vc-annotate-display-mode)
+ (= vc-annotate-display-mode ,days)) ])))))
+ (setq menu-def
+ (append menu-def
+ (list
+ ["Span ..."
+ (let ((days
+ (float (string-to-number
+ (read-string "Span how many days? ")))))
+ (vc-annotate-display-select nil days)) t])
+ (list "--")
+ (list
+ ["Span to Oldest"
+ (unless (eq vc-annotate-display-mode 'scale)
+ (vc-annotate-display-select nil 'scale))
+ :style toggle :selected
+ (eq vc-annotate-display-mode 'scale)])
+ (list
+ ["Span Oldest->Newest"
+ (unless (eq vc-annotate-display-mode 'fullscale)
+ (vc-annotate-display-select nil 'fullscale))
+ :style toggle :selected
+ (eq vc-annotate-display-mode 'fullscale)])))
+ ;; Define the menu
+ (if (or (featurep 'easymenu) (load "easymenu" t))
+ (easy-menu-define vc-annotate-mode-menu vc-annotate-mode-map
+ "VC Annotate Display Menu" menu-def))))
+
+(defun vc-annotate-display-select (&optional buffer mode)
+ "Highlight the output of \\[vc-annotate].
+By default, the current buffer is highlighted, unless overridden by
+BUFFER. `vc-annotate-display-mode' specifies the highlighting mode to
+use; you may override this using the second optional arg MODE."
+ (interactive)
+ (if mode (setq vc-annotate-display-mode mode))
+ (when buffer
+ (set-buffer buffer)
+ (display-buffer buffer))
+ (if (not vc-annotate-mode) ; Turn on vc-annotate-mode if not done
+ (vc-annotate-mode))
+ (cond ((null vc-annotate-display-mode)
+ (vc-annotate-display-default vc-annotate-ratio))
+ ;; One of the auto-scaling modes
+ ((eq vc-annotate-display-mode 'scale)
+ (vc-annotate-display-autoscale))
+ ((eq vc-annotate-display-mode 'fullscale)
+ (vc-annotate-display-autoscale t))
+ ((numberp vc-annotate-display-mode) ; A fixed number of days lookback
+ (vc-annotate-display-default
+ (/ vc-annotate-display-mode (vc-annotate-car-last-cons
+ vc-annotate-color-map))))
+ (t (error "No such display mode: %s"
+ vc-annotate-display-mode))))
+
+;;;; (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 (prefix)
+ "Display the edit history of the current file using colours.
+
+This command creates a buffer that shows, for each line of the current
+file, when it was last edited and by whom. Additionally, colours are
+used to show the age of each line--blue means oldest, red means
+youngest, and intermediate colours indicate intermediate ages. By
+default, the time scale stretches back one year into the past;
+everything that is older than that is shown in blue.
+
+With a prefix argument, this command asks two questions in the
+minibuffer. First, you may enter a version number; then the buffer
+displays and annotates that version instead of the current version
+\(type RET in the minibuffer to leave that default unchanged). Then,
+you are prompted for the time span in days which the color range
+should cover. For example, a time span of 20 days means that changes
+over the past 20 days are shown in red to blue, according to their
+age, and everything that is older than that is shown in blue.
+
+Customization variables:
+
+`vc-annotate-menu-elements' customizes the menu elements of the
+mode-specific menu. `vc-annotate-color-map' and
+`vc-annotate-very-old-color' defines the mapping of time to
+colors. `vc-annotate-background' specifies the background color."
+ (interactive "P")
+ (vc-ensure-vc-buffer)
+ (let* ((temp-buffer-name (concat "*Annotate " (buffer-name) "*"))
+ (temp-buffer-show-function 'vc-annotate-display-select)
+ (rev (vc-workfile-version (buffer-file-name)))
+ (vc-annotate-version
+ (if prefix (read-string
+ (format "Annotate from version: (default %s) " rev)
+ nil nil rev)
+ rev)))
+ (if prefix
+ (setq vc-annotate-display-mode
+ (float (string-to-number
+ (read-string "Annotate span days: (default 20) "
+ nil nil "20")))))
+ (setq vc-annotate-backend (vc-backend (buffer-file-name)))
+ (message "Annotating...")
+ (if (not (vc-find-backend-function vc-annotate-backend 'annotate-command))
+ (error "Sorry, annotating is not implemented for %s"
+ vc-annotate-backend))
+ (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)
+ vc-annotate-version))
+ ;; 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)))
+ (vc-annotate-car-last-cons (cdr a-list))
+ (car (car a-list))))
+
+(defun vc-annotate-time-span (a-list span &optional 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))
+ (append (list (cons (* (car (car a-list)) span)
+ (cdr (car a-list))))
+ (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 A-LIST against THRESHOLD.
+Return the first cons cell with a car that is not less than THRESHOLD,
+nil if no such cell exists."
+ (let ((i 1)
+ (tmp-cons (car a-list)))
+ (while (and tmp-cons (< (car tmp-cons) threshold))
+ (setq tmp-cons (car (nthcdr i a-list)))
+ (setq i (+ i 1)))
+ tmp-cons)) ; Return the appropriate value
+
+(defun vc-annotate-convert-time (time)
+ "Convert a time value to a floating-point number of days.
+The argument TIME is a list as returned by `current-time' or
+`encode-time', only the first two elements of that list are considered."
+ (/ (+ (* (float (car time)) (lsh 1 16)) (cadr time)) 24 3600))
+
+(defun vc-annotate-difference (&optional offset)
+ "Return the time span in days to the next annotation.
+This calls the backend function annotate-time, and returns the
+difference in days between the time returned and the current time,
+or OFFSET if present."
+ (let ((next-time (vc-call-backend vc-annotate-backend 'annotate-time)))
+ (if next-time
+ (- (or offset
+ (vc-call-backend vc-annotate-backend 'annotate-current-time))
+ next-time))))
+
+(defun vc-default-annotate-current-time (backend)
+ "Return the current time, encoded as fractional days."
+ (vc-annotate-convert-time (current-time)))
+
+(defun vc-annotate-display (&optional color-map offset)
+ "Highlight `vc-annotate' output in the current buffer.
+COLOR-MAP, if present, overrides `vc-annotate-color-map'.
+The annotations are relative to the current time, unless overridden by OFFSET."
+ (if (and color-map (not (eq color-map vc-annotate-color-map)))
+ (set (make-local-variable 'vc-annotate-color-map) color-map))
+ (set (make-local-variable 'vc-annotate-offset) offset)
+ (font-lock-mode 1))
+(make-obsolete 'vc-annotate-display 'vc-annotate-display-select "21.4")
+
+(defvar vc-annotate-offset nil)
+
+(defun vc-annotate-lines (limit)
+ (let (difference)
+ (while (and (< (point) limit)
+ (setq difference (vc-annotate-difference vc-annotate-offset)))
+ (let* ((color (or (vc-annotate-compcar difference 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)
+ (put-text-property point (point) 'face face)))
+ ;; Pretend to font-lock there were no matches.
+ nil))
+\f
+;; Collect back-end-dependent stuff here
+
+(defalias 'vc-default-logentry-check 'ignore)
+
+(defun vc-check-headers ()
+ "Check if the current file has any headers in it."
+ (interactive)
+ (vc-call-backend (vc-backend buffer-file-name) 'check-headers))
+
+(defun vc-default-check-headers (backend)
+ "Default implementation of check-headers; always returns nil."
+ nil)
+
+;; Back-end-dependent stuff ends here.
+
+;; Set up key bindings for use while editing log messages
+
+(defun vc-log-edit (file)
+ "Set up `log-edit' for use with VC on FILE."
+ (setq default-directory
+ (if file (file-name-directory file)
+ (with-current-buffer vc-parent-buffer default-directory)))
+ (log-edit 'vc-finish-logentry nil
+ (if file `(lambda () ',(list (file-name-nondirectory file)))
+ ;; If FILE is nil, we were called from vc-dired.
+ (lambda ()
+ (with-current-buffer vc-parent-buffer
+ (dired-get-marked-files t)))))
+ (set (make-local-variable 'vc-log-file) file)
+ (make-local-variable 'vc-log-version)
+ (set-buffer-modified-p nil)
+ (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 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))
+ (if (vc-backend file) (apply func file args))
+ (message "Traversing directory %s..." (abbreviate-file-name file))
+ (let ((dir (file-name-as-directory file)))
+ (mapcar
+ (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)
+
+;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE
+;;
+;; These may be useful to anyone who has to debug or extend the package.
+;; (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-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-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
+;; A B C D E
+;; A . 1 2 3 4 ci -u -t- admin -fb -i<file> initial admin
+;; B 5 . 6 7 8 co -l get -e checkout
+;; C 9 10 . 11 12 co -u unget; get revert
+;; D 13 14 15 . 16 ci -u -m<comment> delta -y<comment>; 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-state and the following checkout (apparent state B).
+;;
+;; Window U:
+;; Between vc-state and the following revert (apparent state C).
+;; Includes windows Q and S.
+;;
+;; Window V:
+;; 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-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 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 <user>". From 5.6.4 onwards, VC uses the new
+;; ci -i option and the message is "<file>,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 "<file>,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
+;; ignored). From 5.6.4 onwards, VC uses the new ci -i option,
+;; failing with message "<file>,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 <user>" message. From 5.6.4 onwards,
+;; VC uses the new ci -i option, failing with message
+;; "<file>,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/<file>: 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 <user>
+;; 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 <rev> locked by <user>; 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
+;; 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 <user>".
+;; 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 <user>
+;; 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
HCoop / bpt / emacs.git / blobdiff