vc-rcs.el 62.5 KB
Newer Older
1
;;; vc-rcs.el --- support for RCS version-control  -*- lexical-binding:t -*-
2

3
;; Copyright (C) 1992-2014 Free Software Foundation, Inc.
4 5 6

;; Author:     FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
7
;; Package: vc
8 9 10

;; This file is part of GNU Emacs.

11
;; GNU Emacs is free software: you can redistribute it and/or modify
12
;; it under the terms of the GNU General Public License as published by
13 14
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
15 16 17 18 19 20 21

;; 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
22
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
23

24 25 26
;;; Commentary:

;; See vc.el
27

28
;; Some features will not work with ancient RCS versions.  Where
29
;; appropriate, VC finds out which version you have, and allows or
30 31
;; disallows those features.

32 33
;; You can support the RCS -x option by customizing vc-rcs-master-templates.

34 35
;;; Code:

André Spiegel's avatar
André Spiegel committed
36 37 38 39
;;;
;;; Customization options
;;;

40
(eval-when-compile
41
  (require 'cl-lib)
42
  (require 'vc))
43

44 45 46 47 48
(defgroup vc-rcs nil
  "VC RCS backend."
  :version "24.1"
  :group 'vc)

49
(defcustom vc-rcs-release nil
Lute Kamstra's avatar
Lute Kamstra committed
50
  "The release number of your RCS installation, as a string.
51 52 53 54
If nil, VC itself computes this value when it is first needed."
  :type '(choice (const :tag "Auto" nil)
		 (string :tag "Specified")
		 (const :tag "Unknown" unknown))
55
  :group 'vc-rcs)
56 57

(defcustom vc-rcs-register-switches nil
58 59 60 61 62 63
  "Switches for registering a file in RCS.
A string or list of strings passed to the checkin program by
\\[vc-register].  If nil, use the value of `vc-register-switches'.
If t, use no switches."
  :type '(choice (const :tag "Unspecified" nil)
		 (const :tag "None" t)
64
		 (string :tag "Argument String")
65
		 (repeat :tag "Argument List" :value ("") string))
Dave Love's avatar
Dave Love committed
66
  :version "21.1"
67
  :group 'vc-rcs)
68

69
(defcustom vc-rcs-diff-switches nil
70 71 72 73
  "String or list of strings specifying switches for RCS diff under VC.
If nil, use the value of `vc-diff-switches'.  If t, use no switches."
  :type '(choice (const :tag "Unspecified" nil)
                 (const :tag "None" t)
74
		 (string :tag "Argument String")
75
		 (repeat :tag "Argument List" :value ("") string))
76
  :version "21.1"
77
  :group 'vc-rcs)
78

79
(defcustom vc-rcs-header '("\$Id\$")
Lute Kamstra's avatar
Lute Kamstra committed
80
  "Header keywords to be inserted by `vc-insert-headers'."
Dave Love's avatar
Dave Love committed
81
  :type '(repeat string)
82
  :version "24.1"     ; no longer consult the obsolete vc-header-alist
83
  :group 'vc-rcs)
84 85

(defcustom vc-rcsdiff-knows-brief nil
Lute Kamstra's avatar
Lute Kamstra committed
86
  "Indicates whether rcsdiff understands the --brief option.
87 88 89
The value is either `yes', `no', or nil.  If it is nil, VC tries
to use --brief and sets this variable to remember whether it worked."
  :type '(choice (const :tag "Work out" nil) (const yes) (const no))
90
  :group 'vc-rcs)
91

Glenn Morris's avatar
Glenn Morris committed
92 93 94
;; This needs to be autoloaded because vc-rcs-registered uses it (via
;; vc-default-registered), and vc-hooks needs to be able to check
;; for a registered backend without loading every backend.
95 96 97
;;;###autoload
(defcustom vc-rcs-master-templates
  (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
Lute Kamstra's avatar
Lute Kamstra committed
98
  "Where to look for RCS master files.
99 100 101 102 103 104
For a description of possible values, see `vc-check-master-templates'."
  :type '(choice (const :tag "Use standard RCS file names"
			'("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
		 (repeat :tag "User-specified"
			 (choice string
				 function)))
Dave Love's avatar
Dave Love committed
105
  :version "21.1"
106
  :group 'vc-rcs)
107

André Spiegel's avatar
André Spiegel committed
108

109 110
;;; Properties of the backend

111 112 113 114 115 116 117 118 119 120 121 122 123
(defun vc-rcs-revision-granularity () 'file)

(defun vc-rcs-checkout-model (files)
  "RCS-specific version of `vc-checkout-model'."
  (let ((file (if (consp files) (car files) files))
        result)
    (when vc-consult-headers
      (vc-file-setprop file 'vc-checkout-model nil)
      (vc-rcs-consult-headers file)
      (setq result (vc-file-getprop file 'vc-checkout-model)))
    (or result
        (progn (vc-rcs-fetch-master-state file)
               (vc-file-getprop file 'vc-checkout-model)))))
124

André Spiegel's avatar
André Spiegel committed
125 126 127 128
;;;
;;; State-querying functions
;;;

129 130 131 132 133 134
;; The autoload cookie below places vc-rcs-registered directly into
;; loaddefs.el, so that vc-rcs.el does not need to be loaded for
;; every file that is visited.
;;;###autoload
(progn
(defun vc-rcs-registered (f) (vc-default-registered 'RCS f)))
135 136 137

(defun vc-rcs-state (file)
  "Implementation of `vc-state' for RCS."
Dan Nicolaescu's avatar
Dan Nicolaescu committed
138
  (if (not (vc-rcs-registered file))
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
      'unregistered
    (or (boundp 'vc-rcs-headers-result)
	(and vc-consult-headers
	     (vc-rcs-consult-headers file)))
    (let ((state
	   ;; vc-working-revision might not be known; in that case the
	   ;; property is nil.  vc-rcs-fetch-master-state knows how to
	   ;; handle that.
	   (vc-rcs-fetch-master-state file
				      (vc-file-getprop file
						       'vc-working-revision))))
      (if (not (eq state 'up-to-date))
	  state
	(if (vc-workfile-unchanged-p file)
	    'up-to-date
154
	  (if (eq (vc-rcs-checkout-model (list file)) 'locking)
155 156
	      'unlocked-changes
	    'edited))))))
157 158 159 160 161

(defun vc-rcs-state-heuristic (file)
  "State heuristic for RCS."
  (let (vc-rcs-headers-result)
    (if (and vc-consult-headers
Dave Love's avatar
Dave Love committed
162
             (setq vc-rcs-headers-result
163 164 165 166 167 168 169
                   (vc-rcs-consult-headers file))
             (eq vc-rcs-headers-result 'rev-and-lock))
        (let ((state (vc-file-getprop file 'vc-state)))
          ;; If the headers say that the file is not locked, the
          ;; permissions can tell us whether locking is used for
          ;; the file or not.
          (if (and (eq state 'up-to-date)
170 171
                   (not (vc-mistrust-permissions file))
                   (file-exists-p file))
172 173
              (cond
               ((string-match ".rw..-..-." (nth 8 (file-attributes file)))
174
                (vc-file-setprop file 'vc-checkout-model 'implicit)
175 176 177
		(setq state
		      (if (vc-rcs-workfile-is-newer file)
			  'edited
178
			'up-to-date)))
179 180 181 182
               ((string-match ".r-..-..-." (nth 8 (file-attributes file)))
                (vc-file-setprop file 'vc-checkout-model 'locking))))
          state)
      (if (not (vc-mistrust-permissions file))
183 184
          (let* ((attributes  (file-attributes file 'string))
                 (owner-name  (nth 2 attributes))
185
                 (permissions (nth 8 attributes)))
186
            (cond ((and permissions (string-match ".r-..-..-." permissions))
187 188
                   (vc-file-setprop file 'vc-checkout-model 'locking)
                   'up-to-date)
189
                  ((and permissions (string-match ".rw..-..-." permissions))
190
		   (if (eq (vc-rcs-checkout-model file) 'locking)
191 192
		       (if (file-ownership-preserved-p file)
			   'edited
193
			 owner-name)
194
		     (if (vc-rcs-workfile-is-newer file)
195 196
			 'edited
		       'up-to-date)))
197 198 199 200 201 202
                  (t
                   ;; Strange permissions.  Fall through to
                   ;; expensive state computation.
                   (vc-rcs-state file))))
        (vc-rcs-state file)))))

203 204
(autoload 'vc-expand-dirs "vc")

205
(defun vc-rcs-dir-status (dir update-function)
206 207 208 209 210 211 212
  ;; FIXME: this function should be rewritten or `vc-expand-dirs'
  ;; should be changed to take a backend parameter.  Using
  ;; `vc-expand-dirs' is not TRTD because it returns files from
  ;; multiple backends.  It should also return 'unregistered files.

  ;; Doing individual vc-state calls is painful but there
  ;; is no better way in RCS-land.
213 214 215 216 217
  (let ((flist (vc-expand-dirs (list dir)))
	(result nil))
    (dolist (file flist)
      (let ((state (vc-state file))
	    (frel (file-relative-name file)))
218 219 220
	(when (and (eq (vc-backend file) 'RCS)
		   (not (eq state 'up-to-date)))
	  (push (list frel state) result))))
221
    (funcall update-function result)))
222

Eric S. Raymond's avatar
Eric S. Raymond committed
223 224
(defun vc-rcs-working-revision (file)
  "RCS-specific version of `vc-working-revision'."
225 226
  (or (and vc-consult-headers
           (vc-rcs-consult-headers file)
Eric S. Raymond's avatar
Eric S. Raymond committed
227
           (vc-file-getprop file 'vc-working-revision))
228 229
      (progn
        (vc-rcs-fetch-master-state file)
Eric S. Raymond's avatar
Eric S. Raymond committed
230
        (vc-file-getprop file 'vc-working-revision))))
231

André Spiegel's avatar
André Spiegel committed
232 233 234
(defun vc-rcs-latest-on-branch-p (file &optional version)
  "Return non-nil if workfile version of FILE is the latest on its branch.
When VERSION is given, perform check for that version."
Eric S. Raymond's avatar
Eric S. Raymond committed
235
  (unless version (setq version (vc-working-revision file)))
André Spiegel's avatar
André Spiegel committed
236 237
  (with-temp-buffer
    (string= version
238
	     (if (vc-rcs-trunk-p version)
André Spiegel's avatar
André Spiegel committed
239 240 241 242 243 244 245
		 (progn
		   ;; Compare VERSION to the head version number.
		   (vc-insert-file (vc-name file) "^[0-9]")
		   (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
	       ;; If we are not on the trunk, we need to examine the
	       ;; whole current branch.
	       (vc-insert-file (vc-name file) "^desc")
246
	       (vc-rcs-find-most-recent-rev (vc-branch-part version))))))
André Spiegel's avatar
André Spiegel committed
247

248
(defun vc-rcs-workfile-unchanged-p (file)
Stefan Monnier's avatar
Stefan Monnier committed
249
  "RCS-specific implementation of `vc-workfile-unchanged-p'."
250 251
  ;; Try to use rcsdiff --brief.  If rcsdiff does not understand that,
  ;; do a double take and remember the fact for the future
Eric S. Raymond's avatar
Eric S. Raymond committed
252
  (let* ((version (concat "-r" (vc-working-revision file)))
253
         (status (if (eq vc-rcsdiff-knows-brief 'no)
254 255
                     (vc-do-command "*vc*" 1 "rcsdiff" file version)
                   (vc-do-command "*vc*" 2 "rcsdiff" file "--brief" version))))
256 257 258
    (if (eq status 2)
        (if (not vc-rcsdiff-knows-brief)
            (setq vc-rcsdiff-knows-brief 'no
259
                  status (vc-do-command "*vc*" 1 "rcsdiff" file version))
260 261 262 263 264 265
          (error "rcsdiff failed"))
      (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes)))
    ;; The workfile is unchanged if rcsdiff found no differences.
    (zerop status)))


André Spiegel's avatar
André Spiegel committed
266 267 268
;;;
;;; State-changing functions
;;;
269

270 271
(defun vc-rcs-create-repo ()
  "Create a new RCS repository."
272
  ;; RCS is totally file-oriented, so all we have to do is make the directory.
273 274
  (make-directory "RCS"))

275 276
(autoload 'vc-switches "vc")

277 278 279 280
(defun vc-rcs-register (files &optional rev comment)
  "Register FILES into the RCS version-control system.
REV is the optional revision number for the files.  COMMENT can be used
to provide an initial description for each FILES.
281 282
Passes either `vc-rcs-register-switches' or `vc-register-switches'
to the RCS command.
283 284 285

Automatically retrieve a read-only version of the file with keywords
expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
286
  (let (subdir name)
287 288
    ;; When REV is specified, we need to force using "-t-".
    (when rev (unless comment (setq comment "")))
289
    (dolist (file files)
290 291 292
      (and (not (file-exists-p
		 (setq subdir (expand-file-name "RCS"
						(file-name-directory file)))))
293 294 295 296
	   (not (directory-files (file-name-directory file)
				 nil ".*,v$" t))
	   (yes-or-no-p "Create RCS subdirectory? ")
	   (make-directory subdir))
297
      (apply #'vc-do-command "*vc*" 0 "ci" file
298 299 300 301
	     ;; if available, use the secure registering option
	     (and (vc-rcs-release-p "5.6.4") "-i")
	     (concat (if vc-keep-workfiles "-u" "-r") rev)
	     (and comment (concat "-t-" comment))
302
	     (vc-switches 'RCS 'register))
303 304
      ;; parse output to find master file name and workfile version
      (with-current-buffer "*vc*"
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
	(goto-char (point-min))
	(if (not (setq name
		       (if (looking-at (concat "^\\(.*\\)  <--	"
					       (file-name-nondirectory file)))
			   (match-string 1))))
	    ;; if we couldn't find the master name,
	    ;; run vc-rcs-registered to get it
	    ;; (will be stored into the vc-name property)
	    (vc-rcs-registered file)
	  (vc-file-setprop file 'vc-name
			   (if (file-name-absolute-p name)
			       name
			     (expand-file-name
			      name
			      (file-name-directory file))))))
      (vc-file-setprop file 'vc-working-revision
		       (if (re-search-forward
			    "^initial revision: \\([0-9.]+\\).*\n"
			    nil t)
			   (match-string 1))))))
325

André Spiegel's avatar
André Spiegel committed
326 327 328
(defun vc-rcs-responsible-p (file)
  "Return non-nil if RCS thinks it would be responsible for registering FILE."
  ;; TODO: check for all the patterns in vc-rcs-master-templates
329 330 331 332
  (file-directory-p (expand-file-name "RCS"
                                      (if (file-directory-p file)
                                          file
                                        (file-name-directory file)))))
André Spiegel's avatar
André Spiegel committed
333 334 335

(defun vc-rcs-receive-file (file rev)
  "Implementation of receive-file for RCS."
336
  (let ((checkout-model (vc-rcs-checkout-model (list file))))
André Spiegel's avatar
André Spiegel committed
337 338 339 340 341
    (vc-rcs-register file rev "")
    (when (eq checkout-model 'implicit)
      (vc-rcs-set-non-strict-locking file))
    (vc-rcs-set-default-branch file (concat rev ".1"))))

342 343 344 345 346
(defun vc-rcs-unregister (file)
  "Unregister FILE from RCS.
If this leaves the RCS subdirectory empty, ask the user
whether to remove it."
  (let* ((master (vc-name file))
347 348 349 350 351 352
	 (dir (file-name-directory master))
	 (backup-info (find-backup-file-name master)))
    (if (not backup-info)
	(delete-file master)
      (rename-file master (car backup-info) 'ok-if-already-exists)
      (dolist (f (cdr backup-info)) (ignore-errors (delete-file f))))
353 354 355
    (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
	 ;; check whether RCS dir is empty, i.e. it does not
	 ;; contain any files except "." and ".."
356
	 (not (directory-files dir nil
357 358 359 360
			       "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*"))
	 (yes-or-no-p (format "Directory %s is empty; remove it? " dir))
	 (delete-directory dir))))

361 362 363 364 365
;; It used to be possible to pass in a value for the variable rev, but
;; nothing in the rest of VC used this capability.  Removing it makes the
;; backend interface simpler for all modes.
;;
(defun vc-rcs-checkin (files comment)
André Spiegel's avatar
André Spiegel committed
366
  "RCS-specific version of `vc-backend-checkin'."
367
  (let (rev (switches (vc-switches 'RCS 'checkin)))
368
    ;; Now operate on the files
369
    (dolist (file (vc-expand-dirs files))
Eric S. Raymond's avatar
Eric S. Raymond committed
370
      (let ((old-version (vc-working-revision file)) new-version
371 372 373
	    (default-branch (vc-file-getprop file 'vc-rcs-default-branch)))
	;; Force branch creation if an appropriate
	;; default branch has been set.
374
	(and default-branch
375 376 377 378
	     (string-match (concat "^" (regexp-quote old-version) "\\.")
			   default-branch)
	     (setq rev default-branch)
	     (setq switches (cons "-f" switches)))
379 380 381
	(if old-version
	    (setq rev (vc-branch-part old-version))
	  (error "can't find current branch"))
382
	(apply #'vc-do-command "*vc*" 0 "ci" (vc-name file)
383 384 385 386 387
	       ;; if available, use the secure check-in option
	       (and (vc-rcs-release-p "5.6.4") "-j")
	       (concat (if vc-keep-workfiles "-u" "-r") rev)
	       (concat "-m" comment)
	       switches)
Eric S. Raymond's avatar
Eric S. Raymond committed
388
	(vc-file-setprop file 'vc-working-revision nil)
389 390 391 392 393 394 395 396 397

	;; determine the new workfile version
	(set-buffer "*vc*")
	(goto-char (point-min))
	(when (or (re-search-forward
		   "new revision: \\([0-9.]+\\);" nil t)
		  (re-search-forward
		   "reverting to previous revision \\([0-9.]+\\)" nil t))
	  (setq new-version (match-string 1))
Eric S. Raymond's avatar
Eric S. Raymond committed
398
	  (vc-file-setprop file 'vc-working-revision new-version))
399 400 401 402 403 404 405 406

	;; if we got to a different branch, adjust the default
	;; branch accordingly
	(cond
	 ((and old-version new-version
	       (not (string= (vc-branch-part old-version)
			     (vc-branch-part new-version))))
	  (vc-rcs-set-default-branch file
407
				     (if (vc-rcs-trunk-p new-version) nil
408
				       (vc-branch-part new-version)))
409
	  ;; If this is an old (pre-1992!) RCS release, we might have
410 411 412 413
	  ;; to remove a remaining lock.
	  (if (not (vc-rcs-release-p "5.6.2"))
	      ;; exit status of 1 is also accepted.
	      ;; It means that the lock was removed before.
414
	      (vc-do-command "*vc*" 1 "rcs" (vc-name file)
415
			     (concat "-u" old-version)))))))))
416

Eric S. Raymond's avatar
Eric S. Raymond committed
417
(defun vc-rcs-find-revision (file rev buffer)
418
  (apply #'vc-do-command
419
	 (or buffer "*vc*") 0 "co" (vc-name file)
420 421
	 "-q" ;; suppress diagnostic output
	 (concat "-p" rev)
422
	 (vc-switches 'RCS 'checkout)))
423 424

(defun vc-rcs-checkout (file &optional editable rev)
425
  "Retrieve a copy of a saved version of FILE.  If FILE is a directory,
426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449
attempt the checkout for all registered files beneath it."
  (if (file-directory-p file)
      (mapc 'vc-rcs-checkout (vc-expand-dirs (list file)))
    (let ((file-buffer (get-file-buffer file))
	  switches)
      (message "Checking out %s..." file)
      (save-excursion
	;; Change buffers to get local value of vc-checkout-switches.
	(if file-buffer (set-buffer file-buffer))
	(setq switches (vc-switches 'RCS 'checkout))
	;; Save this buffer's default-directory
	;; and use save-excursion to make sure it is restored
	;; in the same buffer it was saved in.
	(let ((default-directory default-directory))
	  (save-excursion
	    ;; Adjust the default-directory so that the check-out creates
	    ;; the file in the right place.
	    (setq default-directory (file-name-directory file))
	    (let (new-version)
	      ;; if we should go to the head of the trunk,
	      ;; clear the default branch first
	      (and rev (string= rev "")
		   (vc-rcs-set-default-branch file nil))
	      ;; now do the checkout
450
	      (apply #'vc-do-command
451
		     "*vc*" 0 "co" (vc-name file)
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466
		     ;; If locking is not strict, force to overwrite
		     ;; the writable workfile.
		     (if (eq (vc-rcs-checkout-model (list file)) 'implicit) "-f")
		     (if editable "-l")
		     (if (stringp rev)
			 ;; a literal revision was specified
			 (concat "-r" rev)
		       (let ((workrev (vc-working-revision file)))
			 (if workrev
			     (concat "-r"
				     (if (not rev)
					 ;; no revision specified:
					 ;; use current workfile version
					 workrev
				       ;; REV is t ...
467
				       (if (not (vc-rcs-trunk-p workrev))
468 469 470 471
					   ;; ... go to head of current branch
					   (vc-branch-part workrev)
					 ;; ... go to head of trunk
					 (vc-rcs-set-default-branch file
472 473
                                                                  nil)
                                       ""))))))
474 475 476 477 478
		   switches)
	    ;; determine the new workfile version
	    (with-current-buffer "*vc*"
	      (setq new-version
		    (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1)))
Eric S. Raymond's avatar
Eric S. Raymond committed
479
	    (vc-file-setprop file 'vc-working-revision new-version)
480 481
	    ;; if necessary, adjust the default branch
	    (and rev (not (string= rev ""))
482
		 (vc-rcs-set-default-branch
483 484
		  file
		  (if (vc-rcs-latest-on-branch-p file new-version)
485
		      (if (vc-rcs-trunk-p new-version) nil
486 487
			(vc-branch-part new-version))
		    new-version)))))
488
	(message "Checking out %s...done" file))))))
489

490
(defun vc-rcs-rollback (files)
491
  "Roll back, undoing the most recent checkins of FILES.  Directories are
492
expanded to all registered subfiles in them."
493
  (if (not files)
Juanma Barranquero's avatar
Juanma Barranquero committed
494
      (error "RCS backend doesn't support directory-level rollback"))
495
  (dolist (file (vc-expand-dirs files))
Eric S. Raymond's avatar
Eric S. Raymond committed
496
	  (let* ((discard (vc-working-revision file))
497
		 (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard)))
498 499
		 (config (current-window-configuration))
		 (done nil))
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
500
	    (if (null (yes-or-no-p (format "Remove version %s from %s history? "
501 502 503
					   discard file)))
		(error "Aborted"))
	    (message "Removing revision %s from %s." discard file)
504
	    (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-o" discard))
505 506 507 508 509 510 511
	    ;; Check out the most recent remaining version.  If it
	    ;; fails, because the whole branch got deleted, do a
	    ;; double-take and check out the version where the branch
	    ;; started.
	    (while (not done)
	      (condition-case err
		  (progn
512
		    (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
513 514 515 516 517 518 519 520 521 522 523 524 525 526
				   (concat "-u" previous))
		    (setq done t))
		(error (set-buffer "*vc*")
		       (goto-char (point-min))
		       (if (search-forward "no side branches present for" nil t)
			   (progn (setq previous (vc-branch-part previous))
				  (vc-rcs-set-default-branch file previous)
				  ;; vc-do-command popped up a window with
				  ;; the error message.  Get rid of it, by
				  ;; restoring the old window configuration.
				  (set-window-configuration config))
			 ;; No, it was some other error: re-signal it.
			 (signal (car err) (cdr err)))))))))

527
(defun vc-rcs-revert (file &optional _contents-done)
528
  "Revert FILE to the version it was based on.  If FILE is a directory,
529 530 531
revert all registered files beneath it."
  (if (file-directory-p file)
      (mapc 'vc-rcs-revert (vc-expand-dirs (list file)))
532
    (vc-do-command "*vc*" 0 "co" (vc-name file) "-f"
533 534
		   (concat (if (eq (vc-state file) 'edited) "-u" "-r")
			   (vc-working-revision file)))))
André Spiegel's avatar
André Spiegel committed
535 536 537 538

(defun vc-rcs-merge (file first-version &optional second-version)
  "Merge changes into current working copy of FILE.
The changes are between FIRST-VERSION and SECOND-VERSION."
539
  (vc-do-command "*vc*" 1 "rcsmerge" (vc-name file)
André Spiegel's avatar
André Spiegel committed
540 541 542 543 544 545
		 "-kk"			; ignore keyword conflicts
		 (concat "-r" first-version)
		 (if second-version (concat "-r" second-version))))

(defun vc-rcs-steal-lock (file &optional rev)
  "Steal the lock on the current workfile for FILE and revision REV.
546
If FILE is a directory, steal the lock on all registered files beneath it.
André Spiegel's avatar
André Spiegel committed
547
Needs RCS 5.6.2 or later for -M."
548 549
  (if (file-directory-p file)
      (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file)))
550
    (vc-do-command "*vc*" 0 "rcs" (vc-name file) "-M" (concat "-u" rev))
551 552
    ;; Do a real checkout after stealing the lock, so that we see
    ;; expanded headers.
553
    (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" (concat "-l" rev))))
André Spiegel's avatar
André Spiegel committed
554

555
(defun vc-rcs-modify-change-comment (files rev comment)
556 557 558
  "Modify the change comments change on FILES on a specified REV.  If FILE is a
directory the operation is applied to all registered files beneath it."
  (dolist (file (vc-expand-dirs files))
559
    (vc-do-command "*vc*" 0 "rcs" (vc-name file)
560
		   (concat "-m" rev ":" comment))))
André Spiegel's avatar
André Spiegel committed
561 562 563 564 565 566


;;;
;;; History functions
;;;

567 568 569 570 571 572 573 574 575 576 577
(defun vc-rcs-print-log-cleanup ()
  (let ((inhibit-read-only t))
    (goto-char (point-max))
    (forward-line -1)
    (while (looking-at "=*\n")
      (delete-char (- (match-end 0) (match-beginning 0)))
      (forward-line -1))
    (goto-char (point-min))
    (when (looking-at "[\b\t\n\v\f\r ]+")
      (delete-char (- (match-end 0) (match-beginning 0))))))

578 579
(defun vc-rcs-print-log (files buffer &optional _shortlog
                               _start-revision-ignored limit)
580 581 582 583 584 585
  "Print commit log associated with FILES into specified BUFFER.
Remaining arguments are ignored.
If FILE is a directory the operation is applied to all registered
files beneath it."
  (vc-do-command (or buffer "*vc*") 0 "rlog"
                 (mapcar 'vc-name (vc-expand-dirs files)))
586
  (with-current-buffer (or buffer "*vc*")
587 588
    (vc-rcs-print-log-cleanup))
  (when limit 'limit-unsupported))
André Spiegel's avatar
André Spiegel committed
589

590 591
(defun vc-rcs-diff (files &optional oldvers newvers buffer)
  "Get a difference report using RCS between two sets of files."
592
  (apply #'vc-do-command (or buffer "*vc-diff*")
593 594
	 1		;; Always go synchronous, the repo is local
	 "rcsdiff" (vc-expand-dirs files)
595
         (append (list "-q"
596
                       (and oldvers (concat "-r" oldvers))
597
                       (and newvers (concat "-r" newvers)))
598
                 (vc-switches 'RCS 'diff))))
André Spiegel's avatar
André Spiegel committed
599

600 601 602 603
(defun vc-rcs-find-admin-dir (file)
  "Return the administrative directory of FILE."
  (vc-find-root file "RCS"))

604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626
(defun vc-rcs-comment-history (file)
  "Return a string with all log entries stored in BACKEND for FILE."
  (with-current-buffer "*vc*"
    ;; Has to be written this way, this function is used by the CVS backend too
    (vc-call-backend (vc-backend file) 'print-log (list file))
    ;; Remove cruft
    (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n"
			     "\\(branches: .*;\n\\)?"
			     "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?")))
      (goto-char (point-max)) (forward-line -1)
      (while (looking-at "=*\n")
	(delete-char (- (match-end 0) (match-beginning 0)))
	(forward-line -1))
      (goto-char (point-min))
      (if (looking-at "[\b\t\n\v\f\r ]+")
	  (delete-char (- (match-end 0) (match-beginning 0))))
      (goto-char (point-min))
      (re-search-forward separator nil t)
      (delete-region (point-min) (point))
      (while (re-search-forward separator nil t)
	(delete-region (match-beginning 0) (match-end 0))))
    ;; Return the de-crufted comment list
    (buffer-string)))
627

628 629 630
(defun vc-rcs-annotate-command (file buffer &optional revision)
  "Annotate FILE, inserting the results in BUFFER.
Optional arg REVISION is a revision to annotate from."
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
631
  (vc-setup-buffer buffer)
632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700
  ;; Aside from the "head revision on the trunk", the instructions for
  ;; each revision on the trunk are an ordered list of kill and insert
  ;; commands necessary to go from the chronologically-following
  ;; revision to this one.  That is, associated with revision N are
  ;; edits that applied to revision N+1 would result in revision N.
  ;;
  ;; On a branch, however, (some) things are inverted: the commands
  ;; listed are those necessary to go from the chronologically-preceding
  ;; revision to this one.  That is, associated with revision N are
  ;; edits that applied to revision N-1 would result in revision N.
  ;;
  ;; So, to get per-line history info, we apply reverse-chronological
  ;; edits, starting with the head revision on the trunk, all the way
  ;; back through the initial revision (typically "1.1" or similar),
  ;; then apply forward-chronological edits -- keeping track of which
  ;; revision is associated with each inserted line -- until we reach
  ;; the desired revision for display (which may be either on the trunk
  ;; or on a branch).
  (let* ((tree (with-temp-buffer
                 (insert-file-contents (vc-rcs-registered file))
                 (vc-rcs-parse)))
         (revisions (cdr (assq 'revisions tree)))
         ;; The revision N whose instructions we currently are processing.
         (cur (cdr (assq 'head (cdr (assq 'headers tree)))))
         ;; Alist from the parse tree for N.
         (meta (cdr (assoc cur revisions)))
         ;; Point and temporary string, respectively.
         p s
         ;; "Next-branch list".  Nil means the desired revision to
         ;; display lives on the trunk.  Non-nil means it lives on a
         ;; branch, in which case the value is a list of revision pairs
         ;; (PARENT . CHILD), the first PARENT being on the trunk, that
         ;; links each series of revisions in the path from the initial
         ;; revision to the desired revision to display.
         nbls
         ;; "Path-accumulate-predicate plus revision/date/author".
         ;; Until set, forward-chronological edits are not accumulated.
         ;; Once set, its value (updated every revision) is used for
         ;; the text property `:vc-rcs-r/d/a' for inserts during
         ;; processing of forward-chronological instructions for N.
         ;; See internal func `r/d/a'.
         prda
         ;; List of forward-chronological instructions, each of the
         ;; form: (POS . ACTION), where POS is a buffer position.  If
         ;; ACTION is a string, it is inserted, otherwise it is taken as
         ;; the number of characters to be deleted.
         path
         ;; N+1.  When `cur' is "", this is the initial revision.
         pre)
    (unless revision
      (setq revision cur))
    (unless (assoc revision revisions)
      (error "No such revision: %s" revision))
    ;; Find which branches (if any) must be included in the edits.
    (let ((par revision)
          bpt kids)
      (while (setq bpt (vc-branch-part par)
                   par (vc-branch-part bpt))
        (setq kids (cdr (assq 'branches (cdr (assoc par revisions)))))
        ;; A branchpoint may have multiple children.  Find the right one.
        (while (not (string= bpt (vc-branch-part (car kids))))
          (setq kids (cdr kids)))
        (push (cons par (car kids)) nbls)))
    ;; Start with the full text.
    (set-buffer buffer)
    (insert (cdr (assq 'text meta)))
    ;; Apply reverse-chronological edits on the trunk, computing and
    ;; accumulating forward-chronological edits after some point, for
    ;; later.
701 702 703
    (cl-flet ((r/d/a () (vector pre
                                (cdr (assq 'date meta))
                                (cdr (assq 'author meta)))))
704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723
      (while (when (setq pre cur cur (cdr (assq 'next meta)))
               (not (string= "" cur)))
        (setq
         ;; Start accumulating the forward-chronological edits when N+1
         ;; on the trunk is either the desired revision to display, or
         ;; the appropriate branchpoint for it.  Do this before
         ;; updating `meta' since `r/d/a' uses N+1's `meta' value.
         prda (when (or prda (string= (if nbls (caar nbls) revision) pre))
                (r/d/a))
         meta (cdr (assoc cur revisions)))
        ;; Edits in the parse tree specify a line number (in the buffer
        ;; *BEFORE* editing occurs) to start from, but line numbers
        ;; change as a result of edits.  To DTRT, we apply edits in
        ;; order of descending buffer position so that edits further
        ;; down in the buffer occur first w/o corrupting specified
        ;; buffer positions of edits occurring towards the beginning of
        ;; the buffer.  In this way we avoid using markers.  A pleasant
        ;; property of this approach is ability to push instructions
        ;; onto `path' directly, w/o need to maintain rev boundaries.
        (dolist (insn (cdr (assq :insn meta)))
724 725
          (goto-char (point-min))
          (forward-line (1- (pop insn)))
726
          (setq p (point))
727 728 729 730 731 732 733 734 735 736 737
          (pcase (pop insn)
            (`k (setq s (buffer-substring-no-properties
                         p (progn (forward-line (car insn))
                                  (point))))
                (when prda
                  (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path))
                (delete-region p (point)))
            (`i (setq s (car insn))
                (when prda
                  (push `(,p . ,(length s)) path))
                (insert s)))))
738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756
      ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is
      ;; equivalent to pushing an insert instruction (of the entire buffer
      ;; contents) onto `path' then erasing the buffer, but less wasteful.
      (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a))
      ;; Now apply the forward-chronological edits for the trunk.
      (dolist (insn path)
        (goto-char (pop insn))
        (if (stringp insn)
            (insert insn)
          (delete-char insn)))
      ;; Now apply the forward-chronological edits (directly from the
      ;; parse-tree) for the branch(es), if necessary.  We re-use vars
      ;; `pre' and `meta' for the sake of internal func `r/d/a'.
      (while nbls
        (setq pre (cdr (pop nbls)))
        (while (progn
                 (setq meta (cdr (assoc pre revisions))
                       prda nil)
                 (dolist (insn (cdr (assq :insn meta)))
757 758
                   (goto-char (point-min))
                   (forward-line (1- (pop insn)))
759 760 761 762 763 764 765 766
                   (pcase (pop insn)
                     (`k (delete-region
                          (point) (progn (forward-line (car insn))
                                         (point))))
                     (`i (insert (propertize
                                  (car insn)
                                  :vc-rcs-r/d/a
                                  (or prda (setq prda (r/d/a))))))))
767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790
                 (prog1 (not (string= (if nbls (caar nbls) revision) pre))
                   (setq pre (cdr (assq 'next meta)))))))))
  ;; Lastly, for each line, insert at bol nicely-formatted history info.
  ;; We do two passes to collect summary information used to minimize
  ;; the annotation's usage of screen real-estate: (1) Consider rendered
  ;; width of revision plus author together as a unit; and (2) Omit
  ;; author entirely if all authors are the same as the user.
  (let ((ht (make-hash-table :test 'eq))
        (me (user-login-name))
        (maxw 0)
        (all-me t)
        rda w a)
    (goto-char (point-max))
    (while (not (bobp))
      (forward-line -1)
      (setq rda (get-text-property (point) :vc-rcs-r/d/a))
      (unless (gethash rda ht)
        (setq a (aref rda 2)
              all-me (and all-me (string= a me)))
        (puthash rda (setq w (+ (length (aref rda 0))
                                (length a)))
                 ht)
        (setq maxw (max w maxw))))
    (let ((padding (make-string maxw 32)))
791 792 793
      (cl-flet ((pad (w) (substring-no-properties padding w))
                (render (rda &rest ls)
                        (propertize
794
                         (apply #'concat
795 796 797 798 799 800
                                (format-time-string "%Y-%m-%d" (aref rda 1))
                                "  "
                                (aref rda 0)
                                ls)
                         :vc-annotate-prefix t
                         :vc-rcs-r/d/a rda)))
801 802 803 804 805 806 807 808 809 810 811
        (maphash
         (if all-me
             (lambda (rda w)
               (puthash rda (render rda (pad w) ": ") ht))
           (lambda (rda w)
             (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht)))
         ht)))
    (while (not (eobp))
      (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht))
      (forward-line 1))))

812 813
(declare-function vc-annotate-convert-time "vc-annotate" (time))

814 815 816 817
(defun vc-rcs-annotate-current-time ()
  "Return the current time, based at midnight of the current day, and
encoded as fractional days."
  (vc-annotate-convert-time
818
   (apply #'encode-time 0 0 0 (nthcdr 3 (decode-time)))))
819 820 821 822 823

(defun vc-rcs-annotate-time ()
  "Return the time of the next annotation (as fraction of days)
systime, or nil if there is none.  Also, reposition point."
  (unless (eobp)
Thien-Thi Nguyen's avatar
Thien-Thi Nguyen committed
824 825 826
    (prog1 (vc-annotate-convert-time
            (aref (get-text-property (point) :vc-rcs-r/d/a) 1))
      (goto-char (next-single-property-change (point) :vc-annotate-prefix)))))
827 828 829 830

(defun vc-rcs-annotate-extract-revision-at-line ()
  (aref (get-text-property (point) :vc-rcs-r/d/a) 0))

André Spiegel's avatar
André Spiegel committed
831 832

;;;
833
;;; Tag system
André Spiegel's avatar
André Spiegel committed
834 835
;;;

836 837 838
(autoload 'vc-tag-precondition "vc")
(declare-function vc-file-tree-walk "vc" (dirname func &rest args))

839
(defun vc-rcs-create-tag (dir name branchp)
840
  (when branchp
841
    (error "RCS backend does not support module branches"))
842 843 844 845 846 847 848
  (let ((result (vc-tag-precondition dir)))
    (if (stringp result)
	(error "File %s is not up-to-date" result)
      (vc-file-tree-walk
       dir
       (lambda (f)
	 (vc-do-command "*vc*" 0 "rcs" (vc-name f) (concat "-n" name ":")))))))
André Spiegel's avatar
André Spiegel committed
849 850 851 852 853 854


;;;
;;; Miscellaneous
;;;

855 856 857 858 859 860 861 862 863
(defun vc-rcs-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-rcs-minor-part (rev)
  "Return the minor revision number of a revision number REV."
  (string-match "[0-9]+\\'" rev)
  (substring rev (match-beginning 0) (match-end 0)))

864
(defun vc-rcs-previous-revision (_file rev)
865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892
  "Return the revision number immediately preceding REV for FILE,
or nil if there is no previous revision.  This default
implementation works for MAJOR.MINOR-style revision numbers as
used by RCS and CVS."
  (let ((branch (vc-branch-part rev))
        (minor-num (string-to-number (vc-rcs-minor-part rev))))
    (when branch
      (if (> minor-num 1)
          ;; revision does probably not start a branch or release
          (concat branch "." (number-to-string (1- minor-num)))
        (if (vc-rcs-trunk-p rev)
            ;; we are at the beginning of the trunk --
            ;; don't know anything to return here
            nil
          ;; we are at the beginning of a branch --
          ;; return revision of starting point
          (vc-branch-part branch))))))

(defun vc-rcs-next-revision (file rev)
  "Return the revision number immediately following REV for FILE,
or nil if there is no next revision.  This default implementation
works for MAJOR.MINOR-style revision numbers as used by RCS
and CVS."
  (when (not (string= rev (vc-working-revision file)))
    (let ((branch (vc-branch-part rev))
	  (minor-num (string-to-number (vc-rcs-minor-part rev))))
      (concat branch "." (number-to-string (1+ minor-num))))))

Glenn Morris's avatar
Glenn Morris committed
893 894 895
;; You might think that this should be distributed with RCS, but
;; apparently not.  CVS sometimes provides a version of it.
;; http://lists.gnu.org/archive/html/emacs-devel/2014-05/msg00288.html
896 897 898 899 900 901 902 903 904 905 906 907 908
(defvar vc-rcs-rcs2log-program
  (let (exe)
    (cond ((file-executable-p
            (setq exe (expand-file-name "rcs2log" exec-directory)))
           exe)
          ;; In the unlikely event that someone is running an
          ;; uninstalled Emacs and wants to do something RCS-related.
          ((file-executable-p
            (setq exe (expand-file-name "lib-src/rcs2log" source-directory)))
           exe)
          (t "rcs2log")))
  "Path to the `rcs2log' program (normally in `exec-directory').")

909 910
(autoload 'vc-buffer-sync "vc-dispatcher")

911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940
(defun vc-rcs-update-changelog (files)
  "Default implementation of update-changelog.
Uses `rcs2log' which only works for RCS and CVS."
  ;; FIXME: We (c|sh)ould add support for cvs2cl
  (let ((odefault default-directory)
	(changelog (find-change-log))
	;; Presumably not portable to non-Unixy systems, along with rcs2log:
	(tempfile (make-temp-file
		   (expand-file-name "vc"
				     (or small-temporary-file-directory
					 temporary-file-directory))))
        (login-name (or user-login-name
                        (format "uid%d" (number-to-string (user-uid)))))
	(full-name (or add-log-full-name
		       (user-full-name)
		       (user-login-name)
		       (format "uid%d" (number-to-string (user-uid)))))
	(mailing-address (or add-log-mailing-address
			     user-mail-address)))
    (find-file-other-window changelog)
    (barf-if-buffer-read-only)
    (vc-buffer-sync)
    (undo-boundary)
    (goto-char (point-min))
    (push-mark)
    (message "Computing change log entries...")
    (message "Computing change log entries... %s"
	     (unwind-protect
		 (progn
		   (setq default-directory odefault)
941
		   (if (eq 0 (apply #'call-process vc-rcs-rcs2log-program
942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959
                                    nil (list t tempfile) nil
                                    "-c" changelog
                                    "-u" (concat login-name
                                                 "\t" full-name
                                                 "\t" mailing-address)
                                    (mapcar
                                     (lambda (f)
                                       (file-relative-name
					(expand-file-name f odefault)))
                                     files)))
                       "done"
		     (pop-to-buffer (get-buffer-create "*vc*"))
		     (erase-buffer)
		     (insert-file-contents tempfile)
		     "failed"))
	       (setq default-directory (file-name-directory changelog))
	       (delete-file tempfile)))))

André Spiegel's avatar
André Spiegel committed
960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976
(defun vc-rcs-check-headers ()
  "Check if the current file has any headers in it."
  (save-excursion
    (goto-char (point-min))
         (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))

(defun vc-rcs-clear-headers ()
  "Implementation of vc-clear-headers for RCS."
  (let ((case-fold-search nil))
    (goto-char (point-min))
    (while (re-search-forward
            (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|"
                    "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$")
            nil t)
      (replace-match "$\\1$"))))

977 978
(autoload 'vc-rename-master "vc")

André Spiegel's avatar
André Spiegel committed
979 980 981 982
(defun vc-rcs-rename-file (old new)
  ;; Just move the master file (using vc-rcs-master-templates).
  (vc-rename-master (vc-name old) new vc-rcs-master-templates))

983 984 985 986
(defun vc-rcs-find-file-hook ()
  ;; If the file is locked by some other user, make
  ;; the buffer read-only.  Like this, even root
  ;; cannot modify a file that someone else has locked.
987 988
  (and (stringp (vc-state buffer-file-name 'RCS))
       (setq buffer-read-only t)))
989

André Spiegel's avatar
André Spiegel committed
990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016

;;;
;;; Internal functions
;;;

(defun vc-rcs-workfile-is-newer (file)
  "Return non-nil if FILE is newer than its RCS master.
This likely means that FILE has been changed with respect
to its master version."
  (let ((file-time (nth 5 (file-attributes file)))
	(master-time (nth 5 (file-attributes (vc-name file)))))
    (or (> (nth 0 file-time) (nth 0 master-time))
	(and (= (nth 0 file-time) (nth 0 master-time))
	     (> (nth 1 file-time) (nth 1 master-time))))))

(defun vc-rcs-find-most-recent-rev (branch)
  "Find most recent revision on BRANCH."
  (goto-char (point-min))
  (let ((latest-rev -1) value)
    (while (re-search-forward (concat "^\\(" (regexp-quote branch)
				      "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;")
			      nil t)
      (let ((rev (string-to-number (match-string 2))))
	(when (< latest-rev rev)
	  (setq latest-rev rev)
	  (setq value (match-string 1)))))
    (or value
1017
	(vc-branch-part branch))))
André Spiegel's avatar
André Spiegel committed
1018

Eric S. Raymond's avatar
Eric S. Raymond committed
1019
(defun vc-rcs-fetch-master-state (file &optional working-revision)
André Spiegel's avatar
André Spiegel committed
1020
  "Compute the master file's idea of the state of FILE.
1021
If a WORKING-REVISION is given, compute the state of that version,
André Spiegel's avatar
André Spiegel committed
1022
otherwise determine the workfile version based on the master file.
Eric S. Raymond's avatar
Eric S. Raymond committed
1023
This function sets the properties `vc-working-revision' and
André Spiegel's avatar
André Spiegel committed
1024 1025 1026
`vc-checkout-model' to their correct values, based on the master
file."
  (with-temp-buffer
1027 1028 1029 1030
    (if (or (not (vc-insert-file (vc-name file) "^[0-9]"))
            (progn (goto-char (point-min))
                   (not (looking-at "^head[ \t\n]+[^;]+;$"))))
        (error "File %s is not an RCS master file" (vc-name file)))
André Spiegel's avatar
André Spiegel committed
1031 1032 1033
    (let ((workfile-is-latest nil)
	  (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1)))
      (vc-file-setprop file 'vc-rcs-default-branch default-branch)
Eric S. Raymond's avatar
Eric S. Raymond committed
1034
      (unless working-revision
André Spiegel's avatar
André Spiegel committed
1035 1036 1037 1038 1039 1040 1041
	;; Workfile version not known yet.  Determine that first.  It
	;; is either the head of the trunk, the head of the default
	;; branch, or the "default branch" itself, if that is a full
	;; revision number.
	(cond
	 ;; no default branch
	 ((or (not default-branch) (string= "" default-branch))
Eric S. Raymond's avatar
Eric S. Raymond committed
1042
	  (setq working-revision
André Spiegel's avatar
André Spiegel committed
1043 1044 1045 1046 1047
		(vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
	  (setq workfile-is-latest t))
	 ;; default branch is actually a revision
	 ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
			default-branch)
Eric S. Raymond's avatar
Eric S. Raymond committed
1048
	  (setq working-revision default-branch))
André Spiegel's avatar
André Spiegel committed
1049 1050
	 ;; else, search for the head of the default branch
	 (t (vc-insert-file (vc-name file) "^desc")
Eric S. Raymond's avatar
Eric S. Raymond committed
1051
	    (setq working-revision
André Spiegel's avatar
André Spiegel committed
1052 1053
		  (vc-rcs-find-most-recent-rev default-branch))
	    (setq workfile-is-latest t)))
Eric S. Raymond's avatar
Eric S. Raymond committed
1054
	(vc-file-setprop file 'vc-working-revision working-revision))
André Spiegel's avatar
André Spiegel committed
1055 1056 1057 1058 1059 1060 1061 1062 1063
      ;; Check strict locking
      (goto-char (point-min))
      (vc-file-setprop file 'vc-checkout-model
		       (if (re-search-forward ";[ \t\n]*strict;" nil t)
			   'locking 'implicit))
      ;; Compute state of workfile version
      (goto-char (point-min))
      (let ((locking-user
	     (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):"
Eric S. Raymond's avatar
Eric S. Raymond committed
1064
				      (regexp-quote working-revision)
André Spiegel's avatar
André Spiegel committed
1065 1066 1067 1068 1069 1070
				      "[^0-9.]")
			      1)))
	(cond
	 ;; not locked
	 ((not locking-user)
          (if (or workfile-is-latest
Eric S. Raymond's avatar
Eric S. Raymond committed
1071
                  (vc-rcs-latest-on-branch-p file working-revision))
André Spiegel's avatar
André Spiegel committed
1072
              ;; workfile version is latest on branch
1073
              'up-to-date