vc.el 132 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

Richard M. Stallman's avatar
Richard M. Stallman committed
8
;; $Id: vc.el,v 1.234 1998/07/08 02:55:50 rms Exp rms $
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
(defvar vc-binary-assoc nil)
509 510 511 512
(defvar vc-binary-suffixes
  (if (memq system-type '(ms-dos windows-nt))
      '(".exe" ".com" ".bat" ".cmd" ".btm" "")
    '("")))
Eric S. Raymond's avatar
Eric S. Raymond committed
513 514 515
(defun vc-find-binary (name)
  "Look for a command anywhere on the subprocess-command search path."
  (or (cdr (assoc name vc-binary-assoc))
516 517 518 519 520
      (catch 'found
	(mapcar
	 (function 
	  (lambda (s)
	    (if s
521 522 523 524 525 526 527 528 529 530 531 532
		(let ((full (concat s "/" name))
		      (suffixes vc-binary-suffixes)
		      candidate)
		  (while suffixes
		    (setq candidate (concat full (car suffixes)))
		    (if (and (file-executable-p candidate)
			     (not (file-directory-p candidate)))
			(progn
			  (setq vc-binary-assoc
				(cons (cons name candidate) vc-binary-assoc))
			  (throw 'found candidate))
		      (setq suffixes (cdr suffixes))))))))
533 534
	 exec-path)
	nil)))
Eric S. Raymond's avatar
Eric S. Raymond committed
535

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

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

605 606 607
;;; 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.
608
;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634
(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))))))))

635 636 637 638 639 640 641 642 643
(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)))))

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

704 705 706 707
    ;; 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))))
708 709 710 711 712
    (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))))))
713

714 715 716 717 718 719 720
(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)))
721 722 723 724 725 726 727 728
    ;; 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))
729 730
    (vc-restore-buffer-context context)))

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

732
(defun vc-buffer-sync (&optional not-urgent)
Eric S. Raymond's avatar
Eric S. Raymond committed
733
  ;; Make sure the current buffer and its working file are in sync
734
  ;; NOT-URGENT means it is ok to continue if the user says not to save.
735
  (if (buffer-modified-p)
736 737 738 739 740 741 742
      (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
743

744
(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
Eric S. Raymond's avatar
Eric S. Raymond committed
745 746 747
  ;; Has the given workfile changed since last checkout?
  (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
	(lastmod (nth 5 (file-attributes file))))
748 749 750
    (or (equal checkout-time lastmod)
	(and (or (not checkout-time) want-differences-if-changed)
	     (let ((unchanged (zerop (vc-backend-diff file nil nil
751
					  (not want-differences-if-changed)))))
752 753 754
	       ;; 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
755

756 757
(defun vc-next-action-on-file (file verbose &optional comment)
  ;;; If comment is specified, it will be used as an admin or checkin comment.
758
  (let ((vc-type (vc-backend file))
759
	owner version buffer)
760 761
    (cond

762 763 764
     ;; If the file is not under version control, register it
     ((not vc-type)
      (vc-register verbose comment))
765

766 767 768 769 770
     ;; 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)))
771 772 773 774
      (if (or vc-dired-mode
	      (yes-or-no-p 
	       (format "%s is not up-to-date.  Merge in changes now? "
		       (buffer-name))))
775
	  (progn
776 777 778 779 780 781 782 783
	    (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)
784
		     (not (yes-or-no-p 
785 786 787
			   (format 
			    "Buffer %s modified; merge file on disc anyhow? " 
			    (buffer-name buffer)))))
788
		(error "Merge aborted"))
789 790 791 792 793 794 795
	    (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)))))
796 797
	(error "%s needs update" (buffer-name))))

798 799 800 801 802 803 804
     ;; 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)))

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

     ;; a checked-out version exists, but the user may not own the lock
847
     ((and (not (eq vc-type 'CVS))
848
	   (not (string-equal owner (vc-user-login-name))))
849
      (if comment
850
	  (error "Sorry, you can't steal the lock on %s this way" file))
851 852
      (and (eq vc-type 'RCS)
	   (not (vc-backend-release-p 'RCS "5.6.2"))
Richard M. Stallman's avatar
Richard M. Stallman committed
853
	   (error "File is locked by %s" owner))
854 855
      (vc-steal-lock
       file
856 857
       (if verbose (read-string "Version to steal: ")
	 (vc-workfile-version file))
858
       owner))
859

860
     ;; OK, user owns the lock on the file
861
     (t
862 863 864
	  (if vc-dired-mode 
	      (find-file-other-window file) 
	    (find-file file))
865

866 867 868 869 870 871 872 873
	  ;; 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"))
874
            ;; if buffer is not saved, give user a chance to do it
875
	    (vc-buffer-sync))
876 877 878 879 880 881

	  ;; 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.
882
	  (if (and (vc-workfile-unchanged-p file) 
883
		   (not (buffer-modified-p)))
884 885 886 887 888
	       ;; 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)))
889 890 891 892 893 894 895

	    ;; 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)
896
	    )))))
897 898

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

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

Jim Blandy's avatar
Jim Blandy committed
922
;;;###autoload
Eric S. Raymond's avatar
Eric S. Raymond committed
923 924
(defun vc-next-action (verbose)
  "Do the next logical checkin or checkout operation on the current file.
925 926 927 928 929 930 931 932
   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.
933 934

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

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

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

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

989
(defun vc-checkout-writable-buffer (&optional file rev)
990
  "Retrieve a writable copy of the latest version of the current buffer's file."
991
  (vc-checkout (or file (buffer-file-name)) t rev)
992 993
  )

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

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