vc.el 108 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 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 9 10 11 12 13 14 15 16 17 18 19 20

;; 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
21 22 23
;; 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
24 25 26

;;; Commentary:

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

(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
79

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

99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 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
(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)

(defcustom vc-command-messages nil
  "*If non-nil, display run messages from back-end commands."
  :type 'boolean
  :group 'vc)

(defcustom vc-checkin-switches nil
  "*A string or list of strings specifying extra switches for checkin.
These are passed to the checkin program by \\[vc-checkin]."
  :type '(choice (const :tag "None" nil)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List"
			 :value ("")
			 string))
  :group 'vc)

(defcustom vc-checkout-switches nil
  "*A string or list of strings specifying extra switches for checkout.
These are passed to the checkout program by \\[vc-checkout]."
  :type '(choice (const :tag "None" nil)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List"
			 :value ("")
			 string))
  :group 'vc)

(defcustom vc-register-switches nil
  "*A string or list of strings; extra switches for registering a file.
These are passed to the checkin program by \\[vc-register]."
  :type '(choice (const :tag "None" nil)
		 (string :tag "Argument String")
		 (repeat :tag "Argument List"
			 :value ("")
			 string))
  :group 'vc)

(defcustom vc-directory-exclusion-list '("SCCS" "RCS" "CVS")
  "*List of directory names to be ignored while recursively walking file trees."
  :type '(repeat string)
  :group 'vc)
152

153 154 155
(defconst vc-maximum-comment-ring-size 32
  "Maximum number of saved comments in the comment ring.")

156
;;; This is duplicated in diff.el.
157
;;; ...and customized.
158 159 160
(defvar diff-switches "-c"
  "*A string or list of strings specifying switches to be be passed to diff.")

161
;;;###autoload
162 163 164 165 166
(defcustom vc-checkin-hook nil
  "*Normal hook (List of functions) run after a checkin is done.
See `run-hooks'."
  :type 'hook
  :group 'vc)
167

168
;;;###autoload
169 170 171 172 173
(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)
174

Eric S. Raymond's avatar
Eric S. Raymond committed
175 176
;; Header-insertion hair

177
(defcustom vc-header-alist
178
  '((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$"))
179 180 181
  "*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
182 183 184 185 186 187 188 189 190 191
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
192 193 194 195
  '(("\\.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
196 197 198 199 200
version-control type in `vc-header-alist'."
  :type '(repeat (cons :format "%v"
		       (regexp :tag "File Type")
		       (string :tag "Header String")))
  :group 'vc)
201

202
(defcustom vc-comment-alist
Eric S. Raymond's avatar
Eric S. Raymond committed
203 204 205 206
  '((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
207 208 209 210 211 212
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
213

214
;; Default is to be extra careful for super-user.
215
(defcustom vc-checkout-carefully (= (user-uid) 0)
216 217
  "*Non-nil means be extra-careful in checkout.
Verify that the file really is not locked
218 219 220
and that its contents match what the master file says."
  :type 'boolean
  :group 'vc)
221

222
(defcustom vc-rcs-release nil
223
  "*The release number of your RCS installation, as a string.
224 225 226 227
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
228

229
(defcustom vc-sccs-release nil
230
  "*The release number of your SCCS installation, as a string.
231 232 233 234
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
235

236
(defcustom vc-cvs-release nil
237
  "*The release number of your CVS installation, as a string.
238 239 240 241
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 string)
  :group 'vc)
242

Eric S. Raymond's avatar
Eric S. Raymond committed
243 244 245
;; Variables the user doesn't need to know about.
(defvar vc-log-entry-mode nil)
(defvar vc-log-operation nil)
246
(defvar vc-log-after-operation-hook nil)
247
(defvar vc-checkout-writable-buffer-hook 'vc-checkout-writable-buffer)
Richard M. Stallman's avatar
Richard M. Stallman committed
248 249 250
;; 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).
251
(defvar vc-parent-buffer nil)
252
(defvar vc-parent-buffer-name nil)
Eric S. Raymond's avatar
Eric S. Raymond committed
253

254 255 256
(defvar vc-log-file)
(defvar vc-log-version)

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

259
(defvar vc-dired-mode nil)
260 261
(make-variable-buffer-local 'vc-dired-mode)

262
(defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size))
263 264 265
(defvar vc-comment-ring-index nil)
(defvar vc-last-comment-match nil)

266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283
;; Back-portability to Emacs 18

(defun file-executable-p-18 (f)
  (let ((modes (file-modes f)))
    (and modes (not (zerop (logand 292))))))

(defun file-regular-p-18 (f)
  (let ((attributes (file-attributes f)))
    (and attributes (not (car attributes)))))

; Conditionally rebind some things for Emacs 18 compatibility
(if (not (boundp 'minor-mode-map-alist))
    (progn
      (setq compilation-old-error-list nil)
      (fset 'file-executable-p 'file-executable-p-18)
      (fset 'shrink-window-if-larger-than-buffer 'beginning-of-buffer)
      ))

284
(if (not (fboundp 'file-regular-p))
285 286
    (fset 'file-regular-p 'file-regular-p-18))

287 288 289 290 291 292 293
;;; 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
294
	(and (zerop (vc-do-command nil nil "rcs" nil nil "-V"))
295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350
	     (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))))))

351 352 353 354 355 356 357 358 359 360
;;; functions that operate on RCS revision numbers

(defun vc-trunk-p (rev)
  ;; return t if REV is a revision on the trunk
  (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))

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

Eric S. Raymond's avatar
Eric S. Raymond committed
361 362
;; File property caching

363 364 365 366 367 368
(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.
369
  (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
370

371 372 373 374 375 376 377 378 379 380 381
(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)
382
       (vc-file-setprop file 'vc-master-workfile-version nil)
383 384 385
       (vc-file-setprop file 'vc-master-locks nil))
     (progn
       (vc-file-setprop file 'vc-cvs-status nil))))
386

387 388 389 390 391
(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))))
392

Eric S. Raymond's avatar
Eric S. Raymond committed
393 394
;; Random helper functions

395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411
(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
412 413
	 ;; whole current branch.  (vc-master-workfile-version 
         ;; is not what we need.)
414 415 416 417 418 419 420 421 422 423
	 (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
424
     t))
425

426 427
(defun vc-registration-error (file)
  (if file
428 429
      (error "File %s is not under version control" file)
    (error "Buffer %s is not associated with a file" (buffer-name))))
430

Eric S. Raymond's avatar
Eric S. Raymond committed
431 432 433 434 435
(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))
436 437 438 439 440 441 442 443 444 445 446 447 448
      (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
449

450
(defun vc-do-command (buffer okstatus command file last &rest flags)
Eric S. Raymond's avatar
Eric S. Raymond committed
451
  "Execute a version-control command, notifying user and checking for errors.
452
Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil.  
Eric S. Raymond's avatar
Eric S. Raymond committed
453
The command is successful if its exit status does not exceed OKSTATUS.
454
 (If OKSTATUS is nil, that means to ignore errors.)
455 456 457
The last argument of the command is the master name of FILE if LAST is 
`MASTER', or the workfile of FILE if LAST is `WORKFILE'; this is appended 
to an optional list of FLAGS."
458
  (and file (setq file (expand-file-name file)))
459
  (if (not buffer) (setq buffer "*vc*"))
Eric S. Raymond's avatar
Eric S. Raymond committed
460
  (if vc-command-messages
461
      (message "Running %s on %s..." command file))
462
  (let ((obuf (current-buffer)) (camefrom (current-buffer))
Eric S. Raymond's avatar
Eric S. Raymond committed
463 464
	(squeezed nil)
	(vc-file (and file (vc-name file)))
465
	(olddir default-directory)
Eric S. Raymond's avatar
Eric S. Raymond committed
466
	status)
467
    (set-buffer (get-buffer-create buffer))
468 469 470
    (set (make-local-variable 'vc-parent-buffer) camefrom)
    (set (make-local-variable 'vc-parent-buffer-name)
	 (concat " from " (buffer-name camefrom)))
471
    (setq default-directory olddir)
472
    
Eric S. Raymond's avatar
Eric S. Raymond committed
473
    (erase-buffer)
474

Eric S. Raymond's avatar
Eric S. Raymond committed
475 476 477
    (mapcar
     (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
     flags)
478
    (if (and vc-file (eq last 'MASTER))
Eric S. Raymond's avatar
Eric S. Raymond committed
479
	(setq squeezed (append squeezed (list vc-file))))
480 481 482 483 484 485 486
    (if (eq last 'WORKFILE)
	(progn
	  (let* ((pwd (expand-file-name default-directory))
		 (preflen (length pwd)))
	    (if (string= (substring file 0 preflen) pwd)
		(setq file (substring file preflen))))
	  (setq squeezed (append squeezed (list file)))))
487
    (let ((exec-path (append vc-path exec-path))
488 489 490
	  ;; Add vc-path to PATH for the execution of this command.
	  (process-environment
	   (cons (concat "PATH=" (getenv "PATH")
491 492
			 path-separator
			 (mapconcat 'identity vc-path path-separator))
493
		 process-environment))
494
	  (w32-quote-process-args t))
495
      (setq status (apply 'call-process command nil t nil squeezed)))
Eric S. Raymond's avatar
Eric S. Raymond committed
496
    (goto-char (point-max))
497
    (set-buffer-modified-p nil)
498
    (forward-line -1)
499
    (if (or (not (integerp status)) (and okstatus (< okstatus status)))
Eric S. Raymond's avatar
Eric S. Raymond committed
500
	(progn
501
	  (pop-to-buffer buffer)
Eric S. Raymond's avatar
Eric S. Raymond committed
502
	  (goto-char (point-min))
503
	  (shrink-window-if-larger-than-buffer)
504 505 506 507
	  (error "Running %s...FAILED (%s)" command
		 (if (integerp status)
		     (format "status %d" status)
		   status))
Eric S. Raymond's avatar
Eric S. Raymond committed
508 509
	  )
      (if vc-command-messages
510
	  (message "Running %s...OK" command))
Eric S. Raymond's avatar
Eric S. Raymond committed
511 512 513 514 515
      )
    (set-buffer obuf)
    status)
  )

516 517 518
;;; 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.
519
;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545
(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))))))))

546 547 548
(defun vc-buffer-context ()
  ;; Return a list '(point-context mark-context reparse); from which
  ;; vc-restore-buffer-context can later restore the context.
549
  (let ((point-context (vc-position-context (point)))
550 551 552 553
	;; 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.
554 555 556 557 558 559 560 561
	(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
562 563
			  (mapcar (function
				   (lambda (buffer)
564 565 566 567 568
				    (set-buffer buffer)
				    (let ((errors (or
						   compilation-old-error-list
						   compilation-error-list))
					  (buffer-error-marked-p nil))
569
				      (while (and (consp errors)
570
						  (not buffer-error-marked-p))
571
					(and (markerp (cdr (car errors)))
572 573
					     (eq buffer
						 (marker-buffer
574
						  (cdr (car errors))))
575
					     (setq buffer-error-marked-p t))
576
					(setq errors (cdr errors)))
577
				      (if buffer-error-marked-p buffer))))
578
				  (buffer-list)))))))
579 580 581 582 583 584 585 586
    (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)))
587 588 589 590 591 592 593 594 595 596 597 598 599 600 601
    ;; 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
602
			  (/= error-pos (car (car compilation-error-list))))
603 604
		(setq compilation-error-list (cdr compilation-error-list))))))
      (setq reparse (cdr reparse)))
605

606
    ;; Restore point and mark
607 608 609 610 611 612
    (let ((new-point (vc-find-position-by-context point-context)))
      (if new-point (goto-char new-point)))
    (if mark-context
	(let ((new-mark (vc-find-position-by-context mark-context)))
	  (if new-mark (set-mark new-mark))))))

613 614 615 616 617 618 619
(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)))
620 621
    ;; t means don't call normal-mode; that's to preserve various minor modes.
    (revert-buffer arg no-confirm t)
622 623
    (vc-restore-buffer-context context)))

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

625
(defun vc-buffer-sync (&optional not-urgent)
Eric S. Raymond's avatar
Eric S. Raymond committed
626
  ;; Make sure the current buffer and its working file are in sync
627
  ;; NOT-URGENT means it is ok to continue if the user says not to save.
628
  (if (buffer-modified-p)
629 630 631 632 633 634 635
      (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
636

637
(defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
Eric S. Raymond's avatar
Eric S. Raymond committed
638 639 640
  ;; Has the given workfile changed since last checkout?
  (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
	(lastmod (nth 5 (file-attributes file))))
641 642 643
    (or (equal checkout-time lastmod)
	(and (or (not checkout-time) want-differences-if-changed)
	     (let ((unchanged (zerop (vc-backend-diff file nil nil
644
					  (not want-differences-if-changed)))))
645 646 647
	       ;; 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
648

649 650
(defun vc-next-action-on-file (file verbose &optional comment)
  ;;; If comment is specified, it will be used as an admin or checkin comment.
651
  (let ((vc-file (vc-name file))
652
	(vc-type (vc-backend file))
653
	owner version buffer)
654 655 656 657
    (cond

     ;; if there is no master file corresponding, create one
     ((not vc-file)
658 659 660 661 662
      (vc-register verbose comment)
      (if vc-initial-comment
	  (setq vc-log-after-operation-hook
		'vc-checkout-writable-buffer-hook)
	(vc-checkout-writable-buffer file)))
663

664 665 666 667 668
     ;; 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)))
669 670 671 672
      (if (or vc-dired-mode
	      (yes-or-no-p 
	       (format "%s is not up-to-date.  Merge in changes now? "
		       (buffer-name))))
673
	  (progn
674 675 676 677 678 679 680 681
	    (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)
682
		     (not (yes-or-no-p 
683 684 685
			   (format 
			    "Buffer %s modified; merge file on disc anyhow? " 
			    (buffer-name buffer)))))
686 687 688 689 690 691 692
		(error "Merge aborted"))
	    (if (not (zerop (vc-backend-merge-news file)))
		;; Overlaps detected - what now?  Should use some
		;; fancy RCS conflict resolving package, or maybe
		;; emerge, but for now, simply warn the user with a
		;; message.
		(message "Conflicts detected!"))
693 694
	    (and buffer
		 (vc-resynch-buffer file t (not (buffer-modified-p buffer)))))
695 696
	(error "%s needs update" (buffer-name))))

697 698 699 700 701 702
     ;; If there is no lock on the file, assert one and get it.
     ;; (With implicit checkout, make sure not to lose unsaved changes.)
     ((progn (and (eq (vc-checkout-model file) 'implicit)
                  (buffer-modified-p buffer)
                  (vc-buffer-sync))
             (not (setq owner (vc-locking-user file))))
703
      (if (and vc-checkout-carefully
704
	       (not (vc-workfile-unchanged-p file t)))
705
	  (if (save-window-excursion
706
		(pop-to-buffer "*vc-diff*")
707 708 709 710 711 712 713 714 715 716
		(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
717
		(error "Checkout aborted")
718 719 720
	      (vc-revert-buffer1 t t)
	      (vc-checkout-writable-buffer file))
	    )
721 722
	(if verbose 
	    (if (not (eq vc-type 'SCCS))
723 724
		(vc-checkout file nil 
		   (read-string "Branch or version to move to: "))
Richard M. Stallman's avatar
Richard M. Stallman committed
725
	      (error "Sorry, this is not implemented for SCCS"))
726 727 728 729 730 731 732
	  (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
733 734 735
		     (if (vc-trunk-p (vc-workfile-version file)) 
                         ""  ;; this means check out latest on trunk
                       (vc-branch-part (vc-workfile-version file)))))))
736
	  )))
737 738

     ;; a checked-out version exists, but the user may not own the lock
739
     ((and (not (eq vc-type 'CVS))
740
	   (not (string-equal owner (vc-user-login-name))))
741
      (if comment
742
	  (error "Sorry, you can't steal the lock on %s this way" file))
743 744
      (and (eq vc-type 'RCS)
	   (not (vc-backend-release-p 'RCS "5.6.2"))
Richard M. Stallman's avatar
Richard M. Stallman committed
745
	   (error "File is locked by %s" owner))
746 747
      (vc-steal-lock
       file
748 749
       (if verbose (read-string "Version to steal: ")
	 (vc-workfile-version file))
750
       owner))
751

752
     ;; OK, user owns the lock on the file
753
     (t
754 755 756
	  (if vc-dired-mode 
	      (find-file-other-window file) 
	    (find-file file))
757 758 759 760 761 762 763 764 765

	  ;; give luser a chance to save before checking in.
	  (vc-buffer-sync)

	  ;; Revert if file is unchanged and buffer is too.
	  ;; If buffer is modified, that means the user just said no
	  ;; to saving it; in that case, don't revert,
	  ;; because the user might intend to save
	  ;; after finishing the log entry.
766
	  (if (and (vc-workfile-unchanged-p file) 
767
		   (not (buffer-modified-p)))
768 769 770 771 772
	       ;; 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)))
773 774 775 776 777 778 779

	    ;; 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)
780
	    )))))
781 782

(defun vc-next-action-dired (file rev comment)
783 784 785
  ;; Do a vc-next-action-on-file on all the marked files, possibly 
  ;; passing on the log comment we've just entered.
  (let ((configuration (current-window-configuration))
786 787
	(dired-buffer (current-buffer))
	(dired-dir default-directory))
788
    (dired-map-over-marks
789 790
     (let ((file (dired-get-filename)) p
	   (default-directory default-directory))
791
       (message "Processing %s..." file)
792 793 794
       ;; Adjust the default directory so that checkouts
       ;; go to the right place.
       (setq default-directory (file-name-directory file))
795 796
       (vc-next-action-on-file file nil comment)
       (set-buffer dired-buffer)
797
       (setq default-directory dired-dir)
798 799 800 801
       (vc-dired-update-line file)
       (set-window-configuration configuration)
       (message "Processing %s...done" file))
    nil t)))
802

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

Jim Blandy's avatar
Jim Blandy committed
805
;;;###autoload
Eric S. Raymond's avatar
Eric S. Raymond committed
806 807
(defun vc-next-action (verbose)
  "Do the next logical checkin or checkout operation on the current file.
808 809 810 811 812 813 814 815
   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.
816 817

For RCS and SCCS files:
Eric S. Raymond's avatar
Eric S. Raymond committed
818
   If the file is not already registered, this registers it for version
819
control and then retrieves a writable, locked copy for editing.
Eric S. Raymond's avatar
Eric S. Raymond committed
820
   If the file is registered and not locked by anyone, this checks out
821
a writable and locked file ready for editing.
Eric S. Raymond's avatar
Eric S. Raymond committed
822 823 824
   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.
825 826
   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
827
resulting changes along with the log message as change commentary.  If
828
the variable `vc-keep-workfiles' is non-nil (which is its default), a
Eric S. Raymond's avatar
Eric S. Raymond committed
829 830
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
831
the option to steal the lock.
832 833 834 835 836 837 838 839 840 841

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

Eric S. Raymond's avatar
Eric S. Raymond committed
844
  (interactive "P")
845 846 847
  (catch 'nogo
    (if vc-dired-mode
	(let ((files (dired-get-marked-files)))
848 849
	  (if (string= "" 
		 (mapconcat
850 851
	             (function (lambda (f)
			 (if (eq (vc-backend f) 'CVS)
852 853
			     (if (or (eq (vc-cvs-status f) 'locally-modified)
				     (eq (vc-cvs-status f) 'locally-added))
854 855 856 857 858 859 860
				 "@" "")
			   (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))
861
	    (throw 'nogo nil)))
862
    (while vc-parent-buffer
863
      (pop-to-buffer vc-parent-buffer))
864 865
    (if buffer-file-name
	(vc-next-action-on-file buffer-file-name verbose)
866
      (vc-registration-error nil))))
Eric S. Raymond's avatar
Eric S. Raymond committed
867 868 869

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

870
(defun vc-checkout-writable-buffer (&optional file rev)
871
  "Retrieve a writable copy of the latest version of the current buffer's file."
872
  (vc-checkout (or file (buffer-file-name)) t rev)
873 874
  )

Jim Blandy's avatar
Jim Blandy committed
875
;;;###autoload
876
(defun vc-register (&optional override comment)
Eric S. Raymond's avatar
Eric S. Raymond committed
877 878
  "Register the current file into your version-control system."
  (interactive "P")
879 880
  (or buffer-file-name
      (error "No visited file"))
881 882 883 884 885 886
  (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")))
887 888 889 890 891 892
  ;; 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
893
  (vc-buffer-sync)
894 895 896 897
  (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
898 899
  (vc-admin
   buffer-file-name
900 901 902
   (and override
	(read-string
	 (format "Initial version level for %s: " buffer-file-name))))
Eric S. Raymond's avatar
Eric S. Raymond committed
903 904
  )

905
(defun vc-resynch-window (file &optional keep noquery)
Eric S. Raymond's avatar
Eric S. Raymond committed
906
  ;; If the given file is in the current buffer,
Karl Heuer's avatar
Karl Heuer committed
907
  ;; either revert on it so we see expanded keywords,
Eric S. Raymond's avatar
Eric S. Raymond committed
908
  ;; or unvisit it (depending on vc-keep-workfiles)
909 910 911
  ;; 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
912 913 914
  (and (string= buffer-file-name file)
       (if keep
	   (progn
915 916 917
	     ;; temporarily remove vc-find-file-hook, so that
             ;; we don't lose the properties
	     (remove-hook 'find-file-hooks 'vc-find-file-hook)
918
	     (vc-revert-buffer1 t noquery)
919
	     (add-hook 'find-file-hooks 'vc-find-file-hook)
Eric S. Raymond's avatar
Eric S. Raymond committed
920
	     (vc-mode-line buffer-file-name))
921
	 (kill-buffer (current-buffer)))))
Eric S. Raymond's avatar
Eric S. Raymond committed
922

923
(defun vc-resynch-buffer (file &optional keep noquery)
924
  ;; if FILE is currently visited, resynch its buffer
925 926 927 928 929 930
  (let ((buffer (get-file-buffer file)))
    (if buffer
	(save-excursion
	  (set-buffer buffer)
	  (vc-resynch-window file keep noquery)))))

931
(defun vc-start-entry (file rev comment msg action &optional after-hook)
932 933 934
  ;; Accept a comment for an operation on FILE revision REV.  If COMMENT
  ;; is nil, pop up a VC-log buffer, emit MSG, and set the
  ;; action on close to ACTION; otherwise, do action immediately.
935
  ;; Remember the file's buffer in vc-parent-buffer (current one if no file).
936
  ;; AFTER-HOOK specifies the local value for vc-log-operation-hook.
937
  (let ((parent (if file (find-file-noselect file) (current-buffer))))
938 939 940 941 942 943
    (if vc-before-checkin-hook
        (if file
            (save-excursion 
              (set-buffer parent)
              (run-hooks 'vc-before-checkin-hook))
          (run-hooks 'vc-before-checkin-hook)))
944 945 946
    (if comment
	(set-buffer (get-buffer-create "*VC-log*"))
      (pop-to-buffer (get-buffer-create "*VC-log*")))
947 948 949
    (set (make-local-variable 'vc-parent-buffer) parent)
    (set (make-local-variable 'vc-parent-buffer-name)
	 (concat " from " (buffer-name vc-parent-buffer)))
950
    (if file (vc-mode-line file))
951
    (vc-log-mode file)
952 953 954
    (make-local-variable 'vc-log-after-operation-hook)
    (if after-hook
	(setq vc-log-after-operation-hook after-hook))
955 956 957 958 959
    (setq vc-log-operation action)
    (setq vc-log-version rev)
    (if comment
	(progn
	  (erase-buffer)
960 961 962 963
	  (if (eq comment t)
	      (vc-finish-logentry t)
	    (insert comment)
	    (vc-finish-logentry nil)))
964
      (message "%s  Type C-c C-c when done." msg))))
Eric S. Raymond's avatar
Eric S. Raymond committed
965

966
(defun vc-admin (file rev &optional comment)
967
  "Check a file into your version-control system.
Eric S. Raymond's avatar
Eric S. Raymond committed
968
FILE is the unmodified name of the file.  REV should be the base version
969
level to check it in under.  COMMENT, if specified, is the checkin comment."
970 971 972
  (vc-start-entry file rev
		  (or comment (not vc-initial-comment))
		  "Enter initial comment." 'vc-backend-admin
973
		  nil))
974

975
(defun vc-checkout (file &optional writable rev)
976 977 978 979 980
  "Retrieve a copy of the latest version of the given file."
  ;; If ftp is on this system and the name matches the ange-ftp format
  ;; for a remote file, the user is trying something that won't work.
  (if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp"))
      (error "Sorry, you can't check out files over FTP"))
981
  (vc-backend-checkout file writable rev)
982
  (vc-resynch-buffer file t t))
Eric S. Raymond's avatar
Eric S. Raymond committed
983 984 985

(defun vc-steal-lock (file rev &optional owner)
  "Steal the lock on the current workfile."
986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000
  (let (file-description)
    (if (not owner)
	(setq owner (vc-locking-user file)))
    (if rev
	(setq file-description (format "%s:%s" file rev))
      (setq file-description file))
    (if (not (y-or-n-p (format "Take the lock on %s from %s? "
			       file-description owner)))
	(error "Steal cancelled"))
    (pop-to-buffer (get-buffer-create "*VC-mail*"))
    (setq default-directory