vc.el 131 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.229 1998/06/05 12:46:29 spiegel 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
(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)

157 158 159 160 161 162 163 164 165 166 167 168
(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")

169 170 171 172
(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)
173

174 175 176
(defconst vc-maximum-comment-ring-size 32
  "Maximum number of saved comments in the comment ring.")

177 178 179 180
;;; This is duplicated in diff.el.
(defvar diff-switches "-c"
  "*A string or list of strings specifying switches to be be passed to diff.")

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 210 211 212 213 214 215 216 217 218 219 220 221
(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)

222
;;;###autoload
223
(defcustom vc-checkin-hook nil
Dave Love's avatar
Dave Love committed
224
  "*Normal hook (list of functions) run after a checkin is done.
225 226
See `run-hooks'."
  :type 'hook
Dave Love's avatar
Dave Love committed
227
  :options '(vc-comment-to-change-log)
228
  :group 'vc)
229

230
;;;###autoload
231 232 233 234 235
(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)
236

237 238 239 240 241 242
;;;###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
243 244
;; Header-insertion hair

245
(defcustom vc-header-alist
246
  '((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$"))
247 248 249
  "*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
250 251 252 253 254 255 256 257 258 259
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
260 261 262 263
  '(("\\.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
264 265 266 267 268
version-control type in `vc-header-alist'."
  :type '(repeat (cons :format "%v"
		       (regexp :tag "File Type")
		       (string :tag "Header String")))
  :group 'vc)
269

270
(defcustom vc-comment-alist
Eric S. Raymond's avatar
Eric S. Raymond committed
271 272 273 274
  '((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
275 276 277 278 279 280
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
281

282
;; Default is to be extra careful for super-user.
283
(defcustom vc-checkout-carefully (= (user-uid) 0)
284 285
  "*Non-nil means be extra-careful in checkout.
Verify that the file really is not locked
286 287 288
and that its contents match what the master file says."
  :type 'boolean
  :group 'vc)
289

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

297
(defcustom vc-sccs-release nil
298
  "*The release number of your SCCS installation, as a string.
299 300 301 302
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
303

304
(defcustom vc-cvs-release nil
305
  "*The release number of your CVS installation, as a string.
306 307 308 309
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
310

Eric S. Raymond's avatar
Eric S. Raymond committed
311 312 313
;; Variables the user doesn't need to know about.
(defvar vc-log-entry-mode nil)
(defvar vc-log-operation nil)
314
(defvar vc-log-after-operation-hook nil)
315
(defvar vc-checkout-writable-buffer-hook 'vc-checkout-writable-buffer)
Richard M. Stallman's avatar
Richard M. Stallman committed
316 317 318
;; 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).
319
(defvar vc-parent-buffer nil)
320
(defvar vc-parent-buffer-name nil)
Eric S. Raymond's avatar
Eric S. Raymond committed
321

322 323 324
(defvar vc-log-file)
(defvar vc-log-version)

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

327
(defvar vc-dired-mode nil)
328 329
(make-variable-buffer-local 'vc-dired-mode)

330
(defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size))
331 332 333
(defvar vc-comment-ring-index nil)
(defvar vc-last-comment-match nil)

334 335 336 337 338 339 340
;;; 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
341
	(and (zerop (vc-do-command nil nil "rcs" nil nil "-V"))
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 386 387 388 389 390 391 392 393 394 395 396 397
	     (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))))))

398 399 400 401 402 403
;;; 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))))

404 405 406 407
(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))))

408 409 410 411
(defun vc-branch-part (rev)
  ;; return the branch part of a revision number REV
  (substring rev 0 (string-match "\\.[0-9]+\\'" rev)))

412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431
(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
432 433
;; File property caching

434 435 436 437 438 439
(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.
440
  (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
441

442 443 444 445 446 447 448 449 450 451 452
(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)
453
       (vc-file-setprop file 'vc-master-workfile-version nil)
454 455 456
       (vc-file-setprop file 'vc-master-locks nil))
     (progn
       (vc-file-setprop file 'vc-cvs-status nil))))
457

458 459 460 461 462
(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))))
463

Eric S. Raymond's avatar
Eric S. Raymond committed
464 465
;; Random helper functions

466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
(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
483 484
	 ;; whole current branch.  (vc-master-workfile-version 
         ;; is not what we need.)
485 486 487 488 489 490 491 492 493 494
	 (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
495
     t))
496

497 498 499 500 501 502 503 504 505 506
(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))))))
507

Eric S. Raymond's avatar
Eric S. Raymond committed
508 509 510 511 512
(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))
513 514 515 516 517 518 519 520 521 522 523 524 525
      (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
526

527
(defun vc-do-command (buffer okstatus command file last &rest flags)
Eric S. Raymond's avatar
Eric S. Raymond committed
528
  "Execute a version-control command, notifying user and checking for errors.
529 530 531 532 533 534 535 536 537 538
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."
539
  (and file (setq file (expand-file-name file)))
540
  (if (not buffer) (setq buffer "*vc*"))
Eric S. Raymond's avatar
Eric S. Raymond committed
541
  (if vc-command-messages
542
      (message "Running %s on %s..." command file))
543
  (let ((obuf (current-buffer)) (camefrom (current-buffer))
Eric S. Raymond's avatar
Eric S. Raymond committed
544
	(squeezed nil)
545
	(olddir default-directory)
546
	vc-file status)
547
    (set-buffer (get-buffer-create buffer))
548 549 550
    (set (make-local-variable 'vc-parent-buffer) camefrom)
    (set (make-local-variable 'vc-parent-buffer-name)
	 (concat " from " (buffer-name camefrom)))
551
    (setq default-directory olddir)
552
    
Eric S. Raymond's avatar
Eric S. Raymond committed
553
    (erase-buffer)
554

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

596 597 598
;;; 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.
599
;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625
(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))))))))

626 627 628 629 630 631 632 633 634
(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)))))

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

695 696 697 698
    ;; 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))))
699 700 701 702 703
    (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))))))
704

705 706 707 708 709 710 711
(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)))
712 713 714 715 716 717 718 719
    ;; 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))
720 721
    (vc-restore-buffer-context context)))

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

723
(defun vc-buffer-sync (&optional not-urgent)
Eric S. Raymond's avatar
Eric S. Raymond committed
724
  ;; Make sure the current buffer and its working file are in sync
725
  ;; NOT-URGENT means it is ok to continue if the user says not to save.
726
  (if (buffer-modified-p)
727 728 729 730 731 732 733
      (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
734

735
(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
Eric S. Raymond's avatar
Eric S. Raymond committed
736 737 738
  ;; Has the given workfile changed since last checkout?
  (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
	(lastmod (nth 5 (file-attributes file))))
739 740 741
    (or (equal checkout-time lastmod)
	(and (or (not checkout-time) want-differences-if-changed)
	     (let ((unchanged (zerop (vc-backend-diff file nil nil
742
					  (not want-differences-if-changed)))))
743 744 745
	       ;; 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
746

747 748
(defun vc-next-action-on-file (file verbose &optional comment)
  ;;; If comment is specified, it will be used as an admin or checkin comment.
749
  (let ((vc-type (vc-backend file))
750
	owner version buffer)
751 752
    (cond

753 754 755
     ;; If the file is not under version control, register it
     ((not vc-type)
      (vc-register verbose comment))
756

757 758 759 760 761
     ;; 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)))
762 763 764 765
      (if (or vc-dired-mode
	      (yes-or-no-p 
	       (format "%s is not up-to-date.  Merge in changes now? "
		       (buffer-name))))
766
	  (progn
767 768 769 770 771 772 773 774
	    (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)
775
		     (not (yes-or-no-p 
776 777 778
			   (format 
			    "Buffer %s modified; merge file on disc anyhow? " 
			    (buffer-name buffer)))))
779
		(error "Merge aborted"))
780 781 782 783 784 785 786
	    (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)))))
787 788
	(error "%s needs update" (buffer-name))))

789 790 791 792 793 794 795
     ;; 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)))

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

     ;; a checked-out version exists, but the user may not own the lock
838
     ((and (not (eq vc-type 'CVS))
839
	   (not (string-equal owner (vc-user-login-name))))
840
      (if comment
841
	  (error "Sorry, you can't steal the lock on %s this way" file))
842 843
      (and (eq vc-type 'RCS)
	   (not (vc-backend-release-p 'RCS "5.6.2"))
Richard M. Stallman's avatar
Richard M. Stallman committed
844
	   (error "File is locked by %s" owner))
845 846
      (vc-steal-lock
       file
847 848
       (if verbose (read-string "Version to steal: ")
	 (vc-workfile-version file))
849
       owner))
850

851
     ;; OK, user owns the lock on the file
852
     (t
853 854 855
	  (if vc-dired-mode 
	      (find-file-other-window file) 
	    (find-file file))
856

857 858 859 860 861 862 863 864
	  ;; 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"))
865
            ;; if buffer is not saved, give user a chance to do it
866
	    (vc-buffer-sync))
867 868 869 870 871 872

	  ;; 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.
873
	  (if (and (vc-workfile-unchanged-p file) 
874
		   (not (buffer-modified-p)))
875 876 877 878 879
	       ;; 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)))
880 881 882 883 884 885 886

	    ;; 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)
887
	    )))))
888 889

(defun vc-next-action-dired (file rev comment)
890 891
  ;; Do a vc-next-action-on-file on all the marked files, possibly 
  ;; passing on the log comment we've just entered.
892
  (let ((dired-buffer (current-buffer))
893
	(dired-dir default-directory))
894
    (dired-map-over-marks
895
     (let ((file (dired-get-filename)))
896
       (message "Processing %s..." file)
897 898
       ;; Adjust the default directory so that checkouts
       ;; go to the right place.
899 900 901 902 903 904 905
       (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))
906
       (set-window-configuration vc-dired-window-configuration)
907
       (message "Processing %s...done" file))
908 909
    nil t))
  (dired-move-to-filename))
910

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

Jim Blandy's avatar
Jim Blandy committed
913
;;;###autoload
Eric S. Raymond's avatar
Eric S. Raymond committed
914 915
(defun vc-next-action (verbose)
  "Do the next logical checkin or checkout operation on the current file.
916 917 918 919 920 921 922 923
   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.
924 925

For RCS and SCCS files:
Eric S. Raymond's avatar
Eric S. Raymond committed
926
   If the file is not already registered, this registers it for version
927
control.
Eric S. Raymond's avatar
Eric S. Raymond committed
928
   If the file is registered and not locked by anyone, this checks out
929
a writable and locked file ready for editing.
Eric S. Raymond's avatar
Eric S. Raymond committed
930 931 932
   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.
933 934
   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
935
resulting changes along with the log message as change commentary.  If
936
the variable `vc-keep-workfiles' is non-nil (which is its default), a
Eric S. Raymond's avatar
Eric S. Raymond committed
937 938
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
939
the option to steal the lock.
940 941 942 943 944 945 946 947 948 949

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

Eric S. Raymond's avatar
Eric S. Raymond committed
952
  (interactive "P")
953 954 955
  (catch 'nogo
    (if vc-dired-mode
	(let ((files (dired-get-marked-files)))
956 957
          (set (make-local-variable 'vc-dired-window-configuration)
               (current-window-configuration))
958 959
	  (if (string= "" 
		 (mapconcat
960 961
	             (function (lambda (f)
			 (if (eq (vc-backend f) 'CVS)
962 963
			     (if (or (eq (vc-cvs-status f) 'locally-modified)
				     (eq (vc-cvs-status f) 'locally-added))
964 965 966 967 968 969 970
				 "@" "")
			   (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))
971
	    (throw 'nogo nil)))
972 973 974 975 976
    (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
977 978 979

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

980
(defun vc-checkout-writable-buffer (&optional file rev)
981
  "Retrieve a writable copy of the latest version of the current buffer's file."
982
  (vc-checkout (or file (buffer-file-name)) t rev)
983 984
  )

Jim Blandy's avatar
Jim Blandy committed
985
;;;###autoload
986
(defun vc-register (&optional override comment)
Eric S. Raymond's avatar
Eric S. Raymond committed
987 988
  "Register the current file into your version-control system."
  (interactive "P")
989 990
  (or buffer-file-name
      (error "No visited file"))
991 992 993 994 995 996
  (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")))
997 998 999 1000 1001 1002
  ;; 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
1003
  (vc-buffer-sync)
1004 1005 1006 1007
  (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
1008 1009
  (vc-admin
   buffer-file-name
1010 1011 1012 1013 1014
   (or (and override
            (read-string
             (format "Initial version level for %s: " buffer-file-name)))
       vc-default-init-version)
   comment)
1015
  ;; Recompute backend property (it may have been set to nil before).
1016
  (setq vc-buffer-backend (vc-backend (buffer-file-name)))
Eric S. Raymond's avatar
Eric S. Raymond committed
1017 1018
  )

1019
(defun vc-resynch-window (file &optional keep noquery)
Eric S. Raymond's avatar
Eric S. Raymond committed
1020
  ;; If the given file is in the current buffer,
Karl Heuer's avatar
Karl Heuer committed
1021
  ;; either revert on it so we see expanded keywords,
Eric S. Raymond's avatar
Eric S. Raymond committed
1022
  ;; or unvisit it (depending on vc-keep-workfiles)
1023 1024 1025
  ;; 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
1026 1027 1028
  (and (string= buffer-file-name file)
       (if keep
	   (progn
1029
	     (vc-revert-buffer1 t noquery)
1030 1031 1032 1033 1034 1035 1036 1037
             (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
1038
	     (vc-mode-line buffer-file-name))
1039
	 (kill-buffer (current-buffer)))))
Eric S. Raymond's avatar
Eric S. Raymond committed
1040