Mercurial > emacs
comparison lisp/vc/vc-rcs.el @ 109063:c77749185234
merge trunk
author | Kenichi Handa <handa@etlken> |
---|---|
date | Thu, 24 Jun 2010 15:10:43 +0900 |
parents | lisp/vc-rcs.el@1918e70c8b37 lisp/vc-rcs.el@6ff48295959a |
children | 1b626601d32d |
comparison
equal
deleted
inserted
replaced
108814:9d7ea82188d8 | 109063:c77749185234 |
---|---|
1 ;;; vc-rcs.el --- support for RCS version-control | |
2 | |
3 ;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, | |
4 ;; 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 | |
5 ;; Free Software Foundation, Inc. | |
6 | |
7 ;; Author: FSF (see vc.el for full credits) | |
8 ;; Maintainer: Andre Spiegel <spiegel@gnu.org> | |
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 3 of the License, or | |
15 ;; (at your option) 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. If not, see <http://www.gnu.org/licenses/>. | |
24 | |
25 ;;; Commentary: | |
26 | |
27 ;; See vc.el | |
28 | |
29 ;; Some features will not work with old RCS versions. Where | |
30 ;; appropriate, VC finds out which version you have, and allows or | |
31 ;; disallows those features (stealing locks, for example, works only | |
32 ;; from 5.6.2 onwards). | |
33 ;; Even initial checkins will fail if your RCS version is so old that ci | |
34 ;; doesn't understand -t-; this has been known to happen to people running | |
35 ;; NExTSTEP 3.0. | |
36 ;; | |
37 ;; You can support the RCS -x option by customizing vc-rcs-master-templates. | |
38 | |
39 ;;; Code: | |
40 | |
41 ;;; | |
42 ;;; Customization options | |
43 ;;; | |
44 | |
45 (eval-when-compile | |
46 (require 'cl) | |
47 (require 'vc)) | |
48 | |
49 (defcustom vc-rcs-release nil | |
50 "The release number of your RCS installation, as a string. | |
51 If nil, VC itself computes this value when it is first needed." | |
52 :type '(choice (const :tag "Auto" nil) | |
53 (string :tag "Specified") | |
54 (const :tag "Unknown" unknown)) | |
55 :group 'vc) | |
56 | |
57 (defcustom vc-rcs-register-switches nil | |
58 "Switches for registering a file in RCS. | |
59 A string or list of strings passed to the checkin program by | |
60 \\[vc-register]. If nil, use the value of `vc-register-switches'. | |
61 If t, use no switches." | |
62 :type '(choice (const :tag "Unspecified" nil) | |
63 (const :tag "None" t) | |
64 (string :tag "Argument String") | |
65 (repeat :tag "Argument List" :value ("") string)) | |
66 :version "21.1" | |
67 :group 'vc) | |
68 | |
69 (defcustom vc-rcs-diff-switches nil | |
70 "String or list of strings specifying switches for RCS diff under VC. | |
71 If nil, use the value of `vc-diff-switches'. If t, use no switches." | |
72 :type '(choice (const :tag "Unspecified" nil) | |
73 (const :tag "None" t) | |
74 (string :tag "Argument String") | |
75 (repeat :tag "Argument List" :value ("") string)) | |
76 :version "21.1" | |
77 :group 'vc) | |
78 | |
79 (defcustom vc-rcs-header (or (cdr (assoc 'RCS vc-header-alist)) '("\$Id\$")) | |
80 "Header keywords to be inserted by `vc-insert-headers'." | |
81 :type '(repeat string) | |
82 :version "21.1" | |
83 :group 'vc) | |
84 | |
85 (defcustom vc-rcsdiff-knows-brief nil | |
86 "Indicates whether rcsdiff understands the --brief option. | |
87 The value is either `yes', `no', or nil. If it is nil, VC tries | |
88 to use --brief and sets this variable to remember whether it worked." | |
89 :type '(choice (const :tag "Work out" nil) (const yes) (const no)) | |
90 :group 'vc) | |
91 | |
92 ;;;###autoload | |
93 (defcustom vc-rcs-master-templates | |
94 (purecopy '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")) | |
95 "Where to look for RCS master files. | |
96 For a description of possible values, see `vc-check-master-templates'." | |
97 :type '(choice (const :tag "Use standard RCS file names" | |
98 '("%sRCS/%s,v" "%s%s,v" "%sRCS/%s")) | |
99 (repeat :tag "User-specified" | |
100 (choice string | |
101 function))) | |
102 :version "21.1" | |
103 :group 'vc) | |
104 | |
105 | |
106 ;;; Properties of the backend | |
107 | |
108 (defun vc-rcs-revision-granularity () 'file) | |
109 | |
110 (defun vc-rcs-checkout-model (files) | |
111 "RCS-specific version of `vc-checkout-model'." | |
112 (let ((file (if (consp files) (car files) files)) | |
113 result) | |
114 (when vc-consult-headers | |
115 (vc-file-setprop file 'vc-checkout-model nil) | |
116 (vc-rcs-consult-headers file) | |
117 (setq result (vc-file-getprop file 'vc-checkout-model))) | |
118 (or result | |
119 (progn (vc-rcs-fetch-master-state file) | |
120 (vc-file-getprop file 'vc-checkout-model))))) | |
121 | |
122 ;;; | |
123 ;;; State-querying functions | |
124 ;;; | |
125 | |
126 ;; The autoload cookie below places vc-rcs-registered directly into | |
127 ;; loaddefs.el, so that vc-rcs.el does not need to be loaded for | |
128 ;; every file that is visited. | |
129 ;;;###autoload | |
130 (progn | |
131 (defun vc-rcs-registered (f) (vc-default-registered 'RCS f))) | |
132 | |
133 (defun vc-rcs-state (file) | |
134 "Implementation of `vc-state' for RCS." | |
135 (if (not (vc-rcs-registered file)) | |
136 'unregistered | |
137 (or (boundp 'vc-rcs-headers-result) | |
138 (and vc-consult-headers | |
139 (vc-rcs-consult-headers file))) | |
140 (let ((state | |
141 ;; vc-working-revision might not be known; in that case the | |
142 ;; property is nil. vc-rcs-fetch-master-state knows how to | |
143 ;; handle that. | |
144 (vc-rcs-fetch-master-state file | |
145 (vc-file-getprop file | |
146 'vc-working-revision)))) | |
147 (if (not (eq state 'up-to-date)) | |
148 state | |
149 (if (vc-workfile-unchanged-p file) | |
150 'up-to-date | |
151 (if (eq (vc-rcs-checkout-model (list file)) 'locking) | |
152 'unlocked-changes | |
153 'edited)))))) | |
154 | |
155 (defun vc-rcs-state-heuristic (file) | |
156 "State heuristic for RCS." | |
157 (let (vc-rcs-headers-result) | |
158 (if (and vc-consult-headers | |
159 (setq vc-rcs-headers-result | |
160 (vc-rcs-consult-headers file)) | |
161 (eq vc-rcs-headers-result 'rev-and-lock)) | |
162 (let ((state (vc-file-getprop file 'vc-state))) | |
163 ;; If the headers say that the file is not locked, the | |
164 ;; permissions can tell us whether locking is used for | |
165 ;; the file or not. | |
166 (if (and (eq state 'up-to-date) | |
167 (not (vc-mistrust-permissions file)) | |
168 (file-exists-p file)) | |
169 (cond | |
170 ((string-match ".rw..-..-." (nth 8 (file-attributes file))) | |
171 (vc-file-setprop file 'vc-checkout-model 'implicit) | |
172 (setq state | |
173 (if (vc-rcs-workfile-is-newer file) | |
174 'edited | |
175 'up-to-date))) | |
176 ((string-match ".r-..-..-." (nth 8 (file-attributes file))) | |
177 (vc-file-setprop file 'vc-checkout-model 'locking)))) | |
178 state) | |
179 (if (not (vc-mistrust-permissions file)) | |
180 (let* ((attributes (file-attributes file 'string)) | |
181 (owner-name (nth 2 attributes)) | |
182 (permissions (nth 8 attributes))) | |
183 (cond ((and permissions (string-match ".r-..-..-." permissions)) | |
184 (vc-file-setprop file 'vc-checkout-model 'locking) | |
185 'up-to-date) | |
186 ((and permissions (string-match ".rw..-..-." permissions)) | |
187 (if (eq (vc-rcs-checkout-model file) 'locking) | |
188 (if (file-ownership-preserved-p file) | |
189 'edited | |
190 owner-name) | |
191 (if (vc-rcs-workfile-is-newer file) | |
192 'edited | |
193 'up-to-date))) | |
194 (t | |
195 ;; Strange permissions. Fall through to | |
196 ;; expensive state computation. | |
197 (vc-rcs-state file)))) | |
198 (vc-rcs-state file))))) | |
199 | |
200 (defun vc-rcs-dir-status (dir update-function) | |
201 ;; FIXME: this function should be rewritten or `vc-expand-dirs' | |
202 ;; should be changed to take a backend parameter. Using | |
203 ;; `vc-expand-dirs' is not TRTD because it returns files from | |
204 ;; multiple backends. It should also return 'unregistered files. | |
205 | |
206 ;; Doing individual vc-state calls is painful but there | |
207 ;; is no better way in RCS-land. | |
208 (let ((flist (vc-expand-dirs (list dir))) | |
209 (result nil)) | |
210 (dolist (file flist) | |
211 (let ((state (vc-state file)) | |
212 (frel (file-relative-name file))) | |
213 (when (and (eq (vc-backend file) 'RCS) | |
214 (not (eq state 'up-to-date))) | |
215 (push (list frel state) result)))) | |
216 (funcall update-function result))) | |
217 | |
218 (defun vc-rcs-working-revision (file) | |
219 "RCS-specific version of `vc-working-revision'." | |
220 (or (and vc-consult-headers | |
221 (vc-rcs-consult-headers file) | |
222 (vc-file-getprop file 'vc-working-revision)) | |
223 (progn | |
224 (vc-rcs-fetch-master-state file) | |
225 (vc-file-getprop file 'vc-working-revision)))) | |
226 | |
227 (defun vc-rcs-latest-on-branch-p (file &optional version) | |
228 "Return non-nil if workfile version of FILE is the latest on its branch. | |
229 When VERSION is given, perform check for that version." | |
230 (unless version (setq version (vc-working-revision file))) | |
231 (with-temp-buffer | |
232 (string= version | |
233 (if (vc-rcs-trunk-p version) | |
234 (progn | |
235 ;; Compare VERSION to the head version number. | |
236 (vc-insert-file (vc-name file) "^[0-9]") | |
237 (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) | |
238 ;; If we are not on the trunk, we need to examine the | |
239 ;; whole current branch. | |
240 (vc-insert-file (vc-name file) "^desc") | |
241 (vc-rcs-find-most-recent-rev (vc-branch-part version)))))) | |
242 | |
243 (defun vc-rcs-workfile-unchanged-p (file) | |
244 "RCS-specific implementation of `vc-workfile-unchanged-p'." | |
245 ;; Try to use rcsdiff --brief. If rcsdiff does not understand that, | |
246 ;; do a double take and remember the fact for the future | |
247 (let* ((version (concat "-r" (vc-working-revision file))) | |
248 (status (if (eq vc-rcsdiff-knows-brief 'no) | |
249 (vc-do-command "*vc*" 1 "rcsdiff" file version) | |
250 (vc-do-command "*vc*" 2 "rcsdiff" file "--brief" version)))) | |
251 (if (eq status 2) | |
252 (if (not vc-rcsdiff-knows-brief) | |
253 (setq vc-rcsdiff-knows-brief 'no | |
254 status (vc-do-command "*vc*" 1 "rcsdiff" file version)) | |
255 (error "rcsdiff failed")) | |
256 (if (not vc-rcsdiff-knows-brief) (setq vc-rcsdiff-knows-brief 'yes))) | |
257 ;; The workfile is unchanged if rcsdiff found no differences. | |
258 (zerop status))) | |
259 | |
260 | |
261 ;;; | |
262 ;;; State-changing functions | |
263 ;;; | |
264 | |
265 (defun vc-rcs-create-repo () | |
266 "Create a new RCS repository." | |
267 ;; RCS is totally file-oriented, so all we have to do is make the directory. | |
268 (make-directory "RCS")) | |
269 | |
270 (defun vc-rcs-register (files &optional rev comment) | |
271 "Register FILES into the RCS version-control system. | |
272 REV is the optional revision number for the files. COMMENT can be used | |
273 to provide an initial description for each FILES. | |
274 Passes either `vc-rcs-register-switches' or `vc-register-switches' | |
275 to the RCS command. | |
276 | |
277 Automatically retrieve a read-only version of the file with keywords | |
278 expanded if `vc-keep-workfiles' is non-nil, otherwise, delete the workfile." | |
279 (let (subdir name) | |
280 ;; When REV is specified, we need to force using "-t-". | |
281 (when rev (unless comment (setq comment ""))) | |
282 (dolist (file files) | |
283 (and (not (file-exists-p | |
284 (setq subdir (expand-file-name "RCS" | |
285 (file-name-directory file))))) | |
286 (not (directory-files (file-name-directory file) | |
287 nil ".*,v$" t)) | |
288 (yes-or-no-p "Create RCS subdirectory? ") | |
289 (make-directory subdir)) | |
290 (apply 'vc-do-command "*vc*" 0 "ci" file | |
291 ;; if available, use the secure registering option | |
292 (and (vc-rcs-release-p "5.6.4") "-i") | |
293 (concat (if vc-keep-workfiles "-u" "-r") rev) | |
294 (and comment (concat "-t-" comment)) | |
295 (vc-switches 'RCS 'register)) | |
296 ;; parse output to find master file name and workfile version | |
297 (with-current-buffer "*vc*" | |
298 (goto-char (point-min)) | |
299 (if (not (setq name | |
300 (if (looking-at (concat "^\\(.*\\) <-- " | |
301 (file-name-nondirectory file))) | |
302 (match-string 1)))) | |
303 ;; if we couldn't find the master name, | |
304 ;; run vc-rcs-registered to get it | |
305 ;; (will be stored into the vc-name property) | |
306 (vc-rcs-registered file) | |
307 (vc-file-setprop file 'vc-name | |
308 (if (file-name-absolute-p name) | |
309 name | |
310 (expand-file-name | |
311 name | |
312 (file-name-directory file)))))) | |
313 (vc-file-setprop file 'vc-working-revision | |
314 (if (re-search-forward | |
315 "^initial revision: \\([0-9.]+\\).*\n" | |
316 nil t) | |
317 (match-string 1)))))) | |
318 | |
319 (defun vc-rcs-responsible-p (file) | |
320 "Return non-nil if RCS thinks it would be responsible for registering FILE." | |
321 ;; TODO: check for all the patterns in vc-rcs-master-templates | |
322 (file-directory-p (expand-file-name "RCS" (file-name-directory file)))) | |
323 | |
324 (defun vc-rcs-receive-file (file rev) | |
325 "Implementation of receive-file for RCS." | |
326 (let ((checkout-model (vc-rcs-checkout-model (list file)))) | |
327 (vc-rcs-register file rev "") | |
328 (when (eq checkout-model 'implicit) | |
329 (vc-rcs-set-non-strict-locking file)) | |
330 (vc-rcs-set-default-branch file (concat rev ".1")))) | |
331 | |
332 (defun vc-rcs-unregister (file) | |
333 "Unregister FILE from RCS. | |
334 If this leaves the RCS subdirectory empty, ask the user | |
335 whether to remove it." | |
336 (let* ((master (vc-name file)) | |
337 (dir (file-name-directory master)) | |
338 (backup-info (find-backup-file-name master))) | |
339 (if (not backup-info) | |
340 (delete-file master) | |
341 (rename-file master (car backup-info) 'ok-if-already-exists) | |
342 (dolist (f (cdr backup-info)) (ignore-errors (delete-file f)))) | |
343 (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS") | |
344 ;; check whether RCS dir is empty, i.e. it does not | |
345 ;; contain any files except "." and ".." | |
346 (not (directory-files dir nil | |
347 "^\\([^.]\\|\\.[^.]\\|\\.\\.[^.]\\).*")) | |
348 (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) | |
349 (delete-directory dir)))) | |
350 | |
351 (defun vc-rcs-checkin (files rev comment &optional extra-args-ignored) | |
352 "RCS-specific version of `vc-backend-checkin'." | |
353 (let ((switches (vc-switches 'RCS 'checkin))) | |
354 ;; Now operate on the files | |
355 (dolist (file (vc-expand-dirs files)) | |
356 (let ((old-version (vc-working-revision file)) new-version | |
357 (default-branch (vc-file-getprop file 'vc-rcs-default-branch))) | |
358 ;; Force branch creation if an appropriate | |
359 ;; default branch has been set. | |
360 (and (not rev) | |
361 default-branch | |
362 (string-match (concat "^" (regexp-quote old-version) "\\.") | |
363 default-branch) | |
364 (setq rev default-branch) | |
365 (setq switches (cons "-f" switches))) | |
366 (if (and (not rev) old-version) | |
367 (setq rev (vc-branch-part old-version))) | |
368 (apply 'vc-do-command "*vc*" 0 "ci" (vc-name file) | |
369 ;; if available, use the secure check-in option | |
370 (and (vc-rcs-release-p "5.6.4") "-j") | |
371 (concat (if vc-keep-workfiles "-u" "-r") rev) | |
372 (concat "-m" comment) | |
373 switches) | |
374 (vc-file-setprop file 'vc-working-revision nil) | |
375 | |
376 ;; determine the new workfile version | |
377 (set-buffer "*vc*") | |
378 (goto-char (point-min)) | |
379 (when (or (re-search-forward | |
380 "new revision: \\([0-9.]+\\);" nil t) | |
381 (re-search-forward | |
382 "reverting to previous revision \\([0-9.]+\\)" nil t)) | |
383 (setq new-version (match-string 1)) | |
384 (vc-file-setprop file 'vc-working-revision new-version)) | |
385 | |
386 ;; if we got to a different branch, adjust the default | |
387 ;; branch accordingly | |
388 (cond | |
389 ((and old-version new-version | |
390 (not (string= (vc-branch-part old-version) | |
391 (vc-branch-part new-version)))) | |
392 (vc-rcs-set-default-branch file | |
393 (if (vc-rcs-trunk-p new-version) nil | |
394 (vc-branch-part new-version))) | |
395 ;; If this is an old RCS release, we might have | |
396 ;; to remove a remaining lock. | |
397 (if (not (vc-rcs-release-p "5.6.2")) | |
398 ;; exit status of 1 is also accepted. | |
399 ;; It means that the lock was removed before. | |
400 (vc-do-command "*vc*" 1 "rcs" (vc-name file) | |
401 (concat "-u" old-version))))))))) | |
402 | |
403 (defun vc-rcs-find-revision (file rev buffer) | |
404 (apply 'vc-do-command | |
405 (or buffer "*vc*") 0 "co" (vc-name file) | |
406 "-q" ;; suppress diagnostic output | |
407 (concat "-p" rev) | |
408 (vc-switches 'RCS 'checkout))) | |
409 | |
410 (defun vc-rcs-checkout (file &optional editable rev) | |
411 "Retrieve a copy of a saved version of FILE. If FILE is a directory, | |
412 attempt the checkout for all registered files beneath it." | |
413 (if (file-directory-p file) | |
414 (mapc 'vc-rcs-checkout (vc-expand-dirs (list file))) | |
415 (let ((file-buffer (get-file-buffer file)) | |
416 switches) | |
417 (message "Checking out %s..." file) | |
418 (save-excursion | |
419 ;; Change buffers to get local value of vc-checkout-switches. | |
420 (if file-buffer (set-buffer file-buffer)) | |
421 (setq switches (vc-switches 'RCS 'checkout)) | |
422 ;; Save this buffer's default-directory | |
423 ;; and use save-excursion to make sure it is restored | |
424 ;; in the same buffer it was saved in. | |
425 (let ((default-directory default-directory)) | |
426 (save-excursion | |
427 ;; Adjust the default-directory so that the check-out creates | |
428 ;; the file in the right place. | |
429 (setq default-directory (file-name-directory file)) | |
430 (let (new-version) | |
431 ;; if we should go to the head of the trunk, | |
432 ;; clear the default branch first | |
433 (and rev (string= rev "") | |
434 (vc-rcs-set-default-branch file nil)) | |
435 ;; now do the checkout | |
436 (apply 'vc-do-command | |
437 "*vc*" 0 "co" (vc-name file) | |
438 ;; If locking is not strict, force to overwrite | |
439 ;; the writable workfile. | |
440 (if (eq (vc-rcs-checkout-model (list file)) 'implicit) "-f") | |
441 (if editable "-l") | |
442 (if (stringp rev) | |
443 ;; a literal revision was specified | |
444 (concat "-r" rev) | |
445 (let ((workrev (vc-working-revision file))) | |
446 (if workrev | |
447 (concat "-r" | |
448 (if (not rev) | |
449 ;; no revision specified: | |
450 ;; use current workfile version | |
451 workrev | |
452 ;; REV is t ... | |
453 (if (not (vc-rcs-trunk-p workrev)) | |
454 ;; ... go to head of current branch | |
455 (vc-branch-part workrev) | |
456 ;; ... go to head of trunk | |
457 (vc-rcs-set-default-branch file | |
458 nil) | |
459 "")))))) | |
460 switches) | |
461 ;; determine the new workfile version | |
462 (with-current-buffer "*vc*" | |
463 (setq new-version | |
464 (vc-parse-buffer "^revision \\([0-9.]+\\).*\n" 1))) | |
465 (vc-file-setprop file 'vc-working-revision new-version) | |
466 ;; if necessary, adjust the default branch | |
467 (and rev (not (string= rev "")) | |
468 (vc-rcs-set-default-branch | |
469 file | |
470 (if (vc-rcs-latest-on-branch-p file new-version) | |
471 (if (vc-rcs-trunk-p new-version) nil | |
472 (vc-branch-part new-version)) | |
473 new-version))))) | |
474 (message "Checking out %s...done" file)))))) | |
475 | |
476 (defun vc-rcs-rollback (files) | |
477 "Roll back, undoing the most recent checkins of FILES. Directories are | |
478 expanded to all registered subfiles in them." | |
479 (if (not files) | |
480 (error "RCS backend doesn't support directory-level rollback")) | |
481 (dolist (file (vc-expand-dirs files)) | |
482 (let* ((discard (vc-working-revision file)) | |
483 (previous (if (vc-rcs-trunk-p discard) "" (vc-branch-part discard))) | |
484 (config (current-window-configuration)) | |
485 (done nil)) | |
486 (if (null (yes-or-no-p (format "Remove version %s from %s history? " | |
487 discard file))) | |
488 (error "Aborted")) | |
489 (message "Removing revision %s from %s." discard file) | |
490 (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-o" discard)) | |
491 ;; Check out the most recent remaining version. If it | |
492 ;; fails, because the whole branch got deleted, do a | |
493 ;; double-take and check out the version where the branch | |
494 ;; started. | |
495 (while (not done) | |
496 (condition-case err | |
497 (progn | |
498 (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" | |
499 (concat "-u" previous)) | |
500 (setq done t)) | |
501 (error (set-buffer "*vc*") | |
502 (goto-char (point-min)) | |
503 (if (search-forward "no side branches present for" nil t) | |
504 (progn (setq previous (vc-branch-part previous)) | |
505 (vc-rcs-set-default-branch file previous) | |
506 ;; vc-do-command popped up a window with | |
507 ;; the error message. Get rid of it, by | |
508 ;; restoring the old window configuration. | |
509 (set-window-configuration config)) | |
510 ;; No, it was some other error: re-signal it. | |
511 (signal (car err) (cdr err))))))))) | |
512 | |
513 (defun vc-rcs-revert (file &optional contents-done) | |
514 "Revert FILE to the version it was based on. If FILE is a directory, | |
515 revert all registered files beneath it." | |
516 (if (file-directory-p file) | |
517 (mapc 'vc-rcs-revert (vc-expand-dirs (list file))) | |
518 (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" | |
519 (concat (if (eq (vc-state file) 'edited) "-u" "-r") | |
520 (vc-working-revision file))))) | |
521 | |
522 (defun vc-rcs-merge (file first-version &optional second-version) | |
523 "Merge changes into current working copy of FILE. | |
524 The changes are between FIRST-VERSION and SECOND-VERSION." | |
525 (vc-do-command "*vc*" 1 "rcsmerge" (vc-name file) | |
526 "-kk" ; ignore keyword conflicts | |
527 (concat "-r" first-version) | |
528 (if second-version (concat "-r" second-version)))) | |
529 | |
530 (defun vc-rcs-steal-lock (file &optional rev) | |
531 "Steal the lock on the current workfile for FILE and revision REV. | |
532 If FILE is a directory, steal the lock on all registered files beneath it. | |
533 Needs RCS 5.6.2 or later for -M." | |
534 (if (file-directory-p file) | |
535 (mapc 'vc-rcs-steal-lock (vc-expand-dirs (list file))) | |
536 (vc-do-command "*vc*" 0 "rcs" (vc-name file) "-M" (concat "-u" rev)) | |
537 ;; Do a real checkout after stealing the lock, so that we see | |
538 ;; expanded headers. | |
539 (vc-do-command "*vc*" 0 "co" (vc-name file) "-f" (concat "-l" rev)))) | |
540 | |
541 (defun vc-rcs-modify-change-comment (files rev comment) | |
542 "Modify the change comments change on FILES on a specified REV. If FILE is a | |
543 directory the operation is applied to all registered files beneath it." | |
544 (dolist (file (vc-expand-dirs files)) | |
545 (vc-do-command "*vc*" 0 "rcs" (vc-name file) | |
546 (concat "-m" rev ":" comment)))) | |
547 | |
548 | |
549 ;;; | |
550 ;;; History functions | |
551 ;;; | |
552 | |
553 (defun vc-rcs-print-log-cleanup () | |
554 (let ((inhibit-read-only t)) | |
555 (goto-char (point-max)) | |
556 (forward-line -1) | |
557 (while (looking-at "=*\n") | |
558 (delete-char (- (match-end 0) (match-beginning 0))) | |
559 (forward-line -1)) | |
560 (goto-char (point-min)) | |
561 (when (looking-at "[\b\t\n\v\f\r ]+") | |
562 (delete-char (- (match-end 0) (match-beginning 0)))))) | |
563 | |
564 (defun vc-rcs-print-log (files buffer &optional shortlog start-revision-ignored limit) | |
565 "Get change log associated with FILE. If FILE is a | |
566 directory the operation is applied to all registered files beneath it." | |
567 (vc-do-command (or buffer "*vc*") 0 "rlog" (mapcar 'vc-name (vc-expand-dirs files))) | |
568 (with-current-buffer (or buffer "*vc*") | |
569 (vc-rcs-print-log-cleanup)) | |
570 (when limit 'limit-unsupported)) | |
571 | |
572 (defun vc-rcs-diff (files &optional oldvers newvers buffer) | |
573 "Get a difference report using RCS between two sets of files." | |
574 (apply 'vc-do-command (or buffer "*vc-diff*") | |
575 1 ;; Always go synchronous, the repo is local | |
576 "rcsdiff" (vc-expand-dirs files) | |
577 (append (list "-q" | |
578 (and oldvers (concat "-r" oldvers)) | |
579 (and newvers (concat "-r" newvers))) | |
580 (vc-switches 'RCS 'diff)))) | |
581 | |
582 (defun vc-rcs-comment-history (file) | |
583 "Return a string with all log entries stored in BACKEND for FILE." | |
584 (with-current-buffer "*vc*" | |
585 ;; Has to be written this way, this function is used by the CVS backend too | |
586 (vc-call-backend (vc-backend file) 'print-log (list file)) | |
587 ;; Remove cruft | |
588 (let ((separator (concat "^-+\nrevision [0-9.]+\ndate: .*\n" | |
589 "\\(branches: .*;\n\\)?" | |
590 "\\(\\*\\*\\* empty log message \\*\\*\\*\n\\)?"))) | |
591 (goto-char (point-max)) (forward-line -1) | |
592 (while (looking-at "=*\n") | |
593 (delete-char (- (match-end 0) (match-beginning 0))) | |
594 (forward-line -1)) | |
595 (goto-char (point-min)) | |
596 (if (looking-at "[\b\t\n\v\f\r ]+") | |
597 (delete-char (- (match-end 0) (match-beginning 0)))) | |
598 (goto-char (point-min)) | |
599 (re-search-forward separator nil t) | |
600 (delete-region (point-min) (point)) | |
601 (while (re-search-forward separator nil t) | |
602 (delete-region (match-beginning 0) (match-end 0)))) | |
603 ;; Return the de-crufted comment list | |
604 (buffer-string))) | |
605 | |
606 (defun vc-rcs-annotate-command (file buffer &optional revision) | |
607 "Annotate FILE, inserting the results in BUFFER. | |
608 Optional arg REVISION is a revision to annotate from." | |
609 (vc-setup-buffer buffer) | |
610 ;; Aside from the "head revision on the trunk", the instructions for | |
611 ;; each revision on the trunk are an ordered list of kill and insert | |
612 ;; commands necessary to go from the chronologically-following | |
613 ;; revision to this one. That is, associated with revision N are | |
614 ;; edits that applied to revision N+1 would result in revision N. | |
615 ;; | |
616 ;; On a branch, however, (some) things are inverted: the commands | |
617 ;; listed are those necessary to go from the chronologically-preceding | |
618 ;; revision to this one. That is, associated with revision N are | |
619 ;; edits that applied to revision N-1 would result in revision N. | |
620 ;; | |
621 ;; So, to get per-line history info, we apply reverse-chronological | |
622 ;; edits, starting with the head revision on the trunk, all the way | |
623 ;; back through the initial revision (typically "1.1" or similar), | |
624 ;; then apply forward-chronological edits -- keeping track of which | |
625 ;; revision is associated with each inserted line -- until we reach | |
626 ;; the desired revision for display (which may be either on the trunk | |
627 ;; or on a branch). | |
628 (let* ((tree (with-temp-buffer | |
629 (insert-file-contents (vc-rcs-registered file)) | |
630 (vc-rcs-parse))) | |
631 (revisions (cdr (assq 'revisions tree))) | |
632 ;; The revision N whose instructions we currently are processing. | |
633 (cur (cdr (assq 'head (cdr (assq 'headers tree))))) | |
634 ;; Alist from the parse tree for N. | |
635 (meta (cdr (assoc cur revisions))) | |
636 ;; Point and temporary string, respectively. | |
637 p s | |
638 ;; "Next-branch list". Nil means the desired revision to | |
639 ;; display lives on the trunk. Non-nil means it lives on a | |
640 ;; branch, in which case the value is a list of revision pairs | |
641 ;; (PARENT . CHILD), the first PARENT being on the trunk, that | |
642 ;; links each series of revisions in the path from the initial | |
643 ;; revision to the desired revision to display. | |
644 nbls | |
645 ;; "Path-accumulate-predicate plus revision/date/author". | |
646 ;; Until set, forward-chronological edits are not accumulated. | |
647 ;; Once set, its value (updated every revision) is used for | |
648 ;; the text property `:vc-rcs-r/d/a' for inserts during | |
649 ;; processing of forward-chronological instructions for N. | |
650 ;; See internal func `r/d/a'. | |
651 prda | |
652 ;; List of forward-chronological instructions, each of the | |
653 ;; form: (POS . ACTION), where POS is a buffer position. If | |
654 ;; ACTION is a string, it is inserted, otherwise it is taken as | |
655 ;; the number of characters to be deleted. | |
656 path | |
657 ;; N+1. When `cur' is "", this is the initial revision. | |
658 pre) | |
659 (unless revision | |
660 (setq revision cur)) | |
661 (unless (assoc revision revisions) | |
662 (error "No such revision: %s" revision)) | |
663 ;; Find which branches (if any) must be included in the edits. | |
664 (let ((par revision) | |
665 bpt kids) | |
666 (while (setq bpt (vc-branch-part par) | |
667 par (vc-branch-part bpt)) | |
668 (setq kids (cdr (assq 'branches (cdr (assoc par revisions))))) | |
669 ;; A branchpoint may have multiple children. Find the right one. | |
670 (while (not (string= bpt (vc-branch-part (car kids)))) | |
671 (setq kids (cdr kids))) | |
672 (push (cons par (car kids)) nbls))) | |
673 ;; Start with the full text. | |
674 (set-buffer buffer) | |
675 (insert (cdr (assq 'text meta))) | |
676 ;; Apply reverse-chronological edits on the trunk, computing and | |
677 ;; accumulating forward-chronological edits after some point, for | |
678 ;; later. | |
679 (flet ((r/d/a () (vector pre | |
680 (cdr (assq 'date meta)) | |
681 (cdr (assq 'author meta))))) | |
682 (while (when (setq pre cur cur (cdr (assq 'next meta))) | |
683 (not (string= "" cur))) | |
684 (setq | |
685 ;; Start accumulating the forward-chronological edits when N+1 | |
686 ;; on the trunk is either the desired revision to display, or | |
687 ;; the appropriate branchpoint for it. Do this before | |
688 ;; updating `meta' since `r/d/a' uses N+1's `meta' value. | |
689 prda (when (or prda (string= (if nbls (caar nbls) revision) pre)) | |
690 (r/d/a)) | |
691 meta (cdr (assoc cur revisions))) | |
692 ;; Edits in the parse tree specify a line number (in the buffer | |
693 ;; *BEFORE* editing occurs) to start from, but line numbers | |
694 ;; change as a result of edits. To DTRT, we apply edits in | |
695 ;; order of descending buffer position so that edits further | |
696 ;; down in the buffer occur first w/o corrupting specified | |
697 ;; buffer positions of edits occurring towards the beginning of | |
698 ;; the buffer. In this way we avoid using markers. A pleasant | |
699 ;; property of this approach is ability to push instructions | |
700 ;; onto `path' directly, w/o need to maintain rev boundaries. | |
701 (dolist (insn (cdr (assq :insn meta))) | |
702 (goto-char (point-min)) | |
703 (forward-line (1- (pop insn))) | |
704 (setq p (point)) | |
705 (case (pop insn) | |
706 (k (setq s (buffer-substring-no-properties | |
707 p (progn (forward-line (car insn)) | |
708 (point)))) | |
709 (when prda | |
710 (push `(,p . ,(propertize s :vc-rcs-r/d/a prda)) path)) | |
711 (delete-region p (point))) | |
712 (i (setq s (car insn)) | |
713 (when prda | |
714 (push `(,p . ,(length s)) path)) | |
715 (insert s))))) | |
716 ;; For the initial revision, setting `:vc-rcs-r/d/a' directly is | |
717 ;; equivalent to pushing an insert instruction (of the entire buffer | |
718 ;; contents) onto `path' then erasing the buffer, but less wasteful. | |
719 (put-text-property (point-min) (point-max) :vc-rcs-r/d/a (r/d/a)) | |
720 ;; Now apply the forward-chronological edits for the trunk. | |
721 (dolist (insn path) | |
722 (goto-char (pop insn)) | |
723 (if (stringp insn) | |
724 (insert insn) | |
725 (delete-char insn))) | |
726 ;; Now apply the forward-chronological edits (directly from the | |
727 ;; parse-tree) for the branch(es), if necessary. We re-use vars | |
728 ;; `pre' and `meta' for the sake of internal func `r/d/a'. | |
729 (while nbls | |
730 (setq pre (cdr (pop nbls))) | |
731 (while (progn | |
732 (setq meta (cdr (assoc pre revisions)) | |
733 prda nil) | |
734 (dolist (insn (cdr (assq :insn meta))) | |
735 (goto-char (point-min)) | |
736 (forward-line (1- (pop insn))) | |
737 (case (pop insn) | |
738 (k (delete-region | |
739 (point) (progn (forward-line (car insn)) | |
740 (point)))) | |
741 (i (insert (propertize | |
742 (car insn) | |
743 :vc-rcs-r/d/a | |
744 (or prda (setq prda (r/d/a)))))))) | |
745 (prog1 (not (string= (if nbls (caar nbls) revision) pre)) | |
746 (setq pre (cdr (assq 'next meta))))))))) | |
747 ;; Lastly, for each line, insert at bol nicely-formatted history info. | |
748 ;; We do two passes to collect summary information used to minimize | |
749 ;; the annotation's usage of screen real-estate: (1) Consider rendered | |
750 ;; width of revision plus author together as a unit; and (2) Omit | |
751 ;; author entirely if all authors are the same as the user. | |
752 (let ((ht (make-hash-table :test 'eq)) | |
753 (me (user-login-name)) | |
754 (maxw 0) | |
755 (all-me t) | |
756 rda w a) | |
757 (goto-char (point-max)) | |
758 (while (not (bobp)) | |
759 (forward-line -1) | |
760 (setq rda (get-text-property (point) :vc-rcs-r/d/a)) | |
761 (unless (gethash rda ht) | |
762 (setq a (aref rda 2) | |
763 all-me (and all-me (string= a me))) | |
764 (puthash rda (setq w (+ (length (aref rda 0)) | |
765 (length a))) | |
766 ht) | |
767 (setq maxw (max w maxw)))) | |
768 (let ((padding (make-string maxw 32))) | |
769 (flet ((pad (w) (substring-no-properties padding w)) | |
770 (render (rda &rest ls) | |
771 (propertize | |
772 (apply 'concat | |
773 (format-time-string "%Y-%m-%d" (aref rda 1)) | |
774 " " | |
775 (aref rda 0) | |
776 ls) | |
777 :vc-annotate-prefix t | |
778 :vc-rcs-r/d/a rda))) | |
779 (maphash | |
780 (if all-me | |
781 (lambda (rda w) | |
782 (puthash rda (render rda (pad w) ": ") ht)) | |
783 (lambda (rda w) | |
784 (puthash rda (render rda " " (pad w) " " (aref rda 2) ": ") ht))) | |
785 ht))) | |
786 (while (not (eobp)) | |
787 (insert (gethash (get-text-property (point) :vc-rcs-r/d/a) ht)) | |
788 (forward-line 1)))) | |
789 | |
790 (declare-function vc-annotate-convert-time "vc-annotate" (time)) | |
791 | |
792 (defun vc-rcs-annotate-current-time () | |
793 "Return the current time, based at midnight of the current day, and | |
794 encoded as fractional days." | |
795 (vc-annotate-convert-time | |
796 (apply 'encode-time 0 0 0 (nthcdr 3 (decode-time (current-time)))))) | |
797 | |
798 (defun vc-rcs-annotate-time () | |
799 "Return the time of the next annotation (as fraction of days) | |
800 systime, or nil if there is none. Also, reposition point." | |
801 (unless (eobp) | |
802 (prog1 (vc-annotate-convert-time | |
803 (aref (get-text-property (point) :vc-rcs-r/d/a) 1)) | |
804 (goto-char (next-single-property-change (point) :vc-annotate-prefix))))) | |
805 | |
806 (defun vc-rcs-annotate-extract-revision-at-line () | |
807 (aref (get-text-property (point) :vc-rcs-r/d/a) 0)) | |
808 | |
809 | |
810 ;;; | |
811 ;;; Tag system | |
812 ;;; | |
813 | |
814 (defun vc-rcs-create-tag (backend dir name branchp) | |
815 (when branchp | |
816 (error "RCS backend %s does not support module branches" backend)) | |
817 (let ((result (vc-tag-precondition dir))) | |
818 (if (stringp result) | |
819 (error "File %s is not up-to-date" result) | |
820 (vc-file-tree-walk | |
821 dir | |
822 (lambda (f) | |
823 (vc-do-command "*vc*" 0 "rcs" (vc-name f) (concat "-n" name ":"))))))) | |
824 | |
825 | |
826 ;;; | |
827 ;;; Miscellaneous | |
828 ;;; | |
829 | |
830 (defun vc-rcs-trunk-p (rev) | |
831 "Return t if REV is a revision on the trunk." | |
832 (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev)))) | |
833 | |
834 (defun vc-rcs-minor-part (rev) | |
835 "Return the minor revision number of a revision number REV." | |
836 (string-match "[0-9]+\\'" rev) | |
837 (substring rev (match-beginning 0) (match-end 0))) | |
838 | |
839 (defun vc-rcs-previous-revision (file rev) | |
840 "Return the revision number immediately preceding REV for FILE, | |
841 or nil if there is no previous revision. This default | |
842 implementation works for MAJOR.MINOR-style revision numbers as | |
843 used by RCS and CVS." | |
844 (let ((branch (vc-branch-part rev)) | |
845 (minor-num (string-to-number (vc-rcs-minor-part rev)))) | |
846 (when branch | |
847 (if (> minor-num 1) | |
848 ;; revision does probably not start a branch or release | |
849 (concat branch "." (number-to-string (1- minor-num))) | |
850 (if (vc-rcs-trunk-p rev) | |
851 ;; we are at the beginning of the trunk -- | |
852 ;; don't know anything to return here | |
853 nil | |
854 ;; we are at the beginning of a branch -- | |
855 ;; return revision of starting point | |
856 (vc-branch-part branch)))))) | |
857 | |
858 (defun vc-rcs-next-revision (file rev) | |
859 "Return the revision number immediately following REV for FILE, | |
860 or nil if there is no next revision. This default implementation | |
861 works for MAJOR.MINOR-style revision numbers as used by RCS | |
862 and CVS." | |
863 (when (not (string= rev (vc-working-revision file))) | |
864 (let ((branch (vc-branch-part rev)) | |
865 (minor-num (string-to-number (vc-rcs-minor-part rev)))) | |
866 (concat branch "." (number-to-string (1+ minor-num)))))) | |
867 | |
868 (defun vc-rcs-update-changelog (files) | |
869 "Default implementation of update-changelog. | |
870 Uses `rcs2log' which only works for RCS and CVS." | |
871 ;; FIXME: We (c|sh)ould add support for cvs2cl | |
872 (let ((odefault default-directory) | |
873 (changelog (find-change-log)) | |
874 ;; Presumably not portable to non-Unixy systems, along with rcs2log: | |
875 (tempfile (make-temp-file | |
876 (expand-file-name "vc" | |
877 (or small-temporary-file-directory | |
878 temporary-file-directory)))) | |
879 (login-name (or user-login-name | |
880 (format "uid%d" (number-to-string (user-uid))))) | |
881 (full-name (or add-log-full-name | |
882 (user-full-name) | |
883 (user-login-name) | |
884 (format "uid%d" (number-to-string (user-uid))))) | |
885 (mailing-address (or add-log-mailing-address | |
886 user-mail-address))) | |
887 (find-file-other-window changelog) | |
888 (barf-if-buffer-read-only) | |
889 (vc-buffer-sync) | |
890 (undo-boundary) | |
891 (goto-char (point-min)) | |
892 (push-mark) | |
893 (message "Computing change log entries...") | |
894 (message "Computing change log entries... %s" | |
895 (unwind-protect | |
896 (progn | |
897 (setq default-directory odefault) | |
898 (if (eq 0 (apply 'call-process | |
899 (expand-file-name "rcs2log" | |
900 exec-directory) | |
901 nil (list t tempfile) nil | |
902 "-c" changelog | |
903 "-u" (concat login-name | |
904 "\t" full-name | |
905 "\t" mailing-address) | |
906 (mapcar | |
907 (lambda (f) | |
908 (file-relative-name | |
909 (expand-file-name f odefault))) | |
910 files))) | |
911 "done" | |
912 (pop-to-buffer (get-buffer-create "*vc*")) | |
913 (erase-buffer) | |
914 (insert-file-contents tempfile) | |
915 "failed")) | |
916 (setq default-directory (file-name-directory changelog)) | |
917 (delete-file tempfile))))) | |
918 | |
919 (defun vc-rcs-check-headers () | |
920 "Check if the current file has any headers in it." | |
921 (save-excursion | |
922 (goto-char (point-min)) | |
923 (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\ | |
924 \\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t))) | |
925 | |
926 (defun vc-rcs-clear-headers () | |
927 "Implementation of vc-clear-headers for RCS." | |
928 (let ((case-fold-search nil)) | |
929 (goto-char (point-min)) | |
930 (while (re-search-forward | |
931 (concat "\\$\\(Author\\|Date\\|Header\\|Id\\|Locker\\|Name\\|" | |
932 "RCSfile\\|Revision\\|Source\\|State\\): [^$\n]+\\$") | |
933 nil t) | |
934 (replace-match "$\\1$")))) | |
935 | |
936 (defun vc-rcs-rename-file (old new) | |
937 ;; Just move the master file (using vc-rcs-master-templates). | |
938 (vc-rename-master (vc-name old) new vc-rcs-master-templates)) | |
939 | |
940 (defun vc-rcs-find-file-hook () | |
941 ;; If the file is locked by some other user, make | |
942 ;; the buffer read-only. Like this, even root | |
943 ;; cannot modify a file that someone else has locked. | |
944 (and (stringp (vc-state buffer-file-name 'RCS)) | |
945 (setq buffer-read-only t))) | |
946 | |
947 | |
948 ;;; | |
949 ;;; Internal functions | |
950 ;;; | |
951 | |
952 (defun vc-rcs-workfile-is-newer (file) | |
953 "Return non-nil if FILE is newer than its RCS master. | |
954 This likely means that FILE has been changed with respect | |
955 to its master version." | |
956 (let ((file-time (nth 5 (file-attributes file))) | |
957 (master-time (nth 5 (file-attributes (vc-name file))))) | |
958 (or (> (nth 0 file-time) (nth 0 master-time)) | |
959 (and (= (nth 0 file-time) (nth 0 master-time)) | |
960 (> (nth 1 file-time) (nth 1 master-time)))))) | |
961 | |
962 (defun vc-rcs-find-most-recent-rev (branch) | |
963 "Find most recent revision on BRANCH." | |
964 (goto-char (point-min)) | |
965 (let ((latest-rev -1) value) | |
966 (while (re-search-forward (concat "^\\(" (regexp-quote branch) | |
967 "\\.\\([0-9]+\\)\\)\ndate[ \t]+[0-9.]+;") | |
968 nil t) | |
969 (let ((rev (string-to-number (match-string 2)))) | |
970 (when (< latest-rev rev) | |
971 (setq latest-rev rev) | |
972 (setq value (match-string 1))))) | |
973 (or value | |
974 (vc-branch-part branch)))) | |
975 | |
976 (defun vc-rcs-fetch-master-state (file &optional working-revision) | |
977 "Compute the master file's idea of the state of FILE. | |
978 If a WORKING-REVISION is given, compute the state of that version, | |
979 otherwise determine the workfile version based on the master file. | |
980 This function sets the properties `vc-working-revision' and | |
981 `vc-checkout-model' to their correct values, based on the master | |
982 file." | |
983 (with-temp-buffer | |
984 (if (or (not (vc-insert-file (vc-name file) "^[0-9]")) | |
985 (progn (goto-char (point-min)) | |
986 (not (looking-at "^head[ \t\n]+[^;]+;$")))) | |
987 (error "File %s is not an RCS master file" (vc-name file))) | |
988 (let ((workfile-is-latest nil) | |
989 (default-branch (vc-parse-buffer "^branch[ \t\n]+\\([^;]*\\);" 1))) | |
990 (vc-file-setprop file 'vc-rcs-default-branch default-branch) | |
991 (unless working-revision | |
992 ;; Workfile version not known yet. Determine that first. It | |
993 ;; is either the head of the trunk, the head of the default | |
994 ;; branch, or the "default branch" itself, if that is a full | |
995 ;; revision number. | |
996 (cond | |
997 ;; no default branch | |
998 ((or (not default-branch) (string= "" default-branch)) | |
999 (setq working-revision | |
1000 (vc-parse-buffer "^head[ \t\n]+\\([^;]+\\);" 1)) | |
1001 (setq workfile-is-latest t)) | |
1002 ;; default branch is actually a revision | |
1003 ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$" | |
1004 default-branch) | |
1005 (setq working-revision default-branch)) | |
1006 ;; else, search for the head of the default branch | |
1007 (t (vc-insert-file (vc-name file) "^desc") | |
1008 (setq working-revision | |
1009 (vc-rcs-find-most-recent-rev default-branch)) | |
1010 (setq workfile-is-latest t))) | |
1011 (vc-file-setprop file 'vc-working-revision working-revision)) | |
1012 ;; Check strict locking | |
1013 (goto-char (point-min)) | |
1014 (vc-file-setprop file 'vc-checkout-model | |
1015 (if (re-search-forward ";[ \t\n]*strict;" nil t) | |
1016 'locking 'implicit)) | |
1017 ;; Compute state of workfile version | |
1018 (goto-char (point-min)) | |
1019 (let ((locking-user | |
1020 (vc-parse-buffer (concat "^locks[ \t\n]+[^;]*[ \t\n]+\\([^:]+\\):" | |
1021 (regexp-quote working-revision) | |
1022 "[^0-9.]") | |
1023 1))) | |
1024 (cond | |
1025 ;; not locked | |
1026 ((not locking-user) | |
1027 (if (or workfile-is-latest | |
1028 (vc-rcs-latest-on-branch-p file working-revision)) | |
1029 ;; workfile version is latest on branch | |
1030 'up-to-date | |
1031 ;; workfile version is not latest on branch | |
1032 'needs-update)) | |
1033 ;; locked by the calling user | |
1034 ((and (stringp locking-user) | |
1035 (string= locking-user (vc-user-login-name file))) | |
1036 ;; Don't call `vc-rcs-checkout-model' to avoid inf-looping. | |
1037 (if (or (eq (vc-file-getprop file 'vc-checkout-model) 'locking) | |
1038 workfile-is-latest | |
1039 (vc-rcs-latest-on-branch-p file working-revision)) | |
1040 'edited | |
1041 ;; Locking is not used for the file, but the owner does | |
1042 ;; have a lock, and there is a higher version on the current | |
1043 ;; branch. Not sure if this can occur, and if it is right | |
1044 ;; to use `needs-merge' in this case. | |
1045 'needs-merge)) | |
1046 ;; locked by somebody else | |
1047 ((stringp locking-user) | |
1048 locking-user) | |
1049 (t | |
1050 (error "Error getting state of RCS file"))))))) | |
1051 | |
1052 (defun vc-rcs-consult-headers (file) | |
1053 "Search for RCS headers in FILE, and set properties accordingly. | |
1054 | |
1055 Returns: nil if no headers were found | |
1056 'rev if a workfile revision was found | |
1057 'rev-and-lock if revision and lock info was found" | |
1058 (cond | |
1059 ((not (get-file-buffer file)) nil) | |
1060 ((let (status version locking-user) | |
1061 (with-current-buffer (get-file-buffer file) | |
1062 (save-excursion | |
1063 (goto-char (point-min)) | |
1064 (cond | |
1065 ;; search for $Id or $Header | |
1066 ;; ------------------------- | |
1067 ;; The `\ 's below avoid an RCS 5.7 bug when checking in this file. | |
1068 ((or (and (search-forward "$Id\ : " nil t) | |
1069 (looking-at "[^ ]+ \\([0-9.]+\\) ")) | |
1070 (and (progn (goto-char (point-min)) | |
1071 (search-forward "$Header\ : " nil t)) | |
1072 (looking-at "[^ ]+ \\([0-9.]+\\) "))) | |
1073 (goto-char (match-end 0)) | |
1074 ;; if found, store the revision number ... | |
1075 (setq version (match-string-no-properties 1)) | |
1076 ;; ... and check for the locking state | |
1077 (cond | |
1078 ((looking-at | |
1079 (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date | |
1080 "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time | |
1081 "[^ ]+ [^ ]+ ")) ; author & state | |
1082 (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds | |
1083 (cond | |
1084 ;; unlocked revision | |
1085 ((looking-at "\\$") | |
1086 (setq locking-user 'none) | |
1087 (setq status 'rev-and-lock)) | |
1088 ;; revision is locked by some user | |
1089 ((looking-at "\\([^ ]+\\) \\$") | |
1090 (setq locking-user (match-string-no-properties 1)) | |
1091 (setq status 'rev-and-lock)) | |
1092 ;; everything else: false | |
1093 (nil))) | |
1094 ;; unexpected information in | |
1095 ;; keyword string --> quit | |
1096 (nil))) | |
1097 ;; search for $Revision | |
1098 ;; -------------------- | |
1099 ((re-search-forward (concat "\\$" | |
1100 "Revision: \\([0-9.]+\\) \\$") | |
1101 nil t) | |
1102 ;; if found, store the revision number ... | |
1103 (setq version (match-string-no-properties 1)) | |
1104 ;; and see if there's any lock information | |
1105 (goto-char (point-min)) | |
1106 (if (re-search-forward (concat "\\$" "Locker:") nil t) | |
1107 (cond ((looking-at " \\([^ ]+\\) \\$") | |
1108 (setq locking-user (match-string-no-properties 1)) | |
1109 (setq status 'rev-and-lock)) | |
1110 ((looking-at " *\\$") | |
1111 (setq locking-user 'none) | |
1112 (setq status 'rev-and-lock)) | |
1113 (t | |
1114 (setq locking-user 'none) | |
1115 (setq status 'rev-and-lock))) | |
1116 (setq status 'rev))) | |
1117 ;; else: nothing found | |
1118 ;; ------------------- | |
1119 (t nil)))) | |
1120 (if status (vc-file-setprop file 'vc-working-revision version)) | |
1121 (and (eq status 'rev-and-lock) | |
1122 (vc-file-setprop file 'vc-state | |
1123 (cond | |
1124 ((eq locking-user 'none) 'up-to-date) | |
1125 ((string= locking-user (vc-user-login-name file)) | |
1126 'edited) | |
1127 (t locking-user))) | |
1128 ;; If the file has headers, we don't want to query the | |
1129 ;; master file, because that would eliminate all the | |
1130 ;; performance gain the headers brought us. We therefore | |
1131 ;; use a heuristic now to find out whether locking is used | |
1132 ;; for this file. If we trust the file permissions, and the | |
1133 ;; file is not locked, then if the file is read-only we | |
1134 ;; assume that locking is used for the file, otherwise | |
1135 ;; locking is not used. | |
1136 (not (vc-mistrust-permissions file)) | |
1137 (vc-up-to-date-p file) | |
1138 (if (string-match ".r-..-..-." (nth 8 (file-attributes file))) | |
1139 (vc-file-setprop file 'vc-checkout-model 'locking) | |
1140 (vc-file-setprop file 'vc-checkout-model 'implicit))) | |
1141 status)))) | |
1142 | |
1143 (defun vc-release-greater-or-equal (r1 r2) | |
1144 "Compare release numbers, represented as strings. | |
1145 Release components are assumed cardinal numbers, not decimal fractions | |
1146 \(5.10 is a higher release than 5.9\). Omitted fields are considered | |
1147 lower \(5.6.7 is earlier than 5.6.7.1\). Comparison runs till the end | |
1148 of the string is found, or a non-numeric component shows up \(5.6.7 is | |
1149 earlier than \"5.6.7 beta\", which is probably not what you want in | |
1150 some cases\). This code is suitable for existing RCS release numbers. | |
1151 CVS releases are handled reasonably, too \(1.3 < 1.4* < 1.5\)." | |
1152 (let (v1 v2 i1 i2) | |
1153 (catch 'done | |
1154 (or (and (string-match "^\\.?\\([0-9]+\\)" r1) | |
1155 (setq i1 (match-end 0)) | |
1156 (setq v1 (string-to-number (match-string 1 r1))) | |
1157 (or (and (string-match "^\\.?\\([0-9]+\\)" r2) | |
1158 (setq i2 (match-end 0)) | |
1159 (setq v2 (string-to-number (match-string 1 r2))) | |
1160 (if (> v1 v2) (throw 'done t) | |
1161 (if (< v1 v2) (throw 'done nil) | |
1162 (throw 'done | |
1163 (vc-release-greater-or-equal | |
1164 (substring r1 i1) | |
1165 (substring r2 i2))))))) | |
1166 (throw 'done t))) | |
1167 (or (and (string-match "^\\.?\\([0-9]+\\)" r2) | |
1168 (throw 'done nil)) | |
1169 (throw 'done t))))) | |
1170 | |
1171 (defun vc-rcs-release-p (release) | |
1172 "Return t if we have RELEASE or better." | |
1173 (let ((installation (vc-rcs-system-release))) | |
1174 (if (and installation | |
1175 (not (eq installation 'unknown))) | |
1176 (vc-release-greater-or-equal installation release)))) | |
1177 | |
1178 (defun vc-rcs-system-release () | |
1179 "Return the RCS release installed on this system, as a string. | |
1180 Return symbol `unknown' if the release cannot be deducted. The user can | |
1181 override this using variable `vc-rcs-release'. | |
1182 | |
1183 If the user has not set variable `vc-rcs-release' and it is nil, | |
1184 variable `vc-rcs-release' is set to the returned value." | |
1185 (or vc-rcs-release | |
1186 (setq vc-rcs-release | |
1187 (or (and (zerop (vc-do-command "*vc*" nil "rcs" nil "-V")) | |
1188 (with-current-buffer (get-buffer "*vc*") | |
1189 (vc-parse-buffer "^RCS version \\([0-9.]+ *.*\\)" 1))) | |
1190 'unknown)))) | |
1191 | |
1192 (defun vc-rcs-set-non-strict-locking (file) | |
1193 (vc-do-command "*vc*" 0 "rcs" file "-U") | |
1194 (vc-file-setprop file 'vc-checkout-model 'implicit) | |
1195 (set-file-modes file (logior (file-modes file) 128))) | |
1196 | |
1197 (defun vc-rcs-set-default-branch (file branch) | |
1198 (vc-do-command "*vc*" 0 "rcs" (vc-name file) (concat "-b" branch)) | |
1199 (vc-file-setprop file 'vc-rcs-default-branch branch)) | |
1200 | |
1201 (defun vc-rcs-parse (&optional buffer) | |
1202 "Parse current buffer, presumed to be in RCS-style masterfile format. | |
1203 Optional arg BUFFER specifies another buffer to parse. Return an alist | |
1204 of two elements, w/ keys `headers' and `revisions' and values in turn | |
1205 sub-alists. For `headers', the values unless otherwise specified are | |
1206 strings and the keys are: | |
1207 | |
1208 desc -- description | |
1209 head -- latest revision | |
1210 branch -- the branch the \"head revision\" lies on; | |
1211 absent if the head revision lies on the trunk | |
1212 access -- ??? | |
1213 symbols -- sub-alist of (SYMBOL . REVISION) elements | |
1214 locks -- if file is checked out, something like \"ttn:1.7\" | |
1215 strict -- t if \"strict locking\" is in effect, otherwise nil | |
1216 comment -- may be absent; typically something like \"# \" or \"; \" | |
1217 expand -- may be absent; ??? | |
1218 | |
1219 For `revisions', the car is REVISION (string), the cdr a sub-alist, | |
1220 with string values (unless otherwise specified) and keys: | |
1221 | |
1222 date -- a time value (like that returned by `encode-time'); as a | |
1223 special case, a year value less than 100 is augmented by 1900 | |
1224 author -- username | |
1225 state -- typically \"Exp\" or \"Rel\" | |
1226 branches -- list of revisions that begin branches from this revision | |
1227 next -- on the trunk: the chronologically-preceding revision, or \"\"; | |
1228 on a branch: the chronologically-following revision, or \"\" | |
1229 log -- change log entry | |
1230 text -- for the head revision on the trunk, the body of the file; | |
1231 other revisions have `:insn' instead | |
1232 :insn -- for non-head revisions, a list of parsed instructions | |
1233 in one of two forms, in both cases START meaning \"first | |
1234 go to line START\": | |
1235 - `(START k COUNT)' -- kill COUNT lines | |
1236 - `(START i TEXT)' -- insert TEXT (a string) | |
1237 The list is in descending order by START. | |
1238 | |
1239 The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." | |
1240 (setq buffer (get-buffer (or buffer (current-buffer)))) | |
1241 (set-buffer buffer) | |
1242 ;; An RCS masterfile can be viewed as containing four regular (for the | |
1243 ;; most part) sections: (a) the "headers", (b) the "rev headers", (c) | |
1244 ;; the "description" and (d) the "rev bodies", in that order. In the | |
1245 ;; returned alist (see docstring), elements from (b) and (d) are | |
1246 ;; combined pairwise to form the "revisions", while those from (a) and | |
1247 ;; (c) are simply combined to form the "headers". | |
1248 ;; | |
1249 ;; Loosely speaking, each section contains a series of alternating | |
1250 ;; "tags" and "printed representations". In the (b) and (d), many | |
1251 ;; such series can appear, and a revision number on a line by itself | |
1252 ;; precedes the series of tags and printed representations associated | |
1253 ;; with it. | |
1254 ;; | |
1255 ;; In (a) and (b), the printed representations (with the exception of | |
1256 ;; the `comment' tag in the headers) terminate with a semicolon, which | |
1257 ;; is NOT part of the "value" finally associated with the tag. All | |
1258 ;; other printed representations are in "@@-format"; there is an "@", | |
1259 ;; the middle part (to be translated into the value), another "@" and | |
1260 ;; a newline. Each "@@" in the middle part indicates the position of | |
1261 ;; a single "@" (and consequently the requirement of an additional | |
1262 ;; initial step when translating to the value). | |
1263 ;; | |
1264 ;; Parser state includes vars that collect parts of the return value... | |
1265 (let ((desc nil) (headers nil) (revs nil) | |
1266 ;; ... as well as vars that support a single-pass, tag-assisted, | |
1267 ;; minimal-data-copying scan. Basically -- skirting around the | |
1268 ;; grouping by revision required in (b) and (d) -- we repeatedly | |
1269 ;; and context-sensitively read a tag (that MUST be present), | |
1270 ;; determine the bounds of the printed representation, translate | |
1271 ;; it into a value, and push the tag plus value onto one of the | |
1272 ;; collection vars. Finally, we return the parse tree | |
1273 ;; incorporating the values of the collection vars (see "rv"). | |
1274 ;; | |
1275 ;; A symbol or string to keep track of context (for error messages). | |
1276 context | |
1277 ;; A symbol, the current tag. | |
1278 tok | |
1279 ;; Region (begin and end buffer positions) of the printed | |
1280 ;; representation for the current tag. | |
1281 b e | |
1282 ;; A list of buffer positions where "@@" can be found within the | |
1283 ;; printed representation region. For each location, we push two | |
1284 ;; elements onto the list, 1+ and 2+ the location, respectively, | |
1285 ;; with the 2+ appearing at the head. In this way, the expression | |
1286 ;; `(,e ,@@-holes ,b) | |
1287 ;; describes regions that can be concatenated (in reverse order) | |
1288 ;; to "de-@@-format" the printed representation as the first step | |
1289 ;; to translating it into some value. See internal func `gather'. | |
1290 @-holes) | |
1291 (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' | |
1292 (at (tag) (save-excursion (eq tag (read buffer)))) | |
1293 (to-eol () (buffer-substring-no-properties | |
1294 (point) (progn (forward-line 1) | |
1295 (1- (point))))) | |
1296 (to-semi () (setq b (point) | |
1297 e (progn (search-forward ";") | |
1298 (1- (point))))) | |
1299 (to-one@ () (setq @-holes nil | |
1300 b (progn (search-forward "@") (point)) | |
1301 e (progn (while (and (search-forward "@") | |
1302 (= ?@ (char-after)) | |
1303 (progn | |
1304 (push (point) @-holes) | |
1305 (forward-char 1) | |
1306 (push (point) @-holes)))) | |
1307 (1- (point))))) | |
1308 (tok+val (set-b+e name &optional proc) | |
1309 (unless (eq name (setq tok (read buffer))) | |
1310 (error "Missing `%s' while parsing %s" name context)) | |
1311 (sw) | |
1312 (funcall set-b+e) | |
1313 (cons tok (if proc | |
1314 (funcall proc) | |
1315 (buffer-substring-no-properties b e)))) | |
1316 (k-semi (name &optional proc) (tok+val 'to-semi name proc)) | |
1317 (gather () (let ((pairs `(,e ,@@-holes ,b)) | |
1318 acc) | |
1319 (while pairs | |
1320 (push (buffer-substring-no-properties | |
1321 (cadr pairs) (car pairs)) | |
1322 acc) | |
1323 (setq pairs (cddr pairs))) | |
1324 (apply 'concat acc))) | |
1325 (k-one@ (name &optional later) (tok+val 'to-one@ name | |
1326 (if later | |
1327 (lambda () t) | |
1328 'gather)))) | |
1329 (save-excursion | |
1330 (goto-char (point-min)) | |
1331 ;; headers | |
1332 (setq context 'headers) | |
1333 (flet ((hpush (name &optional proc) | |
1334 (push (k-semi name proc) headers))) | |
1335 (hpush 'head) | |
1336 (when (at 'branch) | |
1337 (hpush 'branch)) | |
1338 (hpush 'access) | |
1339 (hpush 'symbols | |
1340 (lambda () | |
1341 (mapcar (lambda (together) | |
1342 (let ((two (split-string together ":"))) | |
1343 (setcar two (intern (car two))) | |
1344 (setcdr two (cadr two)) | |
1345 two)) | |
1346 (split-string | |
1347 (buffer-substring-no-properties b e))))) | |
1348 (hpush 'locks)) | |
1349 (push `(strict . ,(when (at 'strict) | |
1350 (search-forward ";") | |
1351 t)) | |
1352 headers) | |
1353 (when (at 'comment) | |
1354 (push (k-one@ 'comment) headers) | |
1355 (search-forward ";")) | |
1356 (when (at 'expand) | |
1357 (push (k-one@ 'expand) headers) | |
1358 (search-forward ";")) | |
1359 (setq headers (nreverse headers)) | |
1360 ;; rev headers | |
1361 (sw) (setq context 'rev-headers) | |
1362 (while (looking-at "[0-9]") | |
1363 (push `(,(to-eol) | |
1364 ,(k-semi 'date | |
1365 (lambda () | |
1366 (let ((ls (mapcar 'string-to-number | |
1367 (split-string | |
1368 (buffer-substring-no-properties | |
1369 b e) | |
1370 "\\.")))) | |
1371 ;; Hack the year -- verified to be the | |
1372 ;; same algorithm used in RCS 5.7. | |
1373 (when (< (car ls) 100) | |
1374 (setcar ls (+ 1900 (car ls)))) | |
1375 (apply 'encode-time (nreverse ls))))) | |
1376 ,@(mapcar 'k-semi '(author state)) | |
1377 ,(k-semi 'branches | |
1378 (lambda () | |
1379 (split-string | |
1380 (buffer-substring-no-properties b e)))) | |
1381 ,(k-semi 'next)) | |
1382 revs) | |
1383 (sw)) | |
1384 (setq revs (nreverse revs)) | |
1385 ;; desc | |
1386 (sw) (setq context 'desc | |
1387 desc (k-one@ 'desc)) | |
1388 ;; rev bodies | |
1389 (let (acc | |
1390 ;; Element of `revs' that initially holds only header info. | |
1391 ;; "Pairwise combination" occurs when we add body info. | |
1392 rev | |
1393 ;; Components of the editing commands (aside from the actual | |
1394 ;; text) that comprise the `text' printed representations | |
1395 ;; (not including the "head" revision). | |
1396 cmd start act | |
1397 ;; Ascending (reversed) `@-holes' which the internal func | |
1398 ;; `incg' pops to effect incremental gathering. | |
1399 asc | |
1400 ;; Function to extract text (for the `a' command), either | |
1401 ;; `incg' or `buffer-substring-no-properties'. (This is | |
1402 ;; for speed; strictly speaking, it is sufficient to use | |
1403 ;; only the former since it behaves identically to the | |
1404 ;; latter in the absense of "@@".) | |
1405 sub) | |
1406 (flet ((incg (beg end) (let ((b beg) (e end) @-holes) | |
1407 (while (and asc (< (car asc) e)) | |
1408 (push (pop asc) @-holes)) | |
1409 ;; Self-deprecate when work is done. | |
1410 ;; Folding many dimensions into one. | |
1411 ;; Thanks B.Mandelbrot, for complex sum. | |
1412 ;; O beauteous math! --the Unvexed Bum | |
1413 (unless asc | |
1414 (setq sub 'buffer-substring-no-properties)) | |
1415 (gather)))) | |
1416 (while (and (sw) | |
1417 (not (eobp)) | |
1418 (setq context (to-eol) | |
1419 rev (or (assoc context revs) | |
1420 (error "Rev `%s' has body but no head" | |
1421 context)))) | |
1422 (push (k-one@ 'log) (cdr rev)) | |
1423 ;; For rev body `text' tags, delay translation slightly... | |
1424 (push (k-one@ 'text t) (cdr rev)) | |
1425 ;; ... until we decide which tag and value is appropriate to | |
1426 ;; collect. For the "head" revision, compute the value of the | |
1427 ;; `text' printed representation by simple `gather'. For all | |
1428 ;; other revisions, replace the `text' tag+value with `:insn' | |
1429 ;; plus value, always scanning in-place. | |
1430 (if (string= context (cdr (assq 'head headers))) | |
1431 (setcdr (cadr rev) (gather)) | |
1432 (if @-holes | |
1433 (setq asc (nreverse @-holes) | |
1434 sub 'incg) | |
1435 (setq sub 'buffer-substring-no-properties)) | |
1436 (goto-char b) | |
1437 (setq acc nil) | |
1438 (while (< (point) e) | |
1439 (forward-char 1) | |
1440 (setq cmd (char-before) | |
1441 start (read (current-buffer)) | |
1442 act (read (current-buffer))) | |
1443 (forward-char 1) | |
1444 (push (case cmd | |
1445 (?d | |
1446 ;; `d' means "delete lines". | |
1447 ;; For Emacs spirit, we use `k' for "kill". | |
1448 `(,start k ,act)) | |
1449 (?a | |
1450 ;; `a' means "append after this line" but | |
1451 ;; internally we normalize it so that START | |
1452 ;; specifies the actual line for insert, thus | |
1453 ;; requiring less hair in the realization algs. | |
1454 ;; For Emacs spirit, we use `i' for "insert". | |
1455 `(,(1+ start) i | |
1456 ,(funcall sub (point) (progn (forward-line act) | |
1457 (point))))) | |
1458 (t (error "Bad command `%c' in `text' for rev `%s'" | |
1459 cmd context))) | |
1460 acc)) | |
1461 (goto-char (1+ e)) | |
1462 (setcar (cdr rev) (cons :insn acc))))))) | |
1463 ;; rv | |
1464 `((headers ,desc ,@headers) | |
1465 (revisions ,@revs))))) | |
1466 | |
1467 (provide 'vc-rcs) | |
1468 | |
1469 ;; arch-tag: 759b4916-5b0d-431d-b647-b185b8c652cf | |
1470 ;;; vc-rcs.el ends here |