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