(insert-string): Moved from mocklisp.c, reimplemented in Lisp. Obsoleted.
[bpt/emacs.git] / lisp / vc-rcs.el
CommitLineData
d8aff077
GM
1;;; vc-rcs.el --- support for RCS version-control
2
891b8b69 3;; Copyright (C) 1992,93,94,95,96,97,98,99,2000,2001 Free Software Foundation, Inc.
d8aff077
GM
4
5;; Author: FSF (see vc.el for full credits)
6;; Maintainer: Andre Spiegel <spiegel@gnu.org>
7
99739bbf 8;; $Id: vc-rcs.el,v 1.20 2001/07/16 12:22:59 pj Exp $
d8aff077
GM
9
10;; This file is part of GNU Emacs.
11
12;; GNU Emacs is free software; you can redistribute it and/or modify
13;; it under the terms of the GNU General Public License as published by
14;; the Free Software Foundation; either version 2, or (at your option)
15;; any later version.
16
17;; GNU Emacs is distributed in the hope that it will be useful,
18;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20;; GNU General Public License for more details.
21
22;; You should have received a copy of the GNU General Public License
23;; along with GNU Emacs; see the file COPYING. If not, write to the
24;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25;; Boston, MA 02111-1307, USA.
26
e8af40ee
PJ
27;;; Commentary:
28
29;; See vc.el
d8aff077
GM
30
31;;; Code:
32
8f98485f
AS
33;;;
34;;; Customization options
35;;;
36
0bc58756 37(eval-when-compile
10489ed7
AS
38 (require 'cl)
39 (require 'vc))
0bc58756 40
d8aff077
GM
41(defcustom vc-rcs-release nil
42 "*The release number of your RCS installation, as a string.
43If nil, VC itself computes this value when it is first needed."
44 :type '(choice (const :tag "Auto" nil)
45 (string :tag "Specified")
46 (const :tag "Unknown" unknown))
47 :group 'vc)
48
49(defcustom vc-rcs-register-switches nil
33c1b7a1
DL
50 "*Extra switches for registering a file in RCS.
51A string or list of strings. These are passed to the checkin program
52by \\[vc-rcs-register]."
d8aff077
GM
53 :type '(choice (const :tag "None" nil)
54 (string :tag "Argument String")
55 (repeat :tag "Argument List"
56 :value ("")
57 string))
33c1b7a1 58 :version "21.1"
d8aff077
GM
59 :group 'vc)
60
61(defcustom vc-rcs-checkin-switches nil
62 "*A string or list of strings specifying extra switches for RCS checkin.
63These are passed to the checkin program by \\[vc-rcs-checkin]."
64 :type '(choice (const :tag "None" nil)
65 (string :tag "Argument String")
66 (repeat :tag "Argument List"
67 :value ("")
68 string))
33c1b7a1 69 :version "21.1"
d8aff077
GM
70 :group 'vc)
71
72(defcustom vc-rcs-checkout-switches nil
73 "*A string or list of strings specifying extra switches for RCS checkout.
74These are passed to the checkout program by \\[vc-rcs-checkout]."
75 :type '(choice (const :tag "None" nil)
76 (string :tag "Argument String")
77 (repeat :tag "Argument List"
78 :value ("")
79 string))
33c1b7a1 80 :version "21.1"
d8aff077
GM
81 :group 'vc)
82
10489ed7
AS
83(defcustom vc-rcs-diff-switches nil
84 "*A string or list of strings specifying extra switches for rcsdiff under VC."
85 :type '(choice (const :tag "None" nil)
86 (string :tag "Argument String")
87 (repeat :tag "Argument List"
88 :value ("")
89 string))
90 :version "21.1"
91 :group 'vc)
92
d8aff077
GM
93(defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$"))
94 "*Header keywords to be inserted by `vc-insert-headers'."
f0e7c067 95 :type '(repeat string)
33c1b7a1 96 :version "21.1"
d8aff077
GM
97 :group 'vc)
98
99(defcustom vc-rcsdiff-knows-brief nil
100 "*Indicates whether rcsdiff understands the --brief option.
101The value is either `yes', `no', or nil. If it is nil, VC tries
102to use --brief and sets this variable to remember whether it worked."
103 :type '(choice (const :tag "Work out" nil) (const yes) (const no))
104 :group 'vc)
105
106;;;###autoload
107(defcustom vc-rcs-master-templates
108 '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")
109 "*Where to look for RCS master files.
110For a description of possible values, see `vc-check-master-templates'."
111 :type '(choice (const :tag "Use standard RCS file names"
112 '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s"))
113 (repeat :tag "User-specified"
114 (choice string
115 function)))
33c1b7a1 116 :version "21.1"
d8aff077
GM
117 :group 'vc)
118
8f98485f
AS
119\f
120;;;
121;;; State-querying functions
122;;;
123
d8aff077
GM
124;;;###autoload
125(progn (defun vc-rcs-registered (f) (vc-default-registered 'RCS f)))
126
127(defun vc-rcs-state (file)
128 "Implementation of `vc-state' for RCS."
129 (or (boundp 'vc-rcs-headers-result)
130 (and vc-consult-headers
131 (vc-rcs-consult-headers file)))
132 (let ((state
133 ;; vc-workfile-version might not be known; in that case the
134 ;; property is nil. vc-rcs-fetch-master-state knows how to
135 ;; handle that.
33c1b7a1
DL
136 (vc-rcs-fetch-master-state file
137 (vc-file-getprop file
d8aff077 138 'vc-workfile-version))))
ceaa9974
AS
139 (if (not (eq state 'up-to-date))
140 state
141 (require 'vc)
142 (if (vc-workfile-unchanged-p file)
143 'up-to-date
144 (if (eq (vc-checkout-model file) 'locking)
145 'unlocked-changes
146 'edited)))))
d8aff077
GM
147
148(defun vc-rcs-state-heuristic (file)
149 "State heuristic for RCS."
150 (let (vc-rcs-headers-result)
151 (if (and vc-consult-headers
33c1b7a1 152 (setq vc-rcs-headers-result
d8aff077
GM
153 (vc-rcs-consult-headers file))
154 (eq vc-rcs-headers-result 'rev-and-lock))
155 (let ((state (vc-file-getprop file 'vc-state)))
156 ;; If the headers say that the file is not locked, the
157 ;; permissions can tell us whether locking is used for
158 ;; the file or not.
159 (if (and (eq state 'up-to-date)
160 (not (vc-mistrust-permissions file)))
161 (cond
162 ((string-match ".rw..-..-." (nth 8 (file-attributes file)))
0db2c43c
AS
163 (vc-file-setprop file 'vc-checkout-model 'implicit)
164 (setq state
165 (if (vc-rcs-workfile-is-newer file)
166 'edited
167 'up-to-date)))
d8aff077
GM
168 ((string-match ".r-..-..-." (nth 8 (file-attributes file)))
169 (vc-file-setprop file 'vc-checkout-model 'locking))))
170 state)
171 (if (not (vc-mistrust-permissions file))
172 (let* ((attributes (file-attributes file))
173 (owner-uid (nth 2 attributes))
174 (permissions (nth 8 attributes)))
175 (cond ((string-match ".r-..-..-." permissions)
176 (vc-file-setprop file 'vc-checkout-model 'locking)
177 'up-to-date)
178 ((string-match ".rw..-..-." permissions)
0db2c43c
AS
179 (if (eq (vc-checkout-model file) 'locking)
180 (if (file-ownership-preserved-p file)
181 'edited
182 (vc-user-login-name owner-uid))
183 (if (vc-rcs-workfile-is-newer file)
184 'edited
185 'up-to-date)))
d8aff077
GM
186 (t
187 ;; Strange permissions. Fall through to
188 ;; expensive state computation.
189 (vc-rcs-state file))))
190 (vc-rcs-state file)))))
191
192(defun vc-rcs-workfile-version (file)
193 "RCS-specific version of `vc-workfile-version'."
194 (or (and vc-consult-headers
195 (vc-rcs-consult-headers file)
196 (vc-file-getprop file 'vc-workfile-version))
197 (progn
198 (vc-rcs-fetch-master-state file)
199 (vc-file-getprop file 'vc-workfile-version))))
200
8f98485f
AS
201(defun vc-rcs-latest-on-branch-p (file &optional version)
202 "Return non-nil if workfile version of FILE is the latest on its branch.
203When VERSION is given, perform check for that version."
204 (unless version (setq version (vc-workfile-version file)))
205 (with-temp-buffer
206 (string= version
207 (if (vc-rcs-trunk-p version)
208 (progn
209 ;; Compare VERSION to the head version number.
210 (vc-insert-file (vc-name file) "^[0-9]")
211 (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
212 ;; If we are not on the trunk, we need to examine the
213 ;; whole current branch.
214 (vc-insert-file (vc-name file) "^desc")
215 (vc-rcs-find-most-recent-rev (vc-rcs-branch-part version))))))
216
d8aff077
GM
217(defun vc-rcs-checkout-model (file)
218 "RCS-specific version of `vc-checkout-model'."
219 (vc-rcs-consult-headers file)
220 (or (vc-file-getprop file 'vc-checkout-model)
221 (progn (vc-rcs-fetch-master-state file)
222 (vc-file-getprop file 'vc-checkout-model))))
223
d8aff077
GM
224(defun vc-rcs-workfile-unchanged-p (file)
225 "RCS-specific implementation of vc-workfile-unchanged-p."
226 ;; Try to use rcsdiff --brief. If rcsdiff does not understand that,
227 ;; do a double take and remember the fact for the future
228 (let* ((version (concat "-r" (vc-workfile-version file)))
229 (status (if (eq vc-rcsdiff-knows-brief 'no)
230 (vc-do-command nil 1 "rcsdiff" file version)
231 (vc-do-command nil 2 "rcsdiff" file "--brief" version))))
232 (if (eq status 2)
233 (if (not vc-rcsdiff-knows-brief)
234 (setq vc-rcsdiff-knows-brief 'no
235 status (vc-do-command nil 1 "rcsdiff" file version))
236 (error "rcsdiff failed"))
237 (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes)))
238 ;; The workfile is unchanged if rcsdiff found no differences.
239 (zerop status)))
240
d8aff077 241\f
8f98485f
AS
242;;;
243;;; State-changing functions
244;;;
d8aff077 245
8f98485f
AS
246(defun vc-rcs-register (file &optional rev comment)
247 "Register FILE into the RCS version-control system.
248REV is the optional revision number for the file. COMMENT can be used
249to provide an initial description of FILE.
d8aff077
GM
250
251`vc-register-switches' and `vc-rcs-register-switches' are passed to
252the RCS command (in that order).
253
254Automatically retrieve a read-only version of the file with keywords
255expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile."
d8aff077
GM
256 (let ((subdir (expand-file-name "RCS" (file-name-directory file)))
257 (switches (list
258 (if (stringp vc-register-switches)
259 (list vc-register-switches)
260 vc-register-switches)
261 (if (stringp vc-rcs-register-switches)
262 (list vc-rcs-register-switches)
263 vc-rcs-register-switches))))
264
265 (and (not (file-exists-p subdir))
266 (not (directory-files (file-name-directory file)
267 nil ".*,v$" t))
268 (yes-or-no-p "Create RCS subdirectory? ")
269 (make-directory subdir))
270 (apply 'vc-do-command nil 0 "ci" file
271 ;; if available, use the secure registering option
272 (and (vc-rcs-release-p "5.6.4") "-i")
273 (concat (if vc-keep-workfiles "-u" "-r") rev)
274 (and comment (concat "-t-" comment))
275 switches)
276 ;; parse output to find master file name and workfile version
277 (with-current-buffer "*vc*"
278 (goto-char (point-min))
279 (let ((name (if (looking-at (concat "^\\(.*\\) <-- "
280 (file-name-nondirectory file)))
281 (match-string 1))))
282 (if (not name)
283 ;; if we couldn't find the master name,
284 ;; run vc-rcs-registered to get it
285 ;; (will be stored into the vc-name property)
286 (vc-rcs-registered file)
287 (vc-file-setprop file 'vc-name
288 (if (file-name-absolute-p name)
289 name
33c1b7a1
DL
290 (expand-file-name
291 name
d8aff077
GM
292 (file-name-directory file))))))
293 (vc-file-setprop file 'vc-workfile-version
33c1b7a1 294 (if (re-search-forward
d8aff077
GM
295 "^initial revision: \\([0-9.]+\\).*\n"
296 nil t)
297 (match-string 1))))))
298
8f98485f
AS
299(defun vc-rcs-responsible-p (file)
300 "Return non-nil if RCS thinks it would be responsible for registering FILE."
301 ;; TODO: check for all the patterns in vc-rcs-master-templates
302 (file-directory-p (expand-file-name "RCS" (file-name-directory file))))
303
304(defun vc-rcs-receive-file (file rev)
305 "Implementation of receive-file for RCS."
306 (let ((checkout-model (vc-checkout-model file)))
307 (vc-rcs-register file rev "")
308 (when (eq checkout-model 'implicit)
309 (vc-rcs-set-non-strict-locking file))
310 (vc-rcs-set-default-branch file (concat rev ".1"))))
311
0db2c43c
AS
312(defun vc-rcs-unregister (file)
313 "Unregister FILE from RCS.
314If this leaves the RCS subdirectory empty, ask the user
315whether to remove it."
316 (let* ((master (vc-name file))
7849e179
SM
317 (dir (file-name-directory master))
318 (backup-info (find-backup-file-name master)))
319 (if (not backup-info)
320 (delete-file master)
321 (rename-file master (car backup-info) 'ok-if-already-exists)
322 (dolist (f (cdr backup-info)) (ignore-errors (delete-file f))))
0db2c43c
AS
323 (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS")
324 ;; check whether RCS dir is empty, i.e. it does not
325 ;; contain any files except "." and ".."
326 (not (directory-files dir nil
327 "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*"))
328 (yes-or-no-p (format "Directory %s is empty; remove it? " dir))
329 (delete-directory dir))))
330
8f98485f
AS
331(defun vc-rcs-checkin (file rev comment)
332 "RCS-specific version of `vc-backend-checkin'."
333 (let ((switches (if (stringp vc-checkin-switches)
334 (list vc-checkin-switches)
335 vc-checkin-switches)))
336 (let ((old-version (vc-workfile-version file)) new-version
337 (default-branch (vc-file-getprop file 'vc-rcs-default-branch)))
338 ;; Force branch creation if an appropriate
339 ;; default branch has been set.
340 (and (not rev)
341 default-branch
342 (string-match (concat "^" (regexp-quote old-version) "\\.")
343 default-branch)
344 (setq rev default-branch)
345 (setq switches (cons "-f" switches)))
346 (apply 'vc-do-command nil 0 "ci" (vc-name file)
347 ;; if available, use the secure check-in option
348 (and (vc-rcs-release-p "5.6.4") "-j")
349 (concat (if vc-keep-workfiles "-u" "-r") rev)
350 (concat "-m" comment)
351 switches)
352 (vc-file-setprop file 'vc-workfile-version nil)
0db2c43c 353
8f98485f
AS
354 ;; determine the new workfile version
355 (set-buffer "*vc*")
356 (goto-char (point-min))
357 (when (or (re-search-forward
358 "new revision: \\([0-9.]+\\);" nil t)
359 (re-search-forward
360 "reverting to previous revision \\([0-9.]+\\)" nil t))
361 (setq new-version (match-string 1))
362 (vc-file-setprop file 'vc-workfile-version new-version))
363
364 ;; if we got to a different branch, adjust the default
365 ;; branch accordingly
366 (cond
367 ((and old-version new-version
368 (not (string= (vc-rcs-branch-part old-version)
369 (vc-rcs-branch-part new-version))))
370 (vc-rcs-set-default-branch file
371 (if (vc-rcs-trunk-p new-version) nil
372 (vc-rcs-branch-part new-version)))
373 ;; If this is an old RCS release, we might have
374 ;; to remove a remaining lock.
375 (if (not (vc-rcs-release-p "5.6.2"))
376 ;; exit status of 1 is also accepted.
377 ;; It means that the lock was removed before.
378 (vc-do-command nil 1 "rcs" (vc-name file)
379 (concat "-u" old-version))))))))
a7e98271 380
fe962364 381(defun vc-rcs-checkout (file &optional editable rev workfile)
d8aff077
GM
382 "Retrieve a copy of a saved version of FILE into a workfile."
383 (let ((filename (or workfile file))
384 (file-buffer (get-file-buffer file))
385 switches)
386 (message "Checking out %s..." filename)
387 (save-excursion
388 ;; Change buffers to get local value of vc-checkout-switches.
389 (if file-buffer (set-buffer file-buffer))
390 (setq switches (if (stringp vc-checkout-switches)
391 (list vc-checkout-switches)
392 vc-checkout-switches))
393 ;; Save this buffer's default-directory
394 ;; and use save-excursion to make sure it is restored
395 ;; in the same buffer it was saved in.
396 (let ((default-directory default-directory))
397 (save-excursion
398 ;; Adjust the default-directory so that the check-out creates
399 ;; the file in the right place.
400 (setq default-directory (file-name-directory filename))
401 (if workfile ;; RCS
402 ;; RCS can't check out into arbitrary file names directly.
403 ;; Use `co -p' and make stdout point to the correct file.
404 (let ((vc-modes (logior (file-modes (vc-name file))
fe962364 405 (if editable 128 0)))
d8aff077
GM
406 (failed t))
407 (unwind-protect
408 (progn
409 (let ((coding-system-for-read 'no-conversion)
410 (coding-system-for-write 'no-conversion))
411 (with-temp-file filename
412 (apply 'vc-do-command
413 (current-buffer) 0 "co" (vc-name file)
414 "-q" ;; suppress diagnostic output
fe962364 415 (if editable "-l")
d8aff077
GM
416 (concat "-p" rev)
417 switches)))
33c1b7a1 418 (set-file-modes filename
d8aff077 419 (logior (file-modes (vc-name file))
fe962364 420 (if editable 128 0)))
d8aff077 421 (setq failed nil))
33c1b7a1 422 (and failed (file-exists-p filename)
d8aff077
GM
423 (delete-file filename))))
424 (let (new-version)
425 ;; if we should go to the head of the trunk,
426 ;; clear the default branch first
427 (and rev (string= rev "")
a7e98271 428 (vc-rcs-set-default-branch file nil))
d8aff077
GM
429 ;; now do the checkout
430 (apply 'vc-do-command
431 nil 0 "co" (vc-name file)
432 ;; If locking is not strict, force to overwrite
433 ;; the writable workfile.
434 (if (eq (vc-checkout-model file) 'implicit) "-f")
fe962364 435 (if editable "-l")
d8aff077
GM
436 (if rev (concat "-r" rev)
437 ;; if no explicit revision was specified,
438 ;; check out that of the working file
439 (let ((workrev (vc-workfile-version file)))
440 (if workrev (concat "-r" workrev)
441 nil)))
442 switches)
443 ;; determine the new workfile version
444 (with-current-buffer "*vc*"
445 (setq new-version
446 (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1)))
447 (vc-file-setprop file 'vc-workfile-version new-version)
448 ;; if necessary, adjust the default branch
449 (and rev (not (string= rev ""))
a7e98271
AS
450 (vc-rcs-set-default-branch
451 file
452 (if (vc-rcs-latest-on-branch-p file new-version)
453 (if (vc-rcs-trunk-p new-version) nil
454 (vc-rcs-branch-part new-version))
455 new-version))))))
d8aff077
GM
456 (message "Checking out %s...done" filename)))))
457
99739bbf 458(defun vc-rcs-revert (file &optional contents-done)
8f98485f
AS
459 "Revert FILE to the version it was based on."
460 (vc-do-command nil 0 "co" (vc-name file) "-f"
461 (concat "-u" (vc-workfile-version file))))
462
fe962364 463(defun vc-rcs-cancel-version (file editable)
8f98485f 464 "Undo the most recent checkin of FILE.
fe962364 465EDITABLE non-nil means previous version should be locked."
8f98485f
AS
466 (let* ((target (vc-workfile-version file))
467 (previous (if (vc-trunk-p target) "" (vc-branch-part target)))
468 (config (current-window-configuration))
469 (done nil))
470 (vc-do-command nil 0 "rcs" (vc-name file) (concat "-o" target))
471 ;; Check out the most recent remaining version. If it fails, because
472 ;; the whole branch got deleted, do a double-take and check out the
473 ;; version where the branch started.
474 (while (not done)
475 (condition-case err
476 (progn
477 (vc-do-command nil 0 "co" (vc-name file) "-f"
fe962364 478 (concat (if editable "-l" "-u") previous))
8f98485f
AS
479 (setq done t))
480 (error (set-buffer "*vc*")
481 (goto-char (point-min))
482 (if (search-forward "no side branches present for" nil t)
483 (progn (setq previous (vc-branch-part previous))
484 (vc-rcs-set-default-branch file previous)
485 ;; vc-do-command popped up a window with
486 ;; the error message. Get rid of it, by
487 ;; restoring the old window configuration.
488 (set-window-configuration config))
489 ;; No, it was some other error: re-signal it.
490 (signal (car err) (cdr err))))))))
491
492(defun vc-rcs-merge (file first-version &optional second-version)
493 "Merge changes into current working copy of FILE.
494The changes are between FIRST-VERSION and SECOND-VERSION."
495 (vc-do-command nil 1 "rcsmerge" (vc-name file)
496 "-kk" ; ignore keyword conflicts
497 (concat "-r" first-version)
498 (if second-version (concat "-r" second-version))))
499
500(defun vc-rcs-steal-lock (file &optional rev)
501 "Steal the lock on the current workfile for FILE and revision REV.
502Needs RCS 5.6.2 or later for -M."
503 (vc-do-command nil 0 "rcs" (vc-name file) "-M"
504 (concat "-u" rev) (concat "-l" rev)))
505
506
507\f
508;;;
509;;; History functions
510;;;
511
512(defun vc-rcs-print-log (file)
513 "Get change log associated with FILE."
cdc2fe43 514 (vc-do-command nil 0 "rlog" (vc-name file)))
8f98485f
AS
515
516(defun vc-rcs-show-log-entry (version)
517 (when (re-search-forward
518 ;; also match some context, for safety
519 (concat "----\nrevision " version
520 "\\(\tlocked by:.*\n\\|\n\\)date: ") nil t)
521 ;; set the display window so that
522 ;; the whole log entry is displayed
523 (let (start end lines)
524 (beginning-of-line) (forward-line -1) (setq start (point))
525 (if (not (re-search-forward "^----*\nrevision" nil t))
526 (setq end (point-max))
527 (beginning-of-line) (forward-line -1) (setq end (point)))
528 (setq lines (count-lines start end))
529 (cond
530 ;; if the global information and this log entry fit
531 ;; into the window, display from the beginning
532 ((< (count-lines (point-min) end) (window-height))
533 (goto-char (point-min))
534 (recenter 0)
535 (goto-char start))
536 ;; if the whole entry fits into the window,
537 ;; display it centered
538 ((< (1+ lines) (window-height))
539 (goto-char start)
540 (recenter (1- (- (/ (window-height) 2) (/ lines 2)))))
541 ;; otherwise (the entry is too large for the window),
542 ;; display from the start
543 (t
544 (goto-char start)
545 (recenter 0))))))
546
547(defun vc-rcs-diff (file &optional oldvers newvers)
548 "Get a difference report using RCS between two versions of FILE."
549 (if (not oldvers) (setq oldvers (vc-workfile-version file)))
cdc2fe43 550 (apply 'vc-do-command "*vc-diff*" 1 "rcsdiff" file
10489ed7
AS
551 (append (list "-q"
552 (concat "-r" oldvers)
553 (and newvers (concat "-r" newvers)))
554 (vc-diff-switches-list rcs))))
8f98485f
AS
555
556\f
557;;;
558;;; Snapshot system
559;;;
560
561(defun vc-rcs-assign-name (file name)
562 "Assign to FILE's latest version a given NAME."
563 (vc-do-command nil 0 "rcs" (vc-name file) (concat "-n" name ":")))
564
565\f
566;;;
567;;; Miscellaneous
568;;;
569
570(defun vc-rcs-check-headers ()
571 "Check if the current file has any headers in it."
572 (save-excursion
573 (goto-char (point-min))
574 (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\
575\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)))
576
577(defun vc-rcs-clear-headers ()
578 "Implementation of vc-clear-headers for RCS."
579 (let ((case-fold-search nil))
580 (goto-char (point-min))
581 (while (re-search-forward
582 (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|"
583 "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$")
584 nil t)
585 (replace-match "$\\1$"))))
586
587(defun vc-rcs-rename-file (old new)
588 ;; Just move the master file (using vc-rcs-master-templates).
589 (vc-rename-master (vc-name old) new vc-rcs-master-templates))
590
591\f
592;;;
593;;; Internal functions
594;;;
595
596(defun vc-rcs-trunk-p (rev)
597 "Return t if REV is an RCS revision on the trunk."
598 (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
599
600(defun vc-rcs-branch-part (rev)
601 "Return the branch part of an RCS revision number REV"
602 (substring rev 0 (string-match "\\.[0-9]+\\'" rev)))
603
604(defun vc-rcs-branch-p (rev)
605 "Return t if REV is an RCS branch revision"
606 (not (eq nil (string-match "\\`[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*\\'" rev))))
607
608(defun vc-rcs-minor-part (rev)
609 "Return the minor version number of an RCS revision number REV."
610 (string-match "[0-9]+\\'" rev)
611 (substring rev (match-beginning 0) (match-end 0)))
612
613(defun vc-rcs-previous-version (rev)
614 "Guess the previous RCS version number"
615 (let ((branch (vc-rcs-branch-part rev))
616 (minor-num (string-to-number (vc-rcs-minor-part rev))))
617 (if (> minor-num 1)
618 ;; version does probably not start a branch or release
619 (concat branch "." (number-to-string (1- minor-num)))
620 (if (vc-rcs-trunk-p rev)
621 ;; we are at the beginning of the trunk --
622 ;; don't know anything to return here
623 ""
624 ;; we are at the beginning of a branch --
625 ;; return version of starting point
626 (vc-rcs-branch-part branch)))))
627
628(defun vc-rcs-workfile-is-newer (file)
629 "Return non-nil if FILE is newer than its RCS master.
630This likely means that FILE has been changed with respect
631to its master version."
632 (let ((file-time (nth 5 (file-attributes file)))
633 (master-time (nth 5 (file-attributes (vc-name file)))))
634 (or (> (nth 0 file-time) (nth 0 master-time))
635 (and (= (nth 0 file-time) (nth 0 master-time))
636 (> (nth 1 file-time) (nth 1 master-time))))))
637
638(defun vc-rcs-find-most-recent-rev (branch)
639 "Find most recent revision on BRANCH."
640 (goto-char (point-min))
641 (let ((latest-rev -1) value)
642 (while (re-search-forward (concat "^\\(" (regexp-quote branch)
643 "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;")
644 nil t)
645 (let ((rev (string-to-number (match-string 2))))
646 (when (< latest-rev rev)
647 (setq latest-rev rev)
648 (setq value (match-string 1)))))
649 (or value
650 (vc-rcs-branch-part branch))))
651
652(defun vc-rcs-fetch-master-state (file &optional workfile-version)
653 "Compute the master file's idea of the state of FILE.
654If a WORKFILE-VERSION is given, compute the state of that version,
655otherwise determine the workfile version based on the master file.
656This function sets the properties `vc-workfile-version' and
657`vc-checkout-model' to their correct values, based on the master
658file."
659 (with-temp-buffer
660 (vc-insert-file (vc-name file) "^[0-9]")
661 (let ((workfile-is-latest nil)
662 (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1)))
663 (vc-file-setprop file 'vc-rcs-default-branch default-branch)
664 (unless workfile-version
665 ;; Workfile version not known yet. Determine that first. It
666 ;; is either the head of the trunk, the head of the default
667 ;; branch, or the "default branch" itself, if that is a full
668 ;; revision number.
669 (cond
670 ;; no default branch
671 ((or (not default-branch) (string= "" default-branch))
672 (setq workfile-version
673 (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1))
674 (setq workfile-is-latest t))
675 ;; default branch is actually a revision
676 ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
677 default-branch)
678 (setq workfile-version default-branch))
679 ;; else, search for the head of the default branch
680 (t (vc-insert-file (vc-name file) "^desc")
681 (setq workfile-version
682 (vc-rcs-find-most-recent-rev default-branch))
683 (setq workfile-is-latest t)))
684 (vc-file-setprop file 'vc-workfile-version workfile-version))
685 ;; Check strict locking
686 (goto-char (point-min))
687 (vc-file-setprop file 'vc-checkout-model
688 (if (re-search-forward ";[ \t\n]*strict;" nil t)
689 'locking 'implicit))
690 ;; Compute state of workfile version
691 (goto-char (point-min))
692 (let ((locking-user
693 (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):"
694 (regexp-quote workfile-version)
695 "[^0-9.]")
696 1)))
697 (cond
698 ;; not locked
699 ((not locking-user)
700 (if (or workfile-is-latest
701 (vc-rcs-latest-on-branch-p file workfile-version))
702 ;; workfile version is latest on branch
036f45fa 703 'up-to-date
8f98485f
AS
704 ;; workfile version is not latest on branch
705 'needs-patch))
706 ;; locked by the calling user
707 ((and (stringp locking-user)
708 (string= locking-user (vc-user-login-name)))
709 (if (or (eq (vc-checkout-model file) 'locking)
710 workfile-is-latest
711 (vc-rcs-latest-on-branch-p file workfile-version))
712 'edited
713 ;; Locking is not used for the file, but the owner does
714 ;; have a lock, and there is a higher version on the current
715 ;; branch. Not sure if this can occur, and if it is right
716 ;; to use `needs-merge' in this case.
717 'needs-merge))
718 ;; locked by somebody else
719 ((stringp locking-user)
720 locking-user)
721 (t
722 (error "Error getting state of RCS file")))))))
723
724(defun vc-rcs-consult-headers (file)
725 "Search for RCS headers in FILE, and set properties accordingly.
726
727Returns: nil if no headers were found
728 'rev if a workfile revision was found
729 'rev-and-lock if revision and lock info was found"
730 (cond
731 ((not (get-file-buffer file)) nil)
732 ((let (status version locking-user)
733 (save-excursion
734 (set-buffer (get-file-buffer file))
735 (goto-char (point-min))
736 (cond
737 ;; search for $Id or $Header
738 ;; -------------------------
739 ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file.
740 ((or (and (search-forward "$Id\ : " nil t)
741 (looking-at "[^ ]+ \\([0-9.]+\\) "))
742 (and (progn (goto-char (point-min))
743 (search-forward "$Header\ : " nil t))
744 (looking-at "[^ ]+ \\([0-9.]+\\) ")))
745 (goto-char (match-end 0))
746 ;; if found, store the revision number ...
747 (setq version (match-string-no-properties 1))
748 ;; ... and check for the locking state
749 (cond
750 ((looking-at
751 (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date
752 "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time
753 "[^ ]+ [^ ]+ ")) ; author & state
754 (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds
755 (cond
756 ;; unlocked revision
757 ((looking-at "\\$")
758 (setq locking-user 'none)
759 (setq status 'rev-and-lock))
760 ;; revision is locked by some user
761 ((looking-at "\\([^ ]+\\) \\$")
762 (setq locking-user (match-string-no-properties 1))
763 (setq status 'rev-and-lock))
764 ;; everything else: false
765 (nil)))
766 ;; unexpected information in
767 ;; keyword string --> quit
768 (nil)))
769 ;; search for $Revision
770 ;; --------------------
771 ((re-search-forward (concat "\\$"
772 "Revision: \\([0-9.]+\\) \\$")
773 nil t)
774 ;; if found, store the revision number ...
775 (setq version (match-string-no-properties 1))
776 ;; and see if there's any lock information
777 (goto-char (point-min))
778 (if (re-search-forward (concat "\\$" "Locker:") nil t)
779 (cond ((looking-at " \\([^ ]+\\) \\$")
780 (setq locking-user (match-string-no-properties 1))
781 (setq status 'rev-and-lock))
782 ((looking-at " *\\$")
783 (setq locking-user 'none)
784 (setq status 'rev-and-lock))
785 (t
786 (setq locking-user 'none)
787 (setq status 'rev-and-lock)))
788 (setq status 'rev)))
789 ;; else: nothing found
790 ;; -------------------
791 (t nil)))
792 (if status (vc-file-setprop file 'vc-workfile-version version))
793 (and (eq status 'rev-and-lock)
794 (vc-file-setprop file 'vc-state
795 (cond
796 ((eq locking-user 'none) 'up-to-date)
797 ((string= locking-user (vc-user-login-name)) 'edited)
798 (t locking-user)))
799 ;; If the file has headers, we don't want to query the
800 ;; master file, because that would eliminate all the
801 ;; performance gain the headers brought us. We therefore
802 ;; use a heuristic now to find out whether locking is used
803 ;; for this file. If we trust the file permissions, and the
804 ;; file is not locked, then if the file is read-only we
805 ;; assume that locking is used for the file, otherwise
806 ;; locking is not used.
807 (not (vc-mistrust-permissions file))
808 (vc-up-to-date-p file)
809 (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
810 (vc-file-setprop file 'vc-checkout-model 'locking)
811 (vc-file-setprop file 'vc-checkout-model 'implicit)))
812 status))))
813
814(defun vc-release-greater-or-equal (r1 r2)
815 "Compare release numbers, represented as strings.
816Release components are assumed cardinal numbers, not decimal fractions
817\(5.10 is a higher release than 5.9\). Omitted fields are considered
818lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end
819of the string is found, or a non-numeric component shows up \(5.6.7 is
820earlier than \"5.6.7 beta\", which is probably not what you want in
821some cases\). This code is suitable for existing RCS release numbers.
822CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)."
823 (let (v1 v2 i1 i2)
824 (catch 'done
825 (or (and (string-match "^\\.?\\([0-9]+\\)" r1)
826 (setq i1 (match-end 0))
827 (setq v1 (string-to-number (match-string 1 r1)))
828 (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
829 (setq i2 (match-end 0))
830 (setq v2 (string-to-number (match-string 1 r2)))
831 (if (> v1 v2) (throw 'done t)
832 (if (< v1 v2) (throw 'done nil)
833 (throw 'done
834 (vc-release-greater-or-equal
835 (substring r1 i1)
836 (substring r2 i2)))))))
837 (throw 'done t)))
838 (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
839 (throw 'done nil))
840 (throw 'done t)))))
841
842(defun vc-rcs-release-p (release)
843 "Return t if we have RELEASE or better."
844 (let ((installation (vc-rcs-system-release)))
845 (if (and installation
846 (not (eq installation 'unknown)))
847 (vc-release-greater-or-equal installation release))))
848
849
850(defun vc-rcs-system-release ()
851 "Return the RCS release installed on this system, as a string.
852Return symbol UNKNOWN if the release cannot be deducted. The user can
853override this using variable `vc-rcs-release'.
854
855If the user has not set variable `vc-rcs-release' and it is nil,
856variable `vc-rcs-release' is set to the returned value."
857 (or vc-rcs-release
858 (setq vc-rcs-release
859 (or (and (zerop (vc-do-command nil nil "rcs" nil "-V"))
860 (with-current-buffer (get-buffer "*vc*")
861 (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1)))
862 'unknown))))
863
864(defun vc-rcs-set-non-strict-locking (file)
865 (vc-do-command nil 0 "rcs" file "-U")
866 (vc-file-setprop file 'vc-checkout-model 'implicit)
867 (set-file-modes file (logior (file-modes file) 128)))
868
869(defun vc-rcs-set-default-branch (file branch)
870 (vc-do-command nil 0 "rcs" (vc-name file) (concat "-b" branch))
871 (vc-file-setprop file 'vc-rcs-default-branch branch))
872
d8aff077
GM
873(provide 'vc-rcs)
874
875;;; vc-rcs.el ends here