vc.el 129 KB
Newer Older
Eric S. Raymond's avatar
Eric S. Raymond committed
1 2
;;; vc.el --- drive a version-control system from within Emacs

3
;; Copyright (C) 1992, 93, 94, 95, 96, 97, 1998 Free Software Foundation, Inc.
Eric S. Raymond's avatar
Eric S. Raymond committed
4

5 6
;; Author:     Eric S. Raymond <esr@snark.thyrsus.com>
;; Maintainer: Andre Spiegel <spiegel@inf.fu-berlin.de>
Eric S. Raymond's avatar
Eric S. Raymond committed
7

8
;; $Id: vc.el,v 1.227 1998/05/16 17:53:32 rms Exp spiegel $
9

Eric S. Raymond's avatar
Eric S. Raymond committed
10 11 12 13 14 15 16 17 18 19 20 21 22
;; 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
Erik Naggum's avatar
Erik Naggum committed
23 24 25
;; 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.
Eric S. Raymond's avatar
Eric S. Raymond committed
26 27 28

;;; Commentary:

29 30
;; This mode is fully documented in the Emacs user's manual.
;;
Eric S. Raymond's avatar
Eric S. Raymond committed
31 32 33
;; 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.
34
;; CVS support was added by Per Cederqvist <ceder@lysator.liu.se>
35
;; in Jan-Feb 1994.  Further enhancements came from ttn@netcom.com and
36
;; Andre Spiegel <spiegel@inf.fu-berlin.de>.
Eric S. Raymond's avatar
Eric S. Raymond committed
37
;;
38
;; Supported version-control systems presently include SCCS, RCS, and CVS.
39 40 41 42 43
;;
;; 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).
44 45 46
;; 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. 
Eric S. Raymond's avatar
Eric S. Raymond committed
47
;;
48 49
;; You can support the RCS -x option by adding pairs to the 
;; vc-master-templates list.
Eric S. Raymond's avatar
Eric S. Raymond committed
50 51 52 53
;;
;; Proper function of the SCCS diff commands requires the shellscript vcdiff
;; to be installed somewhere on Emacs's path for executables.
;;
54
;; If your site uses the ChangeLog convention supported by Emacs, the
55
;; function vc-comment-to-change-log should prove a useful checkin hook.
56
;;
Eric S. Raymond's avatar
Eric S. Raymond committed
57
;; This code depends on call-process passing back the subprocess exit
58
;; status.  Thus, you need Emacs 18.58 or later to run it.  For the
59
;; vc-directory command to work properly as documented, you need 19.
60
;; You also need Emacs 19's ring.el.
Eric S. Raymond's avatar
Eric S. Raymond committed
61 62 63
;;
;; The vc code maintains some internal state in order to reduce expensive
;; version-control operations to a minimum.  Some names are only computed
64
;; once.  If you perform version control operations with RCS/SCCS/CVS while
Eric S. Raymond's avatar
Eric S. Raymond committed
65 66 67 68 69 70 71 72 73
;; 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)
74
(require 'ring)
75
(eval-when-compile (require 'dired))	; for dired-map-over-marks macro
76 77 78 79 80

(if (not (assoc 'vc-parent-buffer minor-mode-alist))
    (setq minor-mode-alist
	  (cons '(vc-parent-buffer vc-parent-buffer-name)
		minor-mode-alist)))
Eric S. Raymond's avatar
Eric S. Raymond committed
81

82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98
;; 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))
	      )))

Eric S. Raymond's avatar
Eric S. Raymond committed
99 100
;; General customization

101 102 103 104 105 106 107 108 109 110 111 112 113 114
(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-initial-comment nil
  "*If non-nil, prompt for initial comment when a file is registered."
  :type 'boolean
  :group 'vc)

115 116 117 118
(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
Dan Nicolaescu's avatar
Dan Nicolaescu committed
119 120
  :group 'vc
  :version "20.3")
121

122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160
(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-directory-exclusion-list '("SCCS" "RCS" "CVS")
  "*List of directory names to be ignored while recursively walking file trees."
  :type '(repeat string)
  :group 'vc)
161

162 163 164
(defconst vc-maximum-comment-ring-size 32
  "Maximum number of saved comments in the comment ring.")

165 166 167 168
;;; This is duplicated in diff.el.
(defvar diff-switches "-c"
  "*A string or list of strings specifying switches to be be passed to diff.")

169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209
(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)

210
;;;###autoload
211
(defcustom vc-checkin-hook nil
Dave Love's avatar
Dave Love committed
212
  "*Normal hook (list of functions) run after a checkin is done.
213 214
See `run-hooks'."
  :type 'hook
Dave Love's avatar
Dave Love committed
215
  :options '(vc-comment-to-change-log)
216
  :group 'vc)
217

218
;;;###autoload
219 220 221 222 223
(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)
224

225 226 227 228 229 230
;;;###autoload
(defcustom vc-annotate-mode-hook nil
  "*Hooks to run when VC-Annotate mode is turned on."
  :type 'hook
  :group 'vc)

Eric S. Raymond's avatar
Eric S. Raymond committed
231 232
;; Header-insertion hair

233
(defcustom vc-header-alist
234
  '((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$"))
235 236 237
  "*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
238 239 240 241 242 243 244 245 246 247
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
Eric S. Raymond's avatar
Eric S. Raymond committed
248 249 250 251
  '(("\\.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
252 253 254 255 256
version-control type in `vc-header-alist'."
  :type '(repeat (cons :format "%v"
		       (regexp :tag "File Type")
		       (string :tag "Header String")))
  :group 'vc)
257

258
(defcustom vc-comment-alist
Eric S. Raymond's avatar
Eric S. Raymond committed
259 260 261 262
  '((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
263 264 265 266 267 268
is sensitive to blank lines."
  :type '(repeat (list :format "%v"
		       (symbol :tag "Mode")
		       (string :tag "Comment Start")
		       (string :tag "Comment End")))
  :group 'vc)
Eric S. Raymond's avatar
Eric S. Raymond committed
269

270
;; Default is to be extra careful for super-user.
271
(defcustom vc-checkout-carefully (= (user-uid) 0)
272 273
  "*Non-nil means be extra-careful in checkout.
Verify that the file really is not locked
274 275 276
and that its contents match what the master file says."
  :type 'boolean
  :group 'vc)
277

278
(defcustom vc-rcs-release nil
279
  "*The release number of your RCS installation, as a string.
280 281 282 283
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
284

285
(defcustom vc-sccs-release nil
286
  "*The release number of your SCCS installation, as a string.
287 288 289 290
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
291

292
(defcustom vc-cvs-release nil
293
  "*The release number of your CVS installation, as a string.
294 295 296 297
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
298

Eric S. Raymond's avatar
Eric S. Raymond committed
299 300 301
;; Variables the user doesn't need to know about.
(defvar vc-log-entry-mode nil)
(defvar vc-log-operation nil)
302
(defvar vc-log-after-operation-hook nil)
303
(defvar vc-checkout-writable-buffer-hook 'vc-checkout-writable-buffer)
Richard M. Stallman's avatar
Richard M. Stallman committed
304 305 306
;; 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).
307
(defvar vc-parent-buffer nil)
308
(defvar vc-parent-buffer-name nil)
Eric S. Raymond's avatar
Eric S. Raymond committed
309

310 311 312
(defvar vc-log-file)
(defvar vc-log-version)

Eric S. Raymond's avatar
Eric S. Raymond committed
313 314
(defconst vc-name-assoc-file "VC-names")

315
(defvar vc-dired-mode nil)
316 317
(make-variable-buffer-local 'vc-dired-mode)

318
(defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size))
319 320 321
(defvar vc-comment-ring-index nil)
(defvar vc-last-comment-match nil)

322 323 324 325 326 327 328
;;; 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
329
	(and (zerop (vc-do-command nil nil "rcs" nil nil "-V"))
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385
	     (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))))))

386 387 388 389 390 391
;;; 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))))

392 393 394 395
(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))))

396 397 398 399
(defun vc-branch-part (rev)
  ;; return the branch part of a revision number REV
  (substring rev 0 (string-match "\\.[0-9]+\\'" rev)))

400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419
(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)))))

Eric S. Raymond's avatar
Eric S. Raymond committed
420 421
;; File property caching

422 423 424 425 426 427
(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.
428
  (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
429

430 431 432 433 434 435 436 437 438 439 440
(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)
441
       (vc-file-setprop file 'vc-master-workfile-version nil)
442 443 444
       (vc-file-setprop file 'vc-master-locks nil))
     (progn
       (vc-file-setprop file 'vc-cvs-status nil))))
445

446 447 448 449 450
(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))))
451

Eric S. Raymond's avatar
Eric S. Raymond committed
452 453
;; Random helper functions

454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470
(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
471 472
	 ;; whole current branch.  (vc-master-workfile-version 
         ;; is not what we need.)
473 474 475 476 477 478 479 480 481 482
	 (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
483
     t))
484

485 486 487 488 489 490 491 492 493 494
(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))))))
495

Eric S. Raymond's avatar
Eric S. Raymond committed
496 497 498 499 500
(defvar vc-binary-assoc nil)

(defun vc-find-binary (name)
  "Look for a command anywhere on the subprocess-command search path."
  (or (cdr (assoc name vc-binary-assoc))
501 502 503 504 505 506 507 508 509 510 511 512 513
      (catch 'found
	(mapcar
	 (function 
	  (lambda (s)
	    (if s
		(let ((full (concat s "/" name)))
		  (if (file-executable-p full)
		      (progn
			(setq vc-binary-assoc
			      (cons (cons name full) vc-binary-assoc))
			(throw 'found full)))))))
	 exec-path)
	nil)))
Eric S. Raymond's avatar
Eric S. Raymond committed
514

515
(defun vc-do-command (buffer okstatus command file last &rest flags)
Eric S. Raymond's avatar
Eric S. Raymond committed
516
  "Execute a version-control command, notifying user and checking for errors.
517 518 519 520 521 522 523 524 525 526
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."
527
  (and file (setq file (expand-file-name file)))
528
  (if (not buffer) (setq buffer "*vc*"))
Eric S. Raymond's avatar
Eric S. Raymond committed
529
  (if vc-command-messages
530
      (message "Running %s on %s..." command file))
531
  (let ((obuf (current-buffer)) (camefrom (current-buffer))
Eric S. Raymond's avatar
Eric S. Raymond committed
532
	(squeezed nil)
533
	(olddir default-directory)
534
	vc-file status)
535
    (set-buffer (get-buffer-create buffer))
536 537 538
    (set (make-local-variable 'vc-parent-buffer) camefrom)
    (set (make-local-variable 'vc-parent-buffer-name)
	 (concat " from " (buffer-name camefrom)))
539
    (setq default-directory olddir)
540
    
Eric S. Raymond's avatar
Eric S. Raymond committed
541
    (erase-buffer)
542

Eric S. Raymond's avatar
Eric S. Raymond committed
543 544 545
    (mapcar
     (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
     flags)
546
    (if (and (eq last 'MASTER) file (setq vc-file (vc-name file)))
Eric S. Raymond's avatar
Eric S. Raymond committed
547
	(setq squeezed (append squeezed (list vc-file))))
548
    (if (and file (eq last 'WORKFILE))
549 550 551 552 553 554
	(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)))))
555
    (let ((exec-path (append vc-path exec-path))
556 557 558
	  ;; Add vc-path to PATH for the execution of this command.
	  (process-environment
	   (cons (concat "PATH=" (getenv "PATH")
559 560
			 path-separator
			 (mapconcat 'identity vc-path path-separator))
561
		 process-environment))
562
	  (w32-quote-process-args t))
563
      (setq status (apply 'call-process command nil t nil squeezed)))
Eric S. Raymond's avatar
Eric S. Raymond committed
564
    (goto-char (point-max))
565
    (set-buffer-modified-p nil)
566
    (forward-line -1)
567
    (if (or (not (integerp status)) (and okstatus (< okstatus status)))
Eric S. Raymond's avatar
Eric S. Raymond committed
568
	(progn
569
	  (pop-to-buffer buffer)
Eric S. Raymond's avatar
Eric S. Raymond committed
570
	  (goto-char (point-min))
571
	  (shrink-window-if-larger-than-buffer)
572 573 574 575
	  (error "Running %s...FAILED (%s)" command
		 (if (integerp status)
		     (format "status %d" status)
		   status))
Eric S. Raymond's avatar
Eric S. Raymond committed
576 577
	  )
      (if vc-command-messages
578
	  (message "Running %s...OK" command))
Eric S. Raymond's avatar
Eric S. Raymond committed
579 580 581 582 583
      )
    (set-buffer obuf)
    status)
  )

584 585 586
;;; 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.
587
;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613
(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))))))))

614 615 616 617 618 619 620 621 622
(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)))))

623 624 625
(defun vc-buffer-context ()
  ;; Return a list '(point-context mark-context reparse); from which
  ;; vc-restore-buffer-context can later restore the context.
626
  (let ((point-context (vc-position-context (point)))
627 628 629 630
	;; 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.
631 632 633 634 635 636 637 638
	(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
639 640
			  (mapcar (function
				   (lambda (buffer)
641 642 643 644 645
				    (set-buffer buffer)
				    (let ((errors (or
						   compilation-old-error-list
						   compilation-error-list))
					  (buffer-error-marked-p nil))
646
				      (while (and (consp errors)
647
						  (not buffer-error-marked-p))
648
					(and (markerp (cdr (car errors)))
649 650
					     (eq buffer
						 (marker-buffer
651
						  (cdr (car errors))))
652
					     (setq buffer-error-marked-p t))
653
					(setq errors (cdr errors)))
654
				      (if buffer-error-marked-p buffer))))
655
				  (buffer-list)))))))
656 657 658 659 660 661 662 663
    (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)))
664 665 666 667 668 669 670 671 672 673 674 675 676 677 678
    ;; 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
679
			  (/= error-pos (car (car compilation-error-list))))
680 681
		(setq compilation-error-list (cdr compilation-error-list))))))
      (setq reparse (cdr reparse)))
682

683 684 685 686
    ;; 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))))
687 688 689 690 691
    (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))))))
692

693 694 695 696 697 698 699
(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)))
700 701 702 703 704 705 706 707
    ;; 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))
708 709
    (vc-restore-buffer-context context)))

Eric S. Raymond's avatar
Eric S. Raymond committed
710

711
(defun vc-buffer-sync (&optional not-urgent)
Eric S. Raymond's avatar
Eric S. Raymond committed
712
  ;; Make sure the current buffer and its working file are in sync
713
  ;; NOT-URGENT means it is ok to continue if the user says not to save.
714
  (if (buffer-modified-p)
715 716 717 718 719 720 721
      (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")))))

Eric S. Raymond's avatar
Eric S. Raymond committed
722

723
(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
Eric S. Raymond's avatar
Eric S. Raymond committed
724 725 726
  ;; Has the given workfile changed since last checkout?
  (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
	(lastmod (nth 5 (file-attributes file))))
727 728 729
    (or (equal checkout-time lastmod)
	(and (or (not checkout-time) want-differences-if-changed)
	     (let ((unchanged (zerop (vc-backend-diff file nil nil
730
					  (not want-differences-if-changed)))))
731 732 733
	       ;; 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)))))
Eric S. Raymond's avatar
Eric S. Raymond committed
734

735 736
(defun vc-next-action-on-file (file verbose &optional comment)
  ;;; If comment is specified, it will be used as an admin or checkin comment.
737
  (let ((vc-type (vc-backend file))
738
	owner version buffer)
739 740
    (cond

741 742 743
     ;; If the file is not under version control, register it
     ((not vc-type)
      (vc-register verbose comment))
744

745 746 747 748 749
     ;; 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)))
750 751 752 753
      (if (or vc-dired-mode
	      (yes-or-no-p 
	       (format "%s is not up-to-date.  Merge in changes now? "
		       (buffer-name))))
754
	  (progn
755 756 757 758 759 760 761 762
	    (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)
763
		     (not (yes-or-no-p 
764 765 766
			   (format 
			    "Buffer %s modified; merge file on disc anyhow? " 
			    (buffer-name buffer)))))
767
		(error "Merge aborted"))
768 769 770 771 772 773 774
	    (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)))))
775 776
	(error "%s needs update" (buffer-name))))

777 778 779 780 781 782 783
     ;; 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)))

784
     ;; If there is no lock on the file, assert one and get it.
785 786 787 788 789
     ((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))
790
      (if (and vc-checkout-carefully
791
	       (not (vc-workfile-unchanged-p file t)))
792
	  (if (save-window-excursion
793
		(pop-to-buffer "*vc-diff*")
794 795 796 797 798 799 800 801 802 803
		(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? "))
Richard M. Stallman's avatar
Richard M. Stallman committed
804
		(error "Checkout aborted")
805 806 807
	      (vc-revert-buffer1 t t)
	      (vc-checkout-writable-buffer file))
	    )
808 809
	(if verbose 
	    (if (not (eq vc-type 'SCCS))
810 811
		(vc-checkout file nil 
		   (read-string "Branch or version to move to: "))
Richard M. Stallman's avatar
Richard M. Stallman committed
812
	      (error "Sorry, this is not implemented for SCCS"))
813 814 815 816 817 818 819
	  (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
820 821 822
		     (if (vc-trunk-p (vc-workfile-version file)) 
                         ""  ;; this means check out latest on trunk
                       (vc-branch-part (vc-workfile-version file)))))))
823
	  )))
824 825

     ;; a checked-out version exists, but the user may not own the lock
826
     ((and (not (eq vc-type 'CVS))
827
	   (not (string-equal owner (vc-user-login-name))))
828
      (if comment
829
	  (error "Sorry, you can't steal the lock on %s this way" file))
830 831
      (and (eq vc-type 'RCS)
	   (not (vc-backend-release-p 'RCS "5.6.2"))
Richard M. Stallman's avatar
Richard M. Stallman committed
832
	   (error "File is locked by %s" owner))
833 834
      (vc-steal-lock
       file
835 836
       (if verbose (read-string "Version to steal: ")
	 (vc-workfile-version file))
837
       owner))
838

839
     ;; OK, user owns the lock on the file
840
     (t
841 842 843
	  (if vc-dired-mode 
	      (find-file-other-window file) 
	    (find-file file))
844

845 846 847 848 849 850 851 852
	  ;; 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"))
853
            ;; if buffer is not saved, give user a chance to do it
854
	    (vc-buffer-sync))
855 856 857 858 859 860

	  ;; 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.
861
	  (if (and (vc-workfile-unchanged-p file) 
862
		   (not (buffer-modified-p)))
863 864 865 866 867
	       ;; 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)))
868 869 870 871 872 873 874

	    ;; 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)
875
	    )))))
876 877

(defun vc-next-action-dired (file rev comment)
878 879
  ;; Do a vc-next-action-on-file on all the marked files, possibly 
  ;; passing on the log comment we've just entered.
880
  (let ((dired-buffer (current-buffer))
881
	(dired-dir default-directory))
882
    (dired-map-over-marks
883 884
     (let ((file (dired-get-filename)) p
	   (default-directory default-directory))
885
       (message "Processing %s..." file)
886 887 888
       ;; Adjust the default directory so that checkouts
       ;; go to the right place.
       (setq default-directory (file-name-directory file))
889 890
       (vc-next-action-on-file file nil comment)
       (set-buffer dired-buffer)
891
       (setq default-directory dired-dir)
892 893
       (dired-do-redisplay file)
       (set-window-configuration vc-dired-window-configuration)
894
       (message "Processing %s...done" file))
895 896
    nil t))
  (dired-move-to-filename))
897

Jim Blandy's avatar
Jim Blandy committed
898
;; Here's the major entry point.
Eric S. Raymond's avatar
Eric S. Raymond committed
899

Jim Blandy's avatar
Jim Blandy committed
900
;;;###autoload
Eric S. Raymond's avatar
Eric S. Raymond committed
901 902
(defun vc-next-action (verbose)
  "Do the next logical checkin or checkout operation on the current file.
903 904 905 906 907 908 909 910
   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.
911 912

For RCS and SCCS files:
Eric S. Raymond's avatar
Eric S. Raymond committed
913
   If the file is not already registered, this registers it for version
914
control.
Eric S. Raymond's avatar
Eric S. Raymond committed
915
   If the file is registered and not locked by anyone, this checks out
916
a writable and locked file ready for editing.
Eric S. Raymond's avatar
Eric S. Raymond committed
917 918 919
   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.
920 921
   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
Eric S. Raymond's avatar
Eric S. Raymond committed
922
resulting changes along with the log message as change commentary.  If
923
the variable `vc-keep-workfiles' is non-nil (which is its default), a
Eric S. Raymond's avatar
Eric S. Raymond committed
924 925
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
926
the option to steal the lock.
927 928 929 930 931 932 933 934 935 936

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
937
merge in the changes into your working copy."
938

Eric S. Raymond's avatar
Eric S. Raymond committed
939
  (interactive "P")
940 941 942
  (catch 'nogo
    (if vc-dired-mode
	(let ((files (dired-get-marked-files)))
943 944
          (set (make-local-variable 'vc-dired-window-configuration)
               (current-window-configuration))
945 946
	  (if (string= "" 
		 (mapconcat
947 948
	             (function (lambda (f)
			 (if (eq (vc-backend f) 'CVS)
949 950
			     (if (or (eq (vc-cvs-status f) 'locally-modified)
				     (eq (vc-cvs-status f) 'locally-added))
951 952 953 954 955 956 957
				 "@" "")
			   (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))
958
	    (throw 'nogo nil)))
959 960 961 962 963
    (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)))))
Eric S. Raymond's avatar
Eric S. Raymond committed
964 965 966

;;; These functions help the vc-next-action entry point

967
(defun vc-checkout-writable-buffer (&optional file rev)
968
  "Retrieve a writable copy of the latest version of the current buffer's file."
969
  (vc-checkout (or file (buffer-file-name)) t rev)
970 971
  )

Jim Blandy's avatar
Jim Blandy committed
972
;;;###autoload
973
(defun vc-register (&optional override comment)
Eric S. Raymond's avatar
Eric S. Raymond committed
974 975
  "Register the current file into your version-control system."
  (interactive "P")
976 977
  (or buffer-file-name
      (error "No visited file"))
978 979 980 981 982 983
  (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")))
984 985 986 987 988 989
  ;; 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))
Eric S. Raymond's avatar
Eric S. Raymond committed
990
  (vc-buffer-sync)
991 992 993 994
  (cond ((not vc-make-backup-files)
	 ;; inhibit backup for this buffer
	 (make-local-variable 'backup-inhibited)
	 (setq backup-inhibited t)))
Eric S. Raymond's avatar
Eric S. Raymond committed
995 996
  (vc-admin
   buffer-file-name
997 998 999 1000 1001
   (or (and override
            (read-string
             (format "Initial version level for %s: " buffer-file-name)))
       vc-default-init-version)
   comment)
1002
  ;; Recompute backend property (it may have been set to nil before).
1003
  (setq vc-buffer-backend (vc-backend (buffer-file-name)))
Eric S. Raymond's avatar
Eric S. Raymond committed
1004 1005
  )

1006
(defun vc-resynch-window (file &optional keep noquery)
Eric S. Raymond's avatar
Eric S. Raymond committed
1007
  ;; If the given file is in the current buffer,
Karl Heuer's avatar
Karl Heuer committed
1008
  ;; either revert on it so we see expanded keywords,
Eric S. Raymond's avatar
Eric S. Raymond committed
1009
  ;; or unvisit it (depending on vc-keep-workfiles)
1010 1011 1012
  ;; 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!
Eric S. Raymond's avatar
Eric S. Raymond committed
1013 1014 1015
  (and (string= buffer-file-name file)
       (if keep
	   (progn
1016
	     (vc-revert-buffer1 t noquery)
1017 1018 1019 1020 1021 1022 1023 1024
             (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))))
Eric S. Raymond's avatar
Eric S. Raymond committed
1025
	     (vc-mode-line buffer-file-name))
1026
	 (kill-buffer (current-buffer)))))
Eric S. Raymond's avatar
Eric S. Raymond committed
1027

1028
(defun vc-resynch-buffer (file &optional keep noquery)
1029
  ;; if FILE is currently visited, resynch its buffer
1030 1031 1032 1033 1034 1035 1036
  (if (string= buffer-file-name file)
      (vc-resynch-window file keep