comparison lisp/packages/vc.el @ 151:59463afc5666 r20-3b2

Import from CVS: tag r20-3b2
author cvs
date Mon, 13 Aug 2007 09:37:19 +0200
parents 318232e2a3f0
children 25f70ba0133c
comparison
equal deleted inserted replaced
150:8ebb1c0f0f6f 151:59463afc5666
1 ;;; vc.el --- drive a version-control system from within Emacs 1 ;;; vc.el --- drive a version-control system from within Emacs
2 2
3 ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. 3 ;; Copyright (C) 1992, 93, 94, 95, 96 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems and INS Engineering Corp. 4
5 5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
6 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> 6 ;; Maintainer: Andre Spiegel <spiegel@inf.fu-berlin.de>
7 ;; Maintainer: ttn@netcom.com 7 ;; XEmacs conversion: Steve Baur <steve@altair.xemacs.org>
8 ;; Version: 5.6 8
9 9 ;; This file is part of GNU Emacs.
10 ;; This file is part of XEmacs. 10
11 11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; XEmacs is free software; you can redistribute it and/or modify it 12 ;; it under the terms of the GNU General Public License as published by
13 ;; under the terms of the GNU General Public License as published by
14 ;; the Free Software Foundation; either version 2, or (at your option) 13 ;; the Free Software Foundation; either version 2, or (at your option)
15 ;; any later version. 14 ;; any later version.
16 15
17 ;; XEmacs is distributed in the hope that it will be useful, but 16 ;; GNU Emacs is distributed in the hope that it will be useful,
18 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;; General Public License for more details. 19 ;; GNU General Public License for more details.
21 20
22 ;; You should have received a copy of the GNU General Public License 21 ;; You should have received a copy of the GNU General Public License
23 ;; along with XEmacs; see the file COPYING. If not, write to the 22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
25 ;; Boston, MA 02111-1307, USA. 24 ;; Boston, MA 02111-1307, USA.
26
27 ;;; Synched up with: It's not clear at this point.
28 ;;; mly synched this with FSF at version 5.4. Stig did a whole lot
29 ;;; of stuff to it since then, and so has the FSF.
30 25
31 ;;; Commentary: 26 ;;; Commentary:
32 27
33 ;; This mode is fully documented in the Emacs user's manual. 28 ;; This mode is fully documented in the Emacs user's manual.
34 ;; 29 ;;
35 ;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>. 30 ;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>.
36 ;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>, 31 ;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>,
37 ;; and Richard Stallman contributed valuable criticism, support, and testing. 32 ;; and Richard Stallman contributed valuable criticism, support, and testing.
38 ;; CVS support was added by Per Cederqvist <ceder@lysator.liu.se> 33 ;; CVS support was added by Per Cederqvist <ceder@lysator.liu.se>
39 ;; in Jan-Feb 1994. 34 ;; in Jan-Feb 1994. Further enhancements came from ttn.netcom.com and
40 ;; 35 ;; Andre Spiegel <spiegel@inf.fu-berlin.de>.
41 ;; XEmacs fixes, CVS fixes, and general improvements
42 ;; by Jonathan Stigelman <Stig@hackvan.com>
43 ;; 36 ;;
44 ;; Supported version-control systems presently include SCCS, RCS, and CVS. 37 ;; Supported version-control systems presently include SCCS, RCS, and CVS.
45 ;; The RCS lock-stealing code doesn't work right unless you use RCS 5.6.2 38 ;;
46 ;; or newer. Currently (January 1994) that is only a beta test release. 39 ;; Some features will not work with old RCS versions. Where
40 ;; appropriate, VC finds out which version you have, and allows or
41 ;; disallows those features (stealing locks, for example, works only
42 ;; from 5.6.2 onwards).
47 ;; Even initial checkins will fail if your RCS version is so old that ci 43 ;; Even initial checkins will fail if your RCS version is so old that ci
48 ;; doesn't understand -t-; this has been known to happen to people running 44 ;; doesn't understand -t-; this has been known to happen to people running
49 ;; NExTSTEP 3.0. 45 ;; NExTSTEP 3.0.
50 ;; 46 ;;
51 ;; The RCS code assumes strict locking. You can support the RCS -x option 47 ;; You can support the RCS -x option by adding pairs to the
52 ;; by adding pairs to the vc-master-templates list. 48 ;; vc-master-templates list.
53 ;; 49 ;;
54 ;; Proper function of the SCCS diff commands requires the shellscript vcdiff 50 ;; Proper function of the SCCS diff commands requires the shellscript vcdiff
55 ;; to be installed somewhere on Emacs's path for executables. 51 ;; to be installed somewhere on Emacs's path for executables.
56 ;; 52 ;;
57 ;; If your site uses the ChangeLog convention supported by Emacs, the 53 ;; If your site uses the ChangeLog convention supported by Emacs, the
73 69
74 ;;; Code: 70 ;;; Code:
75 71
76 (require 'vc-hooks) 72 (require 'vc-hooks)
77 (require 'ring) 73 (require 'ring)
78 (eval-when-compile (require 'dired)) ; for dired-map-over-marks macro 74 (eval-when-compile (require 'dired)) ; for dired-map-over-marks macro
79 75
80 (if (not (assoc 'vc-parent-buffer minor-mode-alist)) 76 (if (not (assoc 'vc-parent-buffer minor-mode-alist))
81 (setq minor-mode-alist 77 (setq minor-mode-alist
82 (cons '(vc-parent-buffer vc-parent-buffer-name) 78 (cons '(vc-parent-buffer vc-parent-buffer-name)
83 minor-mode-alist))) 79 minor-mode-alist)))
84 80
81 ;; To implement support for a new version-control system, add another
82 ;; branch to the vc-backend-dispatch macro and fill it in in each
83 ;; call. The variable vc-master-templates in vc-hooks.el will also
84 ;; have to change.
85
86 (defmacro vc-backend-dispatch (f s r c)
87 "Execute FORM1, FORM2 or FORM3 for SCCS, RCS or CVS respectively.
88 If FORM3 is `RCS', use FORM2 for CVS as well as RCS.
89 \(CVS shares some code with RCS)."
90 (list 'let (list (list 'type (list 'vc-backend f)))
91 (list 'cond
92 (list (list 'eq 'type (quote 'SCCS)) s) ;; SCCS
93 (list (list 'eq 'type (quote 'RCS)) r) ;; RCS
94 (list (list 'eq 'type (quote 'CVS)) ;; CVS
95 (if (eq c 'RCS) r c))
96 )))
97
85 ;; General customization 98 ;; General customization
86 99
87 (defvar vc-default-back-end nil
88 "*Back-end actually used by this interface; may be SCCS or RCS.
89 The value is only computed when needed to avoid an expensive search.")
90 (defvar vc-suppress-confirm nil 100 (defvar vc-suppress-confirm nil
91 "*If non-nil, treat user as expert; suppress yes-no prompts on some things.") 101 "*If non-nil, treat user as expert; suppress yes-no prompts on some things.")
92 (defvar vc-keep-workfiles t
93 "*If non-nil, don't delete working files after registering changes.
94 If the back-end is CVS, workfiles are always kept, regardless of the
95 value of this flag.")
96 (defvar vc-initial-comment nil 102 (defvar vc-initial-comment nil
97 "*Prompt for initial comment when a file is registered.") 103 "*If non-nil, prompt for initial comment when a file is registered.")
98 (defvar vc-command-messages nil 104 (defvar vc-command-messages nil
99 "*Display run messages from back-end commands.") 105 "*If non-nil, display run messages from back-end commands.")
100 (defvar vc-mistrust-permissions 'file-symlink-p 106 (defvar vc-register-switches nil
101 "*Don't assume that permissions and ownership track version-control status.") 107 "*A string or list of strings specifying extra switches passed
108 to the register program by \\[vc-register].")
102 (defvar vc-checkin-switches nil 109 (defvar vc-checkin-switches nil
103 "*Extra switches passed to the checkin program by \\[vc-checkin].") 110 "*A string or list of strings specifying extra switches passed
111 to the checkin program by \\[vc-checkin].")
104 (defvar vc-checkout-switches nil 112 (defvar vc-checkout-switches nil
105 "*Extra switches passed to the checkout program by \\[vc-checkout].") 113 "*A string or list of strings specifying extra switches passed
106 (defvar vc-path 114 to the checkout program by \\[vc-checkout].")
107 (if (file-exists-p "/usr/sccs") 115 (defvar vc-directory-exclusion-list '("SCCS" "RCS" "CVS")
108 '("/usr/sccs") nil) 116 "*A list of directory names ignored by functions that recursively
109 "*List of extra directories to search for version control commands.") 117 walk file trees.")
110 (defvar vc-directory-exclusion-list '("SCCS" "RCS")
111 "*Directory names ignored by functions that recursively walk file trees.")
112 118
113 (defconst vc-maximum-comment-ring-size 32 119 (defconst vc-maximum-comment-ring-size 32
114 "Maximum number of saved comments in the comment ring.") 120 "Maximum number of saved comments in the comment ring.")
115 121
116 ;;; XEmacs - This is dumped into loaddefs.el already. 122 ;;; This is duplicated in diff.el.
117 ;(defvar diff-switches "-c" 123 ;;; XEmacs: remove
118 ; "*A string or list of strings specifying switches to be passed to diff.") 124 ;;(defvar diff-switches "-c"
125 ;; "*A string or list of strings specifying switches to be be passed to diff.")
126
127 ;;;###autoload
128 (defvar vc-before-checkin-hook nil
129 "*Normal hook (list of functions) run before a file gets checked in.
130 See `run-hooks'.")
119 131
120 ;;;###autoload 132 ;;;###autoload
121 (defvar vc-checkin-hook nil 133 (defvar vc-checkin-hook nil
122 "*List of functions called after a checkin is done. See `run-hooks'.") 134 "*Normal hook (List of functions) run after a checkin is done.
123 135 See `run-hooks'.")
124 ;;;###autoload
125 (defvar vc-before-checkin-hook nil
126 "*List of functions called before a checkin is done. See `run-hooks'.")
127
128 (defvar vc-make-buffer-writable-hook nil
129 "*List of functions called when a buffer is made writable. See `run-hooks.'
130 This hook is only used when the version control system is CVS. It
131 might be useful for sites who uses locking with CVS, or who uses link
132 farms to gold trees.")
133 136
134 ;; Header-insertion hair 137 ;; Header-insertion hair
135 138
136 (defvar vc-header-alist 139 (defvar vc-header-alist
137 '((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$")) 140 '((SCCS "\%W\%") (RCS "\$Id\$") (CVS "\$Id\$"))
138 "*Header keywords to be inserted when `vc-insert-headers' is executed.") 141 "*Header keywords to be inserted by `vc-insert-headers'.
142 Must be a list of two-element lists, the first element of each must
143 be `RCS', `CVS', or `SCCS'. The second element is the string to
144 be inserted for this particular backend.")
139 (defvar vc-static-header-alist 145 (defvar vc-static-header-alist
140 '(("\\.c$" . 146 '(("\\.c$" .
141 "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n")) 147 "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
142 "*Associate static header string templates with file types. A \%s in the 148 "*Associate static header string templates with file types. A \%s in the
143 template is replaced with the first string associated with the file's 149 template is replaced with the first string associated with the file's
149 Add an entry in this list if you need to override the normal comment-start 155 Add an entry in this list if you need to override the normal comment-start
150 and comment-end variables. This will only be necessary if the mode language 156 and comment-end variables. This will only be necessary if the mode language
151 is sensitive to blank lines.") 157 is sensitive to blank lines.")
152 158
153 ;; Default is to be extra careful for super-user. 159 ;; Default is to be extra careful for super-user.
154 (defvar vc-checkout-carefully (= (user-uid) 0) ; #### - this prevents preloading! 160 (defvar vc-checkout-carefully (= (user-uid) 0)
155 "*Non-nil means be extra-careful in checkout. 161 "*Non-nil means be extra-careful in checkout.
156 Verify that the file really is not locked 162 Verify that the file really is not locked
157 and that its contents match what the master file says.") 163 and that its contents match what the master file says.")
164
165 (defvar vc-rcs-release nil
166 "*The release number of your RCS installation, as a string.
167 If nil, VC itself computes this value when it is first needed.")
168
169 (defvar vc-sccs-release nil
170 "*The release number of your SCCS installation, as a string.
171 If nil, VC itself computes this value when it is first needed.")
172
173 (defvar vc-cvs-release nil
174 "*The release number of your CVS installation, as a string.
175 If nil, VC itself computes this value when it is first needed.")
158 176
159 ;; Variables the user doesn't need to know about. 177 ;; Variables the user doesn't need to know about.
160 (defvar vc-log-entry-mode nil) 178 (defvar vc-log-entry-mode nil)
161 (defvar vc-log-operation nil) 179 (defvar vc-log-operation nil)
162 (defvar vc-log-after-operation-hook nil) 180 (defvar vc-log-after-operation-hook nil)
173 (defconst vc-name-assoc-file "VC-names") 191 (defconst vc-name-assoc-file "VC-names")
174 192
175 (defvar vc-dired-mode nil) 193 (defvar vc-dired-mode nil)
176 (make-variable-buffer-local 'vc-dired-mode) 194 (make-variable-buffer-local 'vc-dired-mode)
177 195
178 (defvar vc-comment-ring nil) 196 (defvar vc-comment-ring (make-ring vc-maximum-comment-ring-size))
179 (defvar vc-comment-ring-index nil) 197 (defvar vc-comment-ring-index nil)
180 (defvar vc-last-comment-match nil) 198 (defvar vc-last-comment-match nil)
181 199
200 ;; Back-portability to Emacs 18
201
202 (defun file-executable-p-18 (f)
203 (let ((modes (file-modes f)))
204 (and modes (not (zerop (logand 292))))))
205
206 (defun file-regular-p-18 (f)
207 (let ((attributes (file-attributes f)))
208 (and attributes (not (car attributes)))))
209
210 ; Conditionally rebind some things for Emacs 18 compatibility
211 (if (not (boundp 'minor-mode-map-alist))
212 (progn
213 (setq compilation-old-error-list nil)
214 (fset 'file-executable-p 'file-executable-p-18)
215 (fset 'shrink-window-if-larger-than-buffer 'beginning-of-buffer)
216 ))
217
218 (if (not (fboundp 'file-regular-p))
219 (fset 'file-regular-p 'file-regular-p-18))
220
221 ;;; Find and compare backend releases
222
223 (defun vc-backend-release (backend)
224 ;; Returns which backend release is installed on this system.
225 (cond
226 ((eq backend 'RCS)
227 (or vc-rcs-release
228 (and (zerop (vc-do-command nil nil "rcs" nil nil "-V"))
229 (save-excursion
230 (set-buffer (get-buffer "*vc*"))
231 (setq vc-rcs-release
232 (car (vc-parse-buffer
233 '(("^RCS version \\([0-9.]+ *.*\\)" 1)))))))
234 (setq vc-rcs-release 'unknown)))
235 ((eq backend 'CVS)
236 (or vc-cvs-release
237 (and (zerop (vc-do-command nil 1 "cvs" nil nil "-v"))
238 (save-excursion
239 (set-buffer (get-buffer "*vc*"))
240 (setq vc-cvs-release
241 (car (vc-parse-buffer
242 '(("^Concurrent Versions System (CVS) \\([0-9.]+\\)"
243 1)))))))
244 (setq vc-cvs-release 'unknown)))
245 ((eq backend 'SCCS)
246 vc-sccs-release)))
247
248 (defun vc-release-greater-or-equal (r1 r2)
249 ;; Compare release numbers, represented as strings.
250 ;; Release components are assumed cardinal numbers, not decimal
251 ;; fractions (5.10 is a higher release than 5.9). Omitted fields
252 ;; are considered lower (5.6.7 is earlier than 5.6.7.1).
253 ;; Comparison runs till the end of the string is found, or a
254 ;; non-numeric component shows up (5.6.7 is earlier than "5.6.7 beta",
255 ;; which is probably not what you want in some cases).
256 ;; This code is suitable for existing RCS release numbers.
257 ;; CVS releases are handled reasonably, too (1.3 < 1.4* < 1.5).
258 (let (v1 v2 i1 i2)
259 (catch 'done
260 (or (and (string-match "^\\.?\\([0-9]+\\)" r1)
261 (setq i1 (match-end 0))
262 (setq v1 (string-to-number (match-string 1 r1)))
263 (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
264 (setq i2 (match-end 0))
265 (setq v2 (string-to-number (match-string 1 r2)))
266 (if (> v1 v2) (throw 'done t)
267 (if (< v1 v2) (throw 'done nil)
268 (throw 'done
269 (vc-release-greater-or-equal
270 (substring r1 i1)
271 (substring r2 i2)))))))
272 (throw 'done t)))
273 (or (and (string-match "^\\.?\\([0-9]+\\)" r2)
274 (throw 'done nil))
275 (throw 'done t)))))
276
277 (defun vc-backend-release-p (backend release)
278 ;; Return t if we have RELEASE of BACKEND or better
279 (let (i r (ri 0) (ii 0) is rs (installation (vc-backend-release backend)))
280 (if (not (eq installation 'unknown))
281 (cond
282 ((or (eq backend 'RCS) (eq backend 'CVS))
283 (vc-release-greater-or-equal installation release))))))
284
285 ;;; functions that operate on RCS revision numbers
286
287 (defun vc-trunk-p (rev)
288 ;; return t if REV is a revision on the trunk
289 (not (eq nil (string-match "\\`[0-9]+\\.[0-9]+\\'" rev))))
290
291 (defun vc-branch-part (rev)
292 ;; return the branch part of a revision number REV
293 (substring rev 0 (string-match "\\.[0-9]+\\'" rev)))
294
182 ;; File property caching 295 ;; File property caching
183
184 (defun vc-file-clearprops (file)
185 ;; clear all properties of a given file
186 (setplist (intern file vc-file-prop-obarray) nil))
187 296
188 (defun vc-clear-context () 297 (defun vc-clear-context ()
189 "Clear all cached file properties and the comment ring." 298 "Clear all cached file properties and the comment ring."
190 (interactive) 299 (interactive)
191 (fillarray vc-file-prop-obarray nil) 300 (fillarray vc-file-prop-obarray nil)
192 ;; Note: there is potential for minor lossage here if there is an open 301 ;; Note: there is potential for minor lossage here if there is an open
193 ;; log buffer with a nonzero local value of vc-comment-ring-index. 302 ;; log buffer with a nonzero local value of vc-comment-ring-index.
194 (setq vc-comment-ring nil)) 303 (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
304
305 (defun vc-file-clear-masterprops (file)
306 ;; clear all properties of FILE that were retrieved
307 ;; from the master file
308 (vc-file-setprop file 'vc-latest-version nil)
309 (vc-file-setprop file 'vc-your-latest-version nil)
310 (vc-backend-dispatch file
311 (progn ;; SCCS
312 (vc-file-setprop file 'vc-master-locks nil))
313 (progn ;; RCS
314 (vc-file-setprop file 'vc-default-branch nil)
315 (vc-file-setprop file 'vc-head-version nil)
316 (vc-file-setprop file 'vc-master-workfile-version nil)
317 (vc-file-setprop file 'vc-master-locks nil))
318 (progn
319 (vc-file-setprop file 'vc-cvs-status nil))))
320
321 (defun vc-head-version (file)
322 ;; Return the RCS head version of FILE
323 (cond ((vc-file-getprop file 'vc-head-version))
324 (t (vc-fetch-master-properties file)
325 (vc-file-getprop file 'vc-head-version))))
195 326
196 ;; Random helper functions 327 ;; Random helper functions
328
329 (defun vc-latest-on-branch-p (file)
330 ;; return t iff the current workfile version of FILE is
331 ;; the latest on its branch.
332 (vc-backend-dispatch file
333 ;; SCCS
334 (string= (vc-workfile-version file) (vc-latest-version file))
335 ;; RCS
336 (let ((workfile-version (vc-workfile-version file)) tip-version)
337 (if (vc-trunk-p workfile-version)
338 (progn
339 ;; Re-fetch the head version number. This is to make
340 ;; sure that no-one has checked in a new version behind
341 ;; our back.
342 (vc-fetch-master-properties file)
343 (string= (vc-file-getprop file 'vc-head-version)
344 workfile-version))
345 ;; If we are not on the trunk, we need to examine the
346 ;; whole current branch. (vc-master-workfile-version
347 ;; is not what we need.)
348 (save-excursion
349 (set-buffer (get-buffer-create "*vc-info*"))
350 (vc-insert-file (vc-name file) "^desc")
351 (setq tip-version (car (vc-parse-buffer (list (list
352 (concat "^\\(" (regexp-quote (vc-branch-part workfile-version))
353 "\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2)))))
354 (if (get-buffer "*vc-info*")
355 (kill-buffer (get-buffer "*vc-info*")))
356 (string= tip-version workfile-version))))
357 ;; CVS
358 t))
197 359
198 (defun vc-registration-error (file) 360 (defun vc-registration-error (file)
199 (if file 361 (if file
200 (error "File %s is not under version control" file) 362 (error "File %s is not under version control" file)
201 (error "Buffer %s is not associated with a file" (buffer-name)))) 363 (error "Buffer %s is not associated with a file" (buffer-name))))
202 364
203 (defvar vc-binary-assoc nil) 365 (defvar vc-binary-assoc nil)
204 366
367 ;; XEmacs: Function referred to in vc-hooks.el
368 ;;;###autoload
205 (defun vc-find-binary (name) 369 (defun vc-find-binary (name)
206 "Look for a command anywhere on the subprocess-command search path." 370 "Look for a command anywhere on the subprocess-command search path."
207 (or (cdr (assoc name vc-binary-assoc)) 371 (or (cdr (assoc name vc-binary-assoc))
208 ;; XEmacs - use locate-file 372 (catch 'found
209 (let ((full (locate-file name exec-path nil 1))) 373 (mapcar
210 (if full 374 (function
211 (setq vc-binary-assoc (cons (cons name full) vc-binary-assoc))) 375 (lambda (s)
212 full))) 376 (if s
213 377 (let ((full (concat s "/" name)))
214 (defun vc-do-command (okstatus command file last &rest flags) 378 (if (file-executable-p full)
379 (progn
380 (setq vc-binary-assoc
381 (cons (cons name full) vc-binary-assoc))
382 (throw 'found full)))))))
383 exec-path)
384 nil)))
385
386 (defun vc-do-command (buffer okstatus command file last &rest flags)
215 "Execute a version-control command, notifying user and checking for errors. 387 "Execute a version-control command, notifying user and checking for errors.
388 Output from COMMAND goes to BUFFER, or *vc* if BUFFER is nil.
216 The command is successful if its exit status does not exceed OKSTATUS. 389 The command is successful if its exit status does not exceed OKSTATUS.
217 Output from COMMAND goes to buffer *vc*. The last argument of the command is 390 (If OKSTATUS is nil, that means to ignore errors.)
218 the master name of FILE if LAST is 'MASTER, or the workfile of FILE if LAST is 391 The last argument of the command is the master name of FILE if LAST is
219 'WORKFILE; this is appended to an optional list of FLAGS." 392 `MASTER', or the workfile of FILE if LAST is `WORKFILE'; this is appended
220 (setq file (expand-file-name file)) 393 to an optional list of FLAGS."
221 (let ((camefrom (current-buffer)) 394 (and file (setq file (expand-file-name file)))
222 (pwd (file-name-directory (expand-file-name file))) 395 (if (not buffer) (setq buffer "*vc*"))
396 (if vc-command-messages
397 (message "Running %s on %s..." command file))
398 (let ((obuf (current-buffer)) (camefrom (current-buffer))
223 (squeezed nil) 399 (squeezed nil)
224 (vc-file (and file (vc-name file))) 400 (vc-file (and file (vc-name file)))
401 (olddir default-directory)
225 status) 402 status)
226 ;;; #### - don't know why this code was here...to beautify the echo message? 403 (set-buffer (get-buffer-create buffer))
227 ;;; the version of code below doesn't break default-directory, but it
228 ;;; still might mess up CVS and RCS because they like to operate on
229 ;;; files in the current directory. --Stig
230 ;;;
231 ;;; (if (string-match (concat "^" (regexp-quote pwd)) file)
232 ;;; (setq file (substring file (match-end 0)))
233 ;;; (setq pwd (file-name-directory file)))
234 (if vc-command-messages
235 (message "Running %s on %s..." command file))
236 (set-buffer (get-buffer-create "*vc*"))
237 (setq default-directory pwd
238 file (file-name-nondirectory file))
239
240 (set (make-local-variable 'vc-parent-buffer) camefrom) 404 (set (make-local-variable 'vc-parent-buffer) camefrom)
241 (set (make-local-variable 'vc-parent-buffer-name) 405 (set (make-local-variable 'vc-parent-buffer-name)
242 (concat " from " (buffer-name camefrom))) 406 (concat " from " (buffer-name camefrom)))
407 (setq default-directory olddir)
243 408
244 (erase-buffer) 409 (erase-buffer)
245 410
246 (mapcar 411 (mapcar
247 (function (lambda (s) (and s (setq squeezed (append squeezed (list s)))))) 412 (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
248 flags) 413 flags)
249 (if (and vc-file (eq last 'MASTER)) 414 (if (and vc-file (eq last 'MASTER))
250 (setq squeezed (append squeezed (list vc-file)))) 415 (setq squeezed (append squeezed (list vc-file))))
251 (if (eq last 'WORKFILE) 416 (if (eq last 'WORKFILE)
252 (setq squeezed (append squeezed (list file)))) 417 (progn
253 (let ((exec-path (if vc-path (append vc-path exec-path) exec-path)) 418 (let* ((pwd (expand-file-name default-directory))
419 (preflen (length pwd)))
420 (if (string= (substring file 0 preflen) pwd)
421 (setq file (substring file preflen))))
422 (setq squeezed (append squeezed (list file)))))
423 (let ((exec-path (append vc-path exec-path))
254 ;; Add vc-path to PATH for the execution of this command. 424 ;; Add vc-path to PATH for the execution of this command.
255 (process-environment (copy-sequence process-environment))) 425 (process-environment
256 (setenv "PATH" (mapconcat 'identity exec-path ":")) 426 (cons (concat "PATH=" (getenv "PATH")
427 path-separator
428 (mapconcat 'identity vc-path path-separator))
429 process-environment))
430 (w32-quote-process-args t))
257 (setq status (apply 'call-process command nil t nil squeezed))) 431 (setq status (apply 'call-process command nil t nil squeezed)))
258 (goto-char (point-max)) 432 (goto-char (point-max))
259 (set-buffer-modified-p nil) ; XEmacs - fsf uses `not-modified' 433 (set-buffer-modified-p nil)
260 (forward-line -1) 434 (forward-line -1)
261 (if (or (not (integerp status)) (< okstatus status)) 435 (if (or (not (integerp status)) (and okstatus (< okstatus status)))
262 (progn 436 (progn
263 (pop-to-buffer "*vc*") 437 (pop-to-buffer buffer)
264 (goto-char (point-min)) 438 (goto-char (point-min))
265 (shrink-window-if-larger-than-buffer) 439 (shrink-window-if-larger-than-buffer)
266 (error "Running %s...FAILED (%s)" command 440 (error "Running %s...FAILED (%s)" command
267 (if (integerp status) 441 (if (integerp status)
268 (format "status %d" status) 442 (format "status %d" status)
269 status)) 443 status))
270 ) 444 )
271 (if vc-command-messages 445 (if vc-command-messages
272 (message "Running %s...OK" command)) 446 (message "Running %s...OK" command))
273 ) 447 )
274 (set-buffer camefrom) 448 (set-buffer obuf)
275 status) 449 status)
276 ) 450 )
277 451
278 ;;; Save a bit of the text around POSN in the current buffer, to help 452 ;;; Save a bit of the text around POSN in the current buffer, to help
279 ;;; us find the corresponding position again later. This works even 453 ;;; us find the corresponding position again later. This works even
280 ;;; if all markers are destroyed or corrupted. 454 ;;; if all markers are destroyed or corrupted.
455 ;;; A lot of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
281 (defun vc-position-context (posn) 456 (defun vc-position-context (posn)
282 (list posn 457 (list posn
283 (buffer-size) 458 (buffer-size)
284 (buffer-substring posn 459 (buffer-substring posn
285 (min (point-max) (+ posn 100))))) 460 (min (point-max) (+ posn 100)))))
302 ;; beginning of buffer like backward-char would 477 ;; beginning of buffer like backward-char would
303 (search-forward context-string nil t))) 478 (search-forward context-string nil t)))
304 ;; to beginning of OSTRING 479 ;; to beginning of OSTRING
305 (- (point) (length context-string)))))))) 480 (- (point) (length context-string))))))))
306 481
307 (defun vc-revert-buffer1 (&optional arg no-confirm) 482 (defun vc-buffer-context ()
308 ;; Most of this was shamelessly lifted from Sebastian Kremer's rcs.el mode. 483 ;; Return a list '(point-context mark-context reparse); from which
309 ;; Revert buffer, try to keep point and mark where user expects them in spite 484 ;; vc-restore-buffer-context can later restore the context.
310 ;; of changes because of expanded version-control key words.
311 ;; This is quite important since otherwise typeahead won't work as expected.
312 (interactive "P")
313 (widen)
314 (let ((point-context (vc-position-context (point))) 485 (let ((point-context (vc-position-context (point)))
315 ;; Use mark-marker to avoid confusion in transient-mark-mode. 486 ;; Use mark-marker to avoid confusion in transient-mark-mode.
316 ;; XEmacs - mark-marker t 487 (mark-context (if (eq (marker-buffer (mark-marker #+xemacs t))
317 (mark-context (if (eq (marker-buffer (mark-marker t)) (current-buffer)) 488 (current-buffer))
318 (vc-position-context (mark-marker t)))) 489 (vc-position-context (mark-marker #+xemacs t))))
490 ;; Make the right thing happen in transient-mark-mode.
491 (mark-active nil)
319 ;; We may want to reparse the compilation buffer after revert 492 ;; We may want to reparse the compilation buffer after revert
320 (reparse (and (boundp 'compilation-error-list) ;compile loaded 493 (reparse (and (boundp 'compilation-error-list) ;compile loaded
321 ;; Construct a list; each elt is nil or a buffer 494 (let ((curbuf (current-buffer)))
322 ;; iff that buffer is a compilation output buffer 495 ;; Construct a list; each elt is nil or a buffer
323 ;; that contains markers into the current buffer. 496 ;; iff that buffer is a compilation output buffer
324 (save-excursion 497 ;; that contains markers into the current buffer.
325 (mapcar (function 498 (save-excursion
326 (lambda (buffer) 499 (mapcar (function
327 (set-buffer buffer) 500 (lambda (buffer)
328 (let ((errors (or 501 (set-buffer buffer)
329 compilation-old-error-list 502 (let ((errors (or
330 compilation-error-list)) 503 compilation-old-error-list
331 (buffer-error-marked-p nil)) 504 compilation-error-list))
332 (while (and (consp errors) 505 (buffer-error-marked-p nil))
333 (not buffer-error-marked-p)) 506 (while (and (consp errors)
334 (and (markerp (cdr (car errors))) 507 (not buffer-error-marked-p))
335 (eq buffer 508 (and (markerp (cdr (car errors)))
336 (marker-buffer 509 (eq buffer
337 (cdr (car errors)))) 510 (marker-buffer
338 (setq buffer-error-marked-p t)) 511 (cdr (car errors))))
339 (setq errors (cdr errors))) 512 (setq buffer-error-marked-p t))
340 (if buffer-error-marked-p buffer)))) 513 (setq errors (cdr errors)))
341 (buffer-list)))))) 514 (if buffer-error-marked-p buffer))))
342 515 (buffer-list)))))))
343 ;; The FSF version intentionally runs font-lock here. That 516 (list point-context mark-context reparse)))
344 ;; usually just leads to a correctly font-locked buffer being 517
345 ;; redone. #### We should detect the cases where the font-locking 518 (defun vc-restore-buffer-context (context)
346 ;; may be incorrect (such as on reverts). We know that it is fine 519 ;; Restore point/mark, and reparse any affected compilation buffers.
347 ;; during regular checkin and checkouts. 520 ;; CONTEXT is that which vc-buffer-context returns.
348 521 (let ((point-context (nth 0 context))
349 ;; the actual revisit 522 (mark-context (nth 1 context))
350 (revert-buffer arg no-confirm) 523 (reparse (nth 2 context)))
351
352 ;; Reparse affected compilation buffers. 524 ;; Reparse affected compilation buffers.
353 (while reparse 525 (while reparse
354 (if (car reparse) 526 (if (car reparse)
355 (save-excursion 527 (save-excursion
356 (set-buffer (car reparse)) 528 (set-buffer (car reparse))
373 (if new-point (goto-char new-point))) 545 (if new-point (goto-char new-point)))
374 (if mark-context 546 (if mark-context
375 (let ((new-mark (vc-find-position-by-context mark-context))) 547 (let ((new-mark (vc-find-position-by-context mark-context)))
376 (if new-mark (set-mark new-mark)))))) 548 (if new-mark (set-mark new-mark))))))
377 549
550 (defun vc-revert-buffer1 (&optional arg no-confirm)
551 ;; Revert buffer, try to keep point and mark where user expects them in spite
552 ;; of changes because of expanded version-control key words.
553 ;; This is quite important since otherwise typeahead won't work as expected.
554 (interactive "P")
555 (widen)
556 (let ((context (vc-buffer-context)))
557 ;; t means don't call normal-mode; that's to preserve various minor modes.
558 (revert-buffer arg no-confirm t)
559 (vc-restore-buffer-context context)))
560
378 561
379 (defun vc-buffer-sync (&optional not-urgent) 562 (defun vc-buffer-sync (&optional not-urgent)
380 ;; Make sure the current buffer and its working file are in sync 563 ;; Make sure the current buffer and its working file are in sync
381 ;; NOT-URGENT means it is ok to continue if the user says not to save. 564 ;; NOT-URGENT means it is ok to continue if the user says not to save.
382 (if (buffer-modified-p) 565 (if (buffer-modified-p)
385 (save-buffer) 568 (save-buffer)
386 (if not-urgent 569 (if not-urgent
387 nil 570 nil
388 (error "Aborted"))))) 571 (error "Aborted")))))
389 572
390 ;;;###autoload
391 (defun vc-file-status ()
392 "Display the current status of the file being visited.
393 Currently, this is only defined for CVS. The information provided in the
394 modeline is generally sufficient for RCS and SCCS."
395 ;; by Stig@hackvan.com
396 (interactive)
397 (vc-buffer-sync t)
398 (let ((type (vc-backend-deduce buffer-file-name))
399 (file buffer-file-name))
400 (cond ((null type)
401 (if buffer-file-name
402 (message "`%s' is not registered with a version control system."
403 buffer-file-name)
404 (ding)
405 (message "Buffer `%s' has no associated file."
406 (buffer-name (current-buffer)))))
407 ((eq 'CVS type)
408 (vc-do-command 0 "cvs" file 'WORKFILE "status" "-v")
409 (set-buffer "*vc*")
410 (set-buffer-modified-p nil)
411 ;; reparse the status information, since we have it handy...
412 (vc-parse-buffer '("Status: \\(.*\\)") file '(vc-cvs-status))
413 (goto-char (point-min))
414 (shrink-window-if-larger-than-buffer
415 (display-buffer (current-buffer))))
416 ((eq 'CC type)
417 (vc-do-command 0 "cleartool" file 'WORKFILE "describe")
418 (set-buffer "*vc*")
419 (set-buffer-modified-p nil)
420 (goto-char (point-min))
421 (shrink-window-if-larger-than-buffer
422 (display-buffer (current-buffer))))
423 (t
424 (ding)
425 (message "Operation not yet defined for RCS or SCCS.")))
426 ))
427 573
428 (defun vc-workfile-unchanged-p (file &optional want-differences-if-changed) 574 (defun vc-workfile-unchanged-p (file &optional want-differences-if-changed)
429 ;; Has the given workfile changed since last checkout? 575 ;; Has the given workfile changed since last checkout?
430 (cond ((and (eq 'CVS (vc-backend-deduce file)) 576 (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
431 (not want-differences-if-changed)) 577 (lastmod (nth 5 (file-attributes file))))
432 578 (or (equal checkout-time lastmod)
433 (let ((status (vc-file-getprop file 'vc-cvs-status))) 579 (and (or (not checkout-time) want-differences-if-changed)
434 ;; #### - should this have some kind of timeout? how often does 580 (let ((unchanged (zerop (vc-backend-diff file nil nil
435 ;; this get called? possibly the cached information should be 581 (not want-differences-if-changed)))))
436 ;; flushed out of hand. The only concern is the VC menu, which 582 ;; 0 stands for an unknown time; it can't match any mod time.
437 ;; may indirectly call this function. 583 (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
438 (or status ; #### - caching is error-prone 584 unchanged)))))
439 (setq status (car (vc-log-info "cvs" file 'WORKFILE '("status")
440 '("Status: \\(.*\\)")
441 '(vc-cvs-status)))))
442 (string= status "Up-to-date")))
443 (t
444 (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
445 (lastmod (nth 5 (file-attributes file)))
446 unchanged)
447 (or (equal checkout-time lastmod)
448 (and (or (not checkout-time) want-differences-if-changed)
449 (setq unchanged
450 (zerop (vc-backend-diff file nil nil
451 (not want-differences-if-changed))))
452 ;; 0 stands for an unknown time; it can't match any mod time.
453 (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
454 unchanged))))))
455 585
456 (defun vc-next-action-on-file (file verbose &optional comment) 586 (defun vc-next-action-on-file (file verbose &optional comment)
457 ;;; If comment is specified, it will be used as an admin or checkin comment. 587 ;;; If comment is specified, it will be used as an admin or checkin comment.
458 (let ((vc-file (vc-name file)) 588 (let ((vc-file (vc-name file))
459 (vc-type (vc-backend-deduce file)) 589 (vc-type (vc-backend file))
460 owner version) 590 owner version buffer)
461 (cond 591 (cond
462 592
463 ;; if there is no master file corresponding, create one 593 ;; if there is no master file corresponding, create one
464 ((not vc-file) 594 ((not vc-file)
465 (vc-register verbose comment)) 595 (vc-register verbose comment)
466 596 (if vc-initial-comment
467 ;; if there is no lock on the file, assert one and get it 597 (setq vc-log-after-operation-hook
468 ((and (not (eq vc-type 'CVS)) ;There are no locks in CVS. 598 'vc-checkout-writable-buffer-hook)
469 (not (setq owner (vc-locking-user file))))
470 (if (and vc-checkout-carefully
471 (not (vc-workfile-unchanged-p file t)))
472 (if (save-window-excursion
473 (pop-to-buffer "*vc*")
474 (goto-char (point-min))
475 (insert (format "Changes to %s since last lock:\n\n" file))
476 (not (beep))
477 (yes-or-no-p
478 "File has unlocked changes, claim lock retaining changes? "))
479 (progn (vc-backend-steal file)
480 (vc-mode-line file))
481 (if (not (yes-or-no-p "Revert to checked-in version, instead? "))
482 (error "Checkout aborted.")
483 (vc-revert-buffer1 t t)
484 (vc-checkout-writable-buffer file))
485 )
486 (vc-checkout-writable-buffer file))) 599 (vc-checkout-writable-buffer file)))
487 600
488 ;; a checked-out version exists, but the user may not own the lock 601 ;; CVS: changes to the master file need to be
489 ((and (not (eq vc-type 'CVS)) ;There are no locks in CVS. 602 ;; merged back into the working file
490 (not (string-equal owner (user-login-name))))
491 (if comment
492 (error "Sorry, you can't steal the lock on %s this way" file))
493 (vc-steal-lock
494 file
495 (and verbose (read-string "Version to steal: "))
496 owner))
497
498 ;; changes to the master file needs to be merged back into the
499 ;; working file
500 ((and (eq vc-type 'CVS) 603 ((and (eq vc-type 'CVS)
501 ;; "0" means "added, but not yet committed" 604 (or (eq (vc-cvs-status file) 'needs-checkout)
502 (not (string= (vc-file-getprop file 'vc-your-latest-version) "0")) 605 (eq (vc-cvs-status file) 'needs-merge)))
503 (progn 606 (if (or vc-dired-mode
504 (vc-fetch-properties file) 607 (yes-or-no-p
505 (not (string= (vc-file-getprop file 'vc-your-latest-version) 608 (format "%s is not up-to-date. Merge in changes now? "
506 (vc-file-getprop file 'vc-latest-version))))) 609 (buffer-name))))
507 (vc-buffer-sync)
508 (if (yes-or-no-p (format "%s is not up-to-date. Merge in changes now? "
509 (buffer-name)))
510 (progn 610 (progn
511 (if (and (buffer-modified-p) 611 (if vc-dired-mode
612 (and (setq buffer (get-file-buffer file))
613 (buffer-modified-p buffer)
614 (switch-to-buffer-other-window buffer)
615 (vc-buffer-sync t))
616 (setq buffer (current-buffer))
617 (vc-buffer-sync t))
618 (if (and buffer (buffer-modified-p buffer)
512 (not (yes-or-no-p 619 (not (yes-or-no-p
513 (format 620 (format
514 "Buffer %s modified; merge file on disc anyhow? " 621 "Buffer %s modified; merge file on disc anyhow? "
515 (buffer-name))))) 622 (buffer-name buffer)))))
516 (error "Merge aborted")) 623 (error "Merge aborted"))
517 (if (not (zerop (vc-backend-merge-news file))) 624 (if (not (zerop (vc-backend-merge-news file)))
518 ;; Overlaps detected - what now? Should use some 625 ;; Overlaps detected - what now? Should use some
519 ;; fancy RCS conflict resolving package, or maybe 626 ;; fancy RCS conflict resolving package, or maybe
520 ;; emerge, but for now, simply warn the user with a 627 ;; emerge, but for now, simply warn the user with a
521 ;; message. 628 ;; message.
522 (message "Conflicts detected!")) 629 (message "Conflicts detected!"))
523 (vc-resynch-window file t (not (buffer-modified-p)))) 630 (and buffer
524 631 (vc-resynch-buffer file t (not (buffer-modified-p buffer)))))
525 (error "%s needs update" (buffer-name)))) 632 (error "%s needs update" (buffer-name))))
526 633
527 ((and buffer-read-only (eq vc-type 'CVS)) 634 ;; If there is no lock on the file, assert one and get it.
528 (toggle-read-only) 635 ;; (With implicit checkout, make sure not to lose unsaved changes.)
529 ;; Sites who make link farms to a read-only gold tree (or 636 ((progn (and (eq (vc-checkout-model file) 'implicit)
530 ;; something similar) can use the hook below to break the 637 (buffer-modified-p buffer)
531 ;; sym-link. 638 (vc-buffer-sync))
532 (run-hooks 'vc-make-buffer-writable-hook)) 639 (not (setq owner (vc-locking-user file))))
533 640 (if (and vc-checkout-carefully
534 ;; OK, user owns the lock on the file (or we are running CVS) 641 (not (vc-workfile-unchanged-p file t)))
642 (if (save-window-excursion
643 (pop-to-buffer "*vc-diff*")
644 (goto-char (point-min))
645 (insert-string (format "Changes to %s since last lock:\n\n"
646 file))
647 (not (beep))
648 (yes-or-no-p
649 (concat "File has unlocked changes, "
650 "claim lock retaining changes? ")))
651 (progn (vc-backend-steal file)
652 (vc-mode-line file))
653 (if (not (yes-or-no-p "Revert to checked-in version, instead? "))
654 (error "Checkout aborted")
655 (vc-revert-buffer1 t t)
656 (vc-checkout-writable-buffer file))
657 )
658 (if verbose
659 (if (not (eq vc-type 'SCCS))
660 (vc-checkout file nil
661 (read-string "Branch or version to move to: "))
662 (error "Sorry, this is not implemented for SCCS"))
663 (if (vc-latest-on-branch-p file)
664 (vc-checkout-writable-buffer file)
665 (if (yes-or-no-p
666 "This is not the latest version. Really lock it? ")
667 (vc-checkout-writable-buffer file)
668 (if (yes-or-no-p "Lock the latest version instead? ")
669 (vc-checkout-writable-buffer file
670 (if (vc-trunk-p (vc-workfile-version file))
671 "" ;; this means check out latest on trunk
672 (vc-branch-part (vc-workfile-version file)))))))
673 )))
674
675 ;; a checked-out version exists, but the user may not own the lock
676 ((and (not (eq vc-type 'CVS))
677 (not (string-equal owner (vc-user-login-name))))
678 (if comment
679 (error "Sorry, you can't steal the lock on %s this way" file))
680 (and (eq vc-type 'RCS)
681 (not (vc-backend-release-p 'RCS "5.6.2"))
682 (error "File is locked by %s" owner))
683 (vc-steal-lock
684 file
685 (if verbose (read-string "Version to steal: ")
686 (vc-workfile-version file))
687 owner))
688
689 ;; OK, user owns the lock on the file
535 (t 690 (t
536 (find-file file) 691 (if vc-dired-mode
537 692 (find-file-other-window file)
538 ;; give luser a chance to save before checking in. 693 (find-file file))
539 (vc-buffer-sync) 694
540 695 ;; give luser a chance to save before checking in.
541 ;; Revert if file is unchanged and buffer is too. 696 (vc-buffer-sync)
542 ;; If buffer is modified, that means the user just said no 697
543 ;; to saving it; in that case, don't revert, 698 ;; Revert if file is unchanged and buffer is too.
544 ;; because the user might intend to save 699 ;; If buffer is modified, that means the user just said no
545 ;; after finishing the log entry. 700 ;; to saving it; in that case, don't revert,
546 (if (and (vc-workfile-unchanged-p file) 701 ;; because the user might intend to save
547 (not (buffer-modified-p))) 702 ;; after finishing the log entry.
548 (progn 703 (if (and (vc-workfile-unchanged-p file)
549 (if (eq vc-type 'CVS) 704 (not (buffer-modified-p)))
550 (message "No changes to %s" file) 705 ;; DO NOT revert the file without asking the user!
551 706 (cond
552 (vc-backend-revert file) 707 ((yes-or-no-p "Revert to master version? ")
553 ;; DO NOT revert the file without asking the user! 708 (vc-backend-revert file)
554 (vc-resynch-window file t nil))) 709 (vc-resynch-window file t t)))
555 710
556 ;; user may want to set nonstandard parameters 711 ;; user may want to set nonstandard parameters
557 (if verbose 712 (if verbose
558 (setq version (read-string "New version level: "))) 713 (setq version (read-string "New version level: ")))
559 714
560 ;; OK, let's do the checkin 715 ;; OK, let's do the checkin
561 (vc-checkin file version comment) 716 (vc-checkin file version comment)
562 ))))) 717 )))))
563 718
564 (defun vc-next-action-dired (file rev comment) 719 (defun vc-next-action-dired (file rev comment)
565 ;; We've accepted a log comment, now do a vc-next-action using it on all 720 ;; Do a vc-next-action-on-file on all the marked files, possibly
566 ;; marked files. 721 ;; passing on the log comment we've just entered.
567 (set-buffer vc-parent-buffer) 722 (let ((configuration (current-window-configuration))
568 (dired-map-over-marks 723 (dired-buffer (current-buffer))
569 (save-window-excursion 724 (dired-dir default-directory))
570 (let ((file (dired-get-filename))) 725 (dired-map-over-marks
726 (let ((file (dired-get-filename)) p
727 (default-directory default-directory))
571 (message "Processing %s..." file) 728 (message "Processing %s..." file)
729 ;; Adjust the default directory so that checkouts
730 ;; go to the right place.
731 (setq default-directory (file-name-directory file))
572 (vc-next-action-on-file file nil comment) 732 (vc-next-action-on-file file nil comment)
573 (message "Processing %s...done" file))) 733 (set-buffer dired-buffer)
574 nil t) 734 (setq default-directory dired-dir)
575 ) 735 (vc-dired-update-line file)
736 (set-window-configuration configuration)
737 (message "Processing %s...done" file))
738 nil t)))
576 739
577 ;; Here's the major entry point. 740 ;; Here's the major entry point.
578 741
579 ;;;###autoload 742 ;;;###autoload
580 (defun vc-next-action (verbose) 743 (defun vc-next-action (verbose)
581 "Do the next logical checkin or checkout operation on the current file. 744 "Do the next logical checkin or checkout operation on the current file.
745 If you call this from within a VC dired buffer with no files marked,
746 it will operate on the file in the current line.
747 If you call this from within a VC dired buffer, and one or more
748 files are marked, it will accept a log message and then operate on
749 each one. The log message will be used as a comment for any register
750 or checkin operations, but ignored when doing checkouts. Attempted
751 lock steals will raise an error.
752 A prefix argument lets you specify the version number to use.
582 753
583 For RCS and SCCS files: 754 For RCS and SCCS files:
584 If the file is not already registered, this registers it for version 755 If the file is not already registered, this registers it for version
585 control and then retrieves a writable, locked copy for editing. 756 control and then retrieves a writable, locked copy for editing.
586 If the file is registered and not locked by anyone, this checks out 757 If the file is registered and not locked by anyone, this checks out
598 769
599 For CVS files: 770 For CVS files:
600 If the file is not already registered, this registers it for version 771 If the file is not already registered, this registers it for version
601 control. This does a \"cvs add\", but no \"cvs commit\". 772 control. This does a \"cvs add\", but no \"cvs commit\".
602 If the file is added but not committed, it is committed. 773 If the file is added but not committed, it is committed.
603 If the file has not been changed, neither in your working area or
604 in the repository, a message is printed and nothing is done.
605 If your working file is changed, but the repository file is 774 If your working file is changed, but the repository file is
606 unchanged, this pops up a buffer for entry of a log message; when the 775 unchanged, this pops up a buffer for entry of a log message; when the
607 message has been entered, it checks in the resulting changes along 776 message has been entered, it checks in the resulting changes along
608 with the logmessage as change commentary. A writable file is retained. 777 with the logmessage as change commentary. A writable file is retained.
609 If the repository file is changed, you are asked if you want to 778 If the repository file is changed, you are asked if you want to
610 merge in the changes into your working copy. 779 merge in the changes into your working copy."
611 780
612 The following is true regardless of which version control system you
613 are using:
614
615 If you call this from within a VC dired buffer with no files marked,
616 it will operate on the file in the current line.
617 If you call this from within a VC dired buffer, and one or more
618 files are marked, it will accept a log message and then operate on
619 each one. The log message will be used as a comment for any register
620 or checkin operations, but ignored when doing checkouts. Attempted
621 lock steals will raise an error.
622
623 For checkin, a prefix argument lets you specify the version number to use."
624 (interactive "P") 781 (interactive "P")
625 (catch 'nogo 782 (catch 'nogo
626 (if vc-dired-mode 783 (if vc-dired-mode
627 (let ((files (dired-get-marked-files))) 784 (let ((files (dired-get-marked-files)))
628 (if (= (length files) 1) 785 (if (string= ""
629 (find-file-other-window (car files)) 786 (mapconcat
630 (vc-start-entry nil nil nil 787 (function (lambda (f)
631 "Enter a change comment for the marked files." 788 (if (eq (vc-backend f) 'CVS)
632 'vc-next-action-dired) 789 (if (or (eq (vc-cvs-status f) 'locally-modified)
633 (throw 'nogo nil)))) 790 (eq (vc-cvs-status f) 'locally-added))
791 "@" "")
792 (if (vc-locking-user f) "@" ""))))
793 files ""))
794 (vc-next-action-dired nil nil "dummy")
795 (vc-start-entry nil nil nil
796 "Enter a change comment for the marked files."
797 'vc-next-action-dired))
798 (throw 'nogo nil)))
634 (while vc-parent-buffer 799 (while vc-parent-buffer
635 (pop-to-buffer vc-parent-buffer)) 800 (pop-to-buffer vc-parent-buffer))
636 (if buffer-file-name 801 (if buffer-file-name
637 (vc-next-action-on-file buffer-file-name verbose) 802 (vc-next-action-on-file buffer-file-name verbose)
638 (vc-registration-error nil)))) 803 (vc-registration-error nil))))
639 804
640 ;;; These functions help the vc-next-action entry point 805 ;;; These functions help the vc-next-action entry point
641 806
642 (defun vc-checkout-writable-buffer (&optional file) 807 (defun vc-checkout-writable-buffer (&optional file rev)
643 "Retrieve a writable copy of the latest version of the current buffer's file." 808 "Retrieve a writable copy of the latest version of the current buffer's file."
644 (vc-checkout (or file (buffer-file-name)) t) 809 (vc-checkout (or file (buffer-file-name)) t rev)
645 ) 810 )
646 811
647 ;;;###autoload 812 ;;;###autoload
648 (defun vc-register (&optional override comment) 813 (defun vc-register (&optional override comment)
649 "Register the current file into your version-control system." 814 "Register the current file into your version-control system."
650 (interactive "P") 815 (interactive "P")
816 (or buffer-file-name
817 (error "No visited file"))
651 (let ((master (vc-name buffer-file-name))) 818 (let ((master (vc-name buffer-file-name)))
652 (and master (file-exists-p master) 819 (and master (file-exists-p master)
653 (error "This file is already registered")) 820 (error "This file is already registered"))
654 (and master 821 (and master
655 (not (y-or-n-p "Previous master file has vanished. Make a new one? ")) 822 (not (y-or-n-p "Previous master file has vanished. Make a new one? "))
659 (if (and (not (buffer-modified-p)) 826 (if (and (not (buffer-modified-p))
660 (zerop (buffer-size)) 827 (zerop (buffer-size))
661 (not (file-exists-p buffer-file-name))) 828 (not (file-exists-p buffer-file-name)))
662 (set-buffer-modified-p t)) 829 (set-buffer-modified-p t))
663 (vc-buffer-sync) 830 (vc-buffer-sync)
831 (cond ((not vc-make-backup-files)
832 ;; inhibit backup for this buffer
833 (make-local-variable 'backup-inhibited)
834 (setq backup-inhibited t)))
664 (vc-admin 835 (vc-admin
665 buffer-file-name 836 buffer-file-name
666 (and override 837 (and override
667 (read-string 838 (read-string
668 (format "Initial version level for %s: " buffer-file-name)))) 839 (format "Initial version level for %s: " buffer-file-name))))
669 ) 840 )
670 841
671 (defun vc-resynch-window (file &optional keep noquery) 842 (defun vc-resynch-window (file &optional keep noquery)
672 ;; If the given file is in the current buffer, 843 ;; If the given file is in the current buffer,
673 ;; either revert on it so we see expanded keyworks, 844 ;; either revert on it so we see expanded keywords,
674 ;; or unvisit it (depending on vc-keep-workfiles) 845 ;; or unvisit it (depending on vc-keep-workfiles)
675 ;; NOQUERY if non-nil inhibits confirmation for reverting. 846 ;; NOQUERY if non-nil inhibits confirmation for reverting.
676 ;; NOQUERY should be t *only* if it is known the only difference 847 ;; NOQUERY should be t *only* if it is known the only difference
677 ;; between the buffer and the file is due to RCS rather than user editing! 848 ;; between the buffer and the file is due to RCS rather than user editing!
678 (and (string= buffer-file-name file) 849 (and (string= buffer-file-name file)
679 (if keep 850 (if keep
680 (progn 851 (progn
852 ;; temporarily remove vc-find-file-hook, so that
853 ;; we don't lose the properties
854 (remove-hook 'find-file-hooks 'vc-find-file-hook)
681 (vc-revert-buffer1 t noquery) 855 (vc-revert-buffer1 t noquery)
856 (add-hook 'find-file-hooks 'vc-find-file-hook)
682 (vc-mode-line buffer-file-name)) 857 (vc-mode-line buffer-file-name))
683 (progn 858 (kill-buffer (current-buffer)))))
684 (delete-window) 859
685 (kill-buffer (current-buffer)))))) 860 (defun vc-resynch-buffer (file &optional keep noquery)
686 861 ;; if FILE is currently visited, resynch its buffer
687 (defun vc-start-entry (file rev comment msg action &optional after-hook before-hook) 862 (let ((buffer (get-file-buffer file)))
863 (if buffer
864 (save-excursion
865 (set-buffer buffer)
866 (vc-resynch-window file keep noquery)))))
867
868 (defun vc-start-entry (file rev comment msg action &optional after-hook)
688 ;; Accept a comment for an operation on FILE revision REV. If COMMENT 869 ;; Accept a comment for an operation on FILE revision REV. If COMMENT
689 ;; is nil, pop up a VC-log buffer, emit MSG, and set the 870 ;; is nil, pop up a VC-log buffer, emit MSG, and set the
690 ;; action on close to ACTION; otherwise, do action immediately. 871 ;; action on close to ACTION; otherwise, do action immediately.
691 ;; Remember the file's buffer in vc-parent-buffer (current one if no file). 872 ;; Remember the file's buffer in vc-parent-buffer (current one if no file).
692 ;; AFTER-HOOK specifies the local value for vc-log-operation-hook. 873 ;; AFTER-HOOK specifies the local value for vc-log-operation-hook.
693 ;; BEFORE-HOOK specifies a hook to run before even asking for the
694 ;; checkin comments.
695 (let ((parent (if file (find-file-noselect file) (current-buffer)))) 874 (let ((parent (if file (find-file-noselect file) (current-buffer))))
696 (when before-hook 875 (if vc-before-checkin-hook
697 (save-excursion 876 (if file
698 (set-buffer parent) 877 (save-excursion
699 (run-hooks before-hook))) 878 (set-buffer parent)
879 (run-hooks 'vc-before-checkin-hook))
880 (run-hooks 'vc-before-checkin-hook)))
700 (if comment 881 (if comment
701 (set-buffer (get-buffer-create "*VC-log*")) 882 (set-buffer (get-buffer-create "*VC-log*"))
702 (pop-to-buffer (get-buffer-create "*VC-log*"))) 883 (pop-to-buffer (get-buffer-create "*VC-log*")))
703 (set (make-local-variable 'vc-parent-buffer) parent) 884 (set (make-local-variable 'vc-parent-buffer) parent)
704 (set (make-local-variable 'vc-parent-buffer-name) 885 (set (make-local-variable 'vc-parent-buffer-name)
705 (concat " from " (buffer-name vc-parent-buffer))) 886 (concat " from " (buffer-name vc-parent-buffer)))
706 (vc-mode-line (or file " (no file)")) 887 (if file (vc-mode-line file))
707 (vc-log-mode) 888 (vc-log-mode file)
708 (make-local-variable 'vc-log-after-operation-hook) 889 (make-local-variable 'vc-log-after-operation-hook)
709 (if after-hook 890 (if after-hook
710 (setq vc-log-after-operation-hook after-hook)) 891 (setq vc-log-after-operation-hook after-hook))
711 (setq vc-log-operation action) 892 (setq vc-log-operation action)
712 (setq vc-log-file file)
713 (setq vc-log-version rev) 893 (setq vc-log-version rev)
714 (if comment 894 (if comment
715 (progn 895 (progn
716 (erase-buffer) 896 (erase-buffer)
717 (if (eq comment t) 897 (if (eq comment t)
725 FILE is the unmodified name of the file. REV should be the base version 905 FILE is the unmodified name of the file. REV should be the base version
726 level to check it in under. COMMENT, if specified, is the checkin comment." 906 level to check it in under. COMMENT, if specified, is the checkin comment."
727 (vc-start-entry file rev 907 (vc-start-entry file rev
728 (or comment (not vc-initial-comment)) 908 (or comment (not vc-initial-comment))
729 "Enter initial comment." 'vc-backend-admin 909 "Enter initial comment." 'vc-backend-admin
730 nil 'vc-before-checkin-hook)) 910 nil))
731 911
732 (defun vc-checkout (file &optional writable) 912 ;; XEmacs: Function referred to in vc-hooks.el.
913 ;;;###autoload
914 (defun vc-checkout (file &optional writable rev)
733 "Retrieve a copy of the latest version of the given file." 915 "Retrieve a copy of the latest version of the given file."
734 ;; XEmacs - ftp is suppressed by the check for a filename handler in
735 ;; vc-registered, so this is needless surplussage
736 ;; If ftp is on this system and the name matches the ange-ftp format 916 ;; If ftp is on this system and the name matches the ange-ftp format
737 ;; for a remote file, the user is trying something that won't work. 917 ;; for a remote file, the user is trying something that won't work.
738 ;; (if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp")) 918 (if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp"))
739 ;; (error "Sorry, you can't check out files over FTP")) 919 (error "Sorry, you can't check out files over FTP"))
740 (vc-backend-checkout file writable) 920 (vc-backend-checkout file writable rev)
741 (if (string-equal file buffer-file-name) 921 (vc-resynch-buffer file t t))
742 (vc-resynch-window file t t))
743 )
744 922
745 (defun vc-steal-lock (file rev &optional owner) 923 (defun vc-steal-lock (file rev &optional owner)
746 "Steal the lock on the current workfile." 924 "Steal the lock on the current workfile."
747 (let (file-description) 925 (let (file-description)
748 (if (not owner) 926 (if (not owner)
783 If the back-end is CVS, a writable workfile is always kept. 961 If the back-end is CVS, a writable workfile is always kept.
784 COMMENT is a comment string; if omitted, a buffer is 962 COMMENT is a comment string; if omitted, a buffer is
785 popped up to accept a comment." 963 popped up to accept a comment."
786 (vc-start-entry file rev comment 964 (vc-start-entry file rev comment
787 "Enter a change comment." 'vc-backend-checkin 965 "Enter a change comment." 'vc-backend-checkin
788 'vc-checkin-hook 'vc-before-checkin-hook)) 966 'vc-checkin-hook))
789 967
790 ;;; Here is a checkin hook that may prove useful to sites using the 968 ;;; Here is a checkin hook that may prove useful to sites using the
791 ;;; ChangeLog facility supported by Emacs. 969 ;;; ChangeLog facility supported by Emacs.
792 (defun vc-comment-to-change-log (&optional whoami file-name) 970 (defun vc-comment-to-change-log (&optional whoami file-name)
793 "Enter last VC comment into change log file for current buffer's file. 971 "Enter last VC comment into change log file for current buffer's file.
798 (list current-prefix-arg 976 (list current-prefix-arg
799 (prompt-for-change-log-name)))) 977 (prompt-for-change-log-name))))
800 ;; Make sure the defvar for add-log-current-defun-function has been executed 978 ;; Make sure the defvar for add-log-current-defun-function has been executed
801 ;; before binding it. 979 ;; before binding it.
802 (require 'add-log) 980 (require 'add-log)
803 (let ( ; Extract the comment first so we get any error before doing anything. 981 (let (;; Extract the comment first so we get any error before doing anything.
804 (comment (ring-ref vc-comment-ring 0)) 982 (comment (ring-ref vc-comment-ring 0))
805 ;; Don't let add-change-log-entry insert a defun name. 983 ;; Don't let add-change-log-entry insert a defun name.
806 (add-log-current-defun-function 'ignore) 984 (add-log-current-defun-function 'ignore)
807 end) 985 end)
808 ;; Call add-log to do half the work. 986 ;; Call add-log to do half the work.
821 (while (< (point) end) 999 (while (< (point) end)
822 (forward-line 1) 1000 (forward-line 1)
823 (indent-to indentation)) 1001 (indent-to indentation))
824 (setq end (point)))) 1002 (setq end (point))))
825 ;; Fill the inserted text, preserving open-parens at bol. 1003 ;; Fill the inserted text, preserving open-parens at bol.
826 (let ((paragraph-separate (concat paragraph-separate "\\|^\\s *\\s(")) 1004 (let ((paragraph-separate (concat paragraph-separate "\\|\\s *\\s("))
827 (paragraph-start (concat paragraph-start "\\|^\\s *\\s("))) 1005 (paragraph-start (concat paragraph-start "\\|\\s *\\s(")))
828 (beginning-of-line) 1006 (beginning-of-line)
829 (fill-region (point) end)) 1007 (fill-region (point) end))
830 ;; Canonicalize the white space at the end of the entry so it is 1008 ;; Canonicalize the white space at the end of the entry so it is
831 ;; separated from the next entry by a single blank line. 1009 ;; separated from the next entry by a single blank line.
832 (skip-syntax-forward " " end) 1010 (skip-syntax-forward " " end)
845 (if (not (bolp)) 1023 (if (not (bolp))
846 (newline)) 1024 (newline))
847 ;; Comment too long? 1025 ;; Comment too long?
848 (vc-backend-logentry-check vc-log-file) 1026 (vc-backend-logentry-check vc-log-file)
849 ;; Record the comment in the comment ring 1027 ;; Record the comment in the comment ring
850 (if (null vc-comment-ring)
851 (setq vc-comment-ring (make-ring vc-maximum-comment-ring-size)))
852 (ring-insert vc-comment-ring (buffer-string)) 1028 (ring-insert vc-comment-ring (buffer-string))
853 )) 1029 ))
854 ;; Sync parent buffer in case the user modified it while editing the comment. 1030 ;; Sync parent buffer in case the user modified it while editing the comment.
855 ;; But not if it is a vc-dired buffer. 1031 ;; But not if it is a vc-dired buffer.
856 (save-excursion 1032 (save-excursion
857 (set-buffer vc-parent-buffer) 1033 (set-buffer vc-parent-buffer)
858 (or vc-dired-mode 1034 (or vc-dired-mode
859 (vc-buffer-sync))) 1035 (vc-buffer-sync)))
860 ;; OK, do it to it 1036 (if (not vc-log-operation) (error "No log operation is pending"))
861 (if vc-log-operation 1037 ;; save the parameters held in buffer-local variables
862 (save-excursion 1038 (let ((log-operation vc-log-operation)
863 (funcall vc-log-operation 1039 (log-file vc-log-file)
864 vc-log-file 1040 (log-version vc-log-version)
865 vc-log-version 1041 (log-entry (buffer-string))
866 (buffer-string))) 1042 (after-hook vc-log-after-operation-hook))
867 (error "No log operation is pending"))
868 ;; save the vc-log-after-operation-hook of log buffer
869 (let ((after-hook vc-log-after-operation-hook))
870 ;; Return to "parent" buffer of this checkin and remove checkin window 1043 ;; Return to "parent" buffer of this checkin and remove checkin window
871 (pop-to-buffer vc-parent-buffer) 1044 (pop-to-buffer vc-parent-buffer)
872 (let ((logbuf (get-buffer "*VC-log*"))) 1045 (let ((logbuf (get-buffer "*VC-log*")))
873 (delete-windows-on logbuf) 1046 (delete-windows-on logbuf)
874 (kill-buffer logbuf)) 1047 (kill-buffer logbuf))
1048 ;; OK, do it to it
1049 (save-excursion
1050 (funcall log-operation
1051 log-file
1052 log-version
1053 log-entry))
875 ;; Now make sure we see the expanded headers 1054 ;; Now make sure we see the expanded headers
876 (if buffer-file-name 1055 (if buffer-file-name
877 (vc-resynch-window buffer-file-name vc-keep-workfiles t)) 1056 (vc-resynch-window buffer-file-name vc-keep-workfiles t))
878 (run-hooks after-hook))) 1057 (run-hooks after-hook 'vc-finish-logentry-hook)))
879 1058
880 ;; Code for access to the comment ring 1059 ;; Code for access to the comment ring
881 1060
882 (defun vc-previous-comment (arg) 1061 (defun vc-previous-comment (arg)
883 "Cycle backwards through comment history." 1062 "Cycle backwards through comment history."
884 (interactive "*p") 1063 (interactive "*p")
885 (let ((len (ring-length vc-comment-ring))) 1064 (let ((len (ring-length vc-comment-ring)))
886 (cond ((or (not len) (<= len 0)) ; XEmacs change from Barry Warsaw 1065 (cond ((<= len 0)
887 (message "Empty comment ring") 1066 (message "Empty comment ring")
888 (ding)) 1067 (ding))
889 (t 1068 (t
890 (erase-buffer) 1069 (erase-buffer)
891 ;; Initialize the index on the first use of this command 1070 ;; Initialize the index on the first use of this command
892 ;; so that the first M-p gets index 0, and the first M-n gets 1071 ;; so that the first M-p gets index 0, and the first M-n gets
893 ;; index -1. 1072 ;; index -1.
894 (if (null vc-comment-ring-index) 1073 (if (null vc-comment-ring-index)
895 (setq vc-comment-ring-index 1074 (setq vc-comment-ring-index
896 (if (> arg 0) -1 1075 (if (> arg 0) -1
897 (if (< arg 0) 1 0)))) 1076 (if (< arg 0) 1 0))))
898 (setq vc-comment-ring-index 1077 (setq vc-comment-ring-index
899 (mod (+ vc-comment-ring-index arg) len)) 1078 (mod (+ vc-comment-ring-index arg) len))
900 (message "%d" (1+ vc-comment-ring-index)) 1079 (message "%d" (1+ vc-comment-ring-index))
901 (insert (ring-ref vc-comment-ring vc-comment-ring-index)))))) 1080 (insert (ring-ref vc-comment-ring vc-comment-ring-index))))))
902 1081
912 (setq str vc-last-comment-match) 1091 (setq str vc-last-comment-match)
913 (setq vc-last-comment-match str)) 1092 (setq vc-last-comment-match str))
914 (if (null vc-comment-ring-index) 1093 (if (null vc-comment-ring-index)
915 (setq vc-comment-ring-index -1)) 1094 (setq vc-comment-ring-index -1))
916 (let ((str (regexp-quote str)) 1095 (let ((str (regexp-quote str))
917 (len (ring-length vc-comment-ring)) 1096 (len (ring-length vc-comment-ring))
918 (n (1+ vc-comment-ring-index))) 1097 (n (1+ vc-comment-ring-index)))
919 (while (and (< n len) (not (string-match str (ring-ref vc-comment-ring n)))) 1098 (while (and (< n len) (not (string-match str (ring-ref vc-comment-ring n))))
920 (setq n (+ n 1))) 1099 (setq n (+ n 1)))
921 (cond ((< n len) 1100 (cond ((< n len)
922 (vc-previous-comment (- n vc-comment-ring-index))) 1101 (vc-previous-comment (- n vc-comment-ring-index)))
929 (setq str vc-last-comment-match) 1108 (setq str vc-last-comment-match)
930 (setq vc-last-comment-match str)) 1109 (setq vc-last-comment-match str))
931 (if (null vc-comment-ring-index) 1110 (if (null vc-comment-ring-index)
932 (setq vc-comment-ring-index 0)) 1111 (setq vc-comment-ring-index 0))
933 (let ((str (regexp-quote str)) 1112 (let ((str (regexp-quote str))
1113 (len (ring-length vc-comment-ring))
934 (n vc-comment-ring-index)) 1114 (n vc-comment-ring-index))
935 (while (and (>= n 0) (not (string-match str (ring-ref vc-comment-ring n)))) 1115 (while (and (>= n 0) (not (string-match str (ring-ref vc-comment-ring n))))
936 (setq n (- n 1))) 1116 (setq n (- n 1)))
937 (cond ((>= n 0) 1117 (cond ((>= n 0)
938 (vc-next-comment (- n vc-comment-ring-index))) 1118 (vc-next-comment (- n vc-comment-ring-index)))
945 "Display diffs between file versions. 1125 "Display diffs between file versions.
946 Normally this compares the current file and buffer with the most recent 1126 Normally this compares the current file and buffer with the most recent
947 checked in version of that file. This uses no arguments. 1127 checked in version of that file. This uses no arguments.
948 With a prefix argument, it reads the file name to use 1128 With a prefix argument, it reads the file name to use
949 and two version designators specifying which versions to compare." 1129 and two version designators specifying which versions to compare."
950 (interactive "P") 1130 (interactive (list current-prefix-arg t))
951 (if vc-dired-mode 1131 (if vc-dired-mode
952 (set-buffer (find-file-noselect (dired-get-filename)))) 1132 (set-buffer (find-file-noselect (dired-get-filename))))
953 (while vc-parent-buffer 1133 (while vc-parent-buffer
954 (pop-to-buffer vc-parent-buffer)) 1134 (pop-to-buffer vc-parent-buffer))
955 (if historic 1135 (if historic
956 (call-interactively 'vc-version-diff) 1136 (call-interactively 'vc-version-diff)
957 (if (or (null buffer-file-name) (null (vc-name buffer-file-name))) 1137 (if (or (null buffer-file-name) (null (vc-name buffer-file-name)))
958 (error 1138 (error
959 "There is no version-control master associated with this buffer")) 1139 "There is no version-control master associated with this buffer"))
962 (or (and file (vc-name file)) 1142 (or (and file (vc-name file))
963 (vc-registration-error file)) 1143 (vc-registration-error file))
964 (vc-buffer-sync not-urgent) 1144 (vc-buffer-sync not-urgent)
965 (setq unchanged (vc-workfile-unchanged-p buffer-file-name)) 1145 (setq unchanged (vc-workfile-unchanged-p buffer-file-name))
966 (if unchanged 1146 (if unchanged
967 (message "No changes to %s since latest version." file) 1147 (message "No changes to %s since latest version" file)
968 (vc-backend-diff file) 1148 (vc-backend-diff file)
969 ;; Ideally, we'd like at this point to parse the diff so that 1149 ;; Ideally, we'd like at this point to parse the diff so that
970 ;; the buffer effectively goes into compilation mode and we 1150 ;; the buffer effectively goes into compilation mode and we
971 ;; can visit the old and new change locations via next-error. 1151 ;; can visit the old and new change locations via next-error.
972 ;; Unfortunately, this is just too painful to do. The basic 1152 ;; Unfortunately, this is just too painful to do. The basic
973 ;; problem is that the `old' file doesn't exist to be 1153 ;; problem is that the `old' file doesn't exist to be
974 ;; visited. This plays hell with numerous assumptions in 1154 ;; visited. This plays hell with numerous assumptions in
975 ;; the diff.el and compile.el machinery. 1155 ;; the diff.el and compile.el machinery.
976 (pop-to-buffer "*vc*") 1156 (set-buffer "*vc-diff*")
977 (setq default-directory (file-name-directory file)) 1157 (setq default-directory (file-name-directory file))
978 (if (= 0 (buffer-size)) 1158 (if (= 0 (buffer-size))
979 (progn 1159 (progn
980 (setq unchanged t) 1160 (setq unchanged t)
981 (message "No changes to %s since latest version." file)) 1161 (message "No changes to %s since latest version" file))
1162 (pop-to-buffer "*vc-diff*")
982 (goto-char (point-min)) 1163 (goto-char (point-min))
983 (shrink-window-if-larger-than-buffer))) 1164 (shrink-window-if-larger-than-buffer)))
984 (not unchanged)))) 1165 (not unchanged))))
985 1166
986 ;;;###autoload
987 (defun vc-version-diff (file rel1 rel2) 1167 (defun vc-version-diff (file rel1 rel2)
988 "For FILE, report diffs between two stored versions REL1 and REL2 of it. 1168 "For FILE, report diffs between two stored versions REL1 and REL2 of it.
989 If FILE is a directory, generate diffs between versions for all registered 1169 If FILE is a directory, generate diffs between versions for all registered
990 files in or below it." 1170 files in or below it."
991 ;; XEmacs - better prompt 1171 (interactive "FFile or directory to diff: \nsOlder version: \nsNewer version: ")
992 (interactive "FFile or directory to diff: \nsOlder version (default is repository): \nsNewer version (default is workfile): ")
993 (if (string-equal rel1 "") (setq rel1 nil)) 1172 (if (string-equal rel1 "") (setq rel1 nil))
994 (if (string-equal rel2 "") (setq rel2 nil)) 1173 (if (string-equal rel2 "") (setq rel2 nil))
995 (if (file-directory-p file) 1174 (if (file-directory-p file)
996 (let ((camefrom (current-buffer))) 1175 (let ((camefrom (current-buffer)))
997 (set-buffer (get-buffer-create "*vc-status*")) 1176 (set-buffer (get-buffer-create "*vc-status*"))
1002 (insert "Diffs between " 1181 (insert "Diffs between "
1003 (or rel1 "last version checked in") 1182 (or rel1 "last version checked in")
1004 " and " 1183 " and "
1005 (or rel2 "current workfile(s)") 1184 (or rel2 "current workfile(s)")
1006 ":\n\n") 1185 ":\n\n")
1007 (set-buffer (get-buffer-create "*vc*")) 1186 (set-buffer (get-buffer-create "*vc-diff*"))
1008 (cd file) 1187 (cd file)
1009 (vc-file-tree-walk 1188 (vc-file-tree-walk
1189 default-directory
1010 (function (lambda (f) 1190 (function (lambda (f)
1011 (message "Looking at %s" f) 1191 (message "Looking at %s" f)
1012 (and 1192 (and
1013 (not (file-directory-p f)) 1193 (not (file-directory-p f))
1014 (vc-registered f) 1194 (vc-registered f)
1020 (goto-char (point-min)) 1200 (goto-char (point-min))
1021 (set-buffer-modified-p nil) 1201 (set-buffer-modified-p nil)
1022 ) 1202 )
1023 (if (zerop (vc-backend-diff file rel1 rel2)) 1203 (if (zerop (vc-backend-diff file rel1 rel2))
1024 (message "No changes to %s between %s and %s." file rel1 rel2) 1204 (message "No changes to %s between %s and %s." file rel1 rel2)
1025 (pop-to-buffer "*vc*")))) 1205 (pop-to-buffer "*vc-diff*"))))
1026 1206
1027 ;;;###autoload 1207 ;;;###autoload
1028 (defun vc-version-other-window (rev) 1208 (defun vc-version-other-window (rev)
1029 "Visit version REV of the current buffer in another window. 1209 "Visit version REV of the current buffer in another window.
1030 If the current buffer is named `F', the version is named `F.~REV~'. 1210 If the current buffer is named `F', the version is named `F.~REV~'.
1031 If `F.~REV~' already exists, it is used instead of being re-created." 1211 If `F.~REV~' already exists, it is used instead of being re-created."
1032 (interactive "sVersion to visit (default is latest version): ") 1212 (interactive "sVersion to visit (default is latest version): ")
1033 (if vc-dired-mode 1213 (if vc-dired-mode
1034 (set-buffer (find-file-noselect (dired-get-filename)))) 1214 (set-buffer (find-file-noselect (dired-get-filename))))
1035 (while vc-parent-buffer 1215 (while vc-parent-buffer
1036 (pop-to-buffer vc-parent-buffer)) 1216 (pop-to-buffer vc-parent-buffer))
1037 (if (and buffer-file-name (vc-name buffer-file-name)) 1217 (if (and buffer-file-name (vc-name buffer-file-name))
1038 (let* ((version (if (string-equal rev "") 1218 (let* ((version (if (string-equal rev "")
1039 (vc-latest-version buffer-file-name) 1219 (vc-latest-version buffer-file-name)
1040 rev)) 1220 rev))
1041 (filename (concat buffer-file-name ".~" version "~"))) 1221 (filename (concat buffer-file-name ".~" version "~")))
1042 (or (file-exists-p filename) 1222 (or (file-exists-p filename)
1043 (vc-backend-checkout buffer-file-name nil version filename)) 1223 (vc-backend-checkout buffer-file-name nil version filename))
1044 (find-file-other-window filename)) 1224 (find-file-other-window filename))
1045 (vc-registration-error buffer-file-name))) 1225 (vc-registration-error buffer-file-name)))
1046 1226
1047 ;; Header-insertion code 1227 ;; Header-insertion code
1048 1228
1049 ;;;###autoload 1229 ;;;###autoload
1053 the variable `vc-header-alist'." 1233 the variable `vc-header-alist'."
1054 (interactive) 1234 (interactive)
1055 (if vc-dired-mode 1235 (if vc-dired-mode
1056 (find-file-other-window (dired-get-filename))) 1236 (find-file-other-window (dired-get-filename)))
1057 (while vc-parent-buffer 1237 (while vc-parent-buffer
1058 (pop-to-buffer vc-parent-buffer)) 1238 (pop-to-buffer vc-parent-buffer))
1059 (save-excursion 1239 (save-excursion
1060 (save-restriction 1240 (save-restriction
1061 (widen) 1241 (widen)
1062 (if (or (not (vc-check-headers)) 1242 (if (or (not (vc-check-headers))
1063 (y-or-n-p "Version headers already exist. Insert another set? ")) 1243 (y-or-n-p "Version headers already exist. Insert another set? "))
1064 (progn 1244 (progn
1065 (let* ((delims (cdr (assq major-mode vc-comment-alist))) 1245 (let* ((delims (cdr (assq major-mode vc-comment-alist)))
1066 (comment-start-vc (or (car delims) comment-start "#")) 1246 (comment-start-vc (or (car delims) comment-start "#"))
1067 (comment-end-vc (or (car (cdr delims)) comment-end "")) 1247 (comment-end-vc (or (car (cdr delims)) comment-end ""))
1068 (hdstrings (cdr (assoc (vc-backend-deduce buffer-file-name) 1248 (hdstrings (cdr (assoc (vc-backend (buffer-file-name)) vc-header-alist))))
1069 vc-header-alist)))) 1249 (mapcar (function (lambda (s)
1070 (mapcar #'(lambda (s) 1250 (insert comment-start-vc "\t" s "\t"
1071 (insert comment-start-vc "\t" s "\t" 1251 comment-end-vc "\n")))
1072 comment-end-vc "\n"))
1073 hdstrings) 1252 hdstrings)
1074 (if vc-static-header-alist 1253 (if vc-static-header-alist
1075 (mapcar #'(lambda (f) 1254 (mapcar (function (lambda (f)
1076 (if (and buffer-file-name 1255 (if (string-match (car f) buffer-file-name)
1077 (string-match (car f) buffer-file-name)) 1256 (insert (format (cdr f) (car hdstrings))))))
1078 (insert (format (cdr f) (car hdstrings)))))
1079 vc-static-header-alist)) 1257 vc-static-header-alist))
1080 ) 1258 )
1081 ))))) 1259 )))))
1082 1260
1083 ;; The VC directory submode. Coopt Dired for this. 1261 (defun vc-clear-headers ()
1262 ;; Clear all version headers in the current buffer, i.e. reset them
1263 ;; to the nonexpanded form. Only implemented for RCS, yet.
1264 ;; Don't lose point and mark during this.
1265 (let ((context (vc-buffer-context)))
1266 (goto-char (point-min))
1267 (while (re-search-forward "\\$\\([A-Za-z]+\\): [^\\$]+\\$" nil t)
1268 (replace-match "$\\1$"))
1269 (vc-restore-buffer-context context)))
1270
1271 ;; The VC directory major mode. Coopt Dired for this.
1084 ;; All VC commands get mapped into logical equivalents. 1272 ;; All VC commands get mapped into logical equivalents.
1085 1273
1086 ;; XEmacs 1274 (define-derived-mode vc-dired-mode dired-mode "Dired under VC"
1087 (defvar vc-dired-prefix-map (let ((map (make-sparse-keymap))) 1275 "The major mode used in VC directory buffers. It is derived from Dired.
1088 (set-keymap-name map 'vc-dired-prefix-map)
1089 (define-key map "\C-xv" vc-prefix-map)
1090 map))
1091
1092 (or (not (boundp 'minor-mode-map-alist))
1093 (assq 'vc-dired-mode minor-mode-map-alist)
1094 (setq minor-mode-map-alist
1095 (cons (cons 'vc-dired-mode vc-dired-prefix-map)
1096 minor-mode-map-alist)))
1097
1098 (defun vc-dired-mode ()
1099 "The augmented Dired minor mode used in VC directory buffers.
1100 All Dired commands operate normally. Users currently locking listed files 1276 All Dired commands operate normally. Users currently locking listed files
1101 are listed in place of the file's owner and group. 1277 are listed in place of the file's owner and group.
1102 Keystrokes bound to VC commands will execute as though they had been called 1278 Keystrokes bound to VC commands will execute as though they had been called
1103 on a buffer attached to the file named in the current Dired buffer line." 1279 on a buffer attached to the file named in the current Dired buffer line."
1104 (setq vc-dired-mode t) 1280 (setq vc-dired-mode t))
1105 (setq vc-mode " under VC")) 1281
1282 (define-key vc-dired-mode-map "\C-xv" vc-prefix-map)
1283 (define-key vc-dired-mode-map "g" 'vc-dired-update)
1284 (define-key vc-dired-mode-map "=" 'vc-diff)
1285
1286 (defun vc-dired-state-info (file)
1287 ;; Return the string that indicates the version control status
1288 ;; on a VC dired line.
1289 (let ((cvs-state (and (eq (vc-backend file) 'CVS)
1290 (vc-cvs-status file))))
1291 (if cvs-state
1292 (cond ((eq cvs-state 'up-to-date) nil)
1293 ((eq cvs-state 'needs-checkout) "patch")
1294 ((eq cvs-state 'locally-modified) "modified")
1295 ((eq cvs-state 'needs-merge) "merge")
1296 ((eq cvs-state 'unresolved-conflict) "conflict")
1297 ((eq cvs-state 'locally-added) "added"))
1298 (vc-locking-user file))))
1106 1299
1107 (defun vc-dired-reformat-line (x) 1300 (defun vc-dired-reformat-line (x)
1108 ;; Hack a directory-listing line, plugging in locking-user info in 1301 ;; Hack a directory-listing line, plugging in locking-user info in
1109 ;; place of the user and group info. Should have the beneficial 1302 ;; place of the user and group info. Should have the beneficial
1110 ;; side-effect of shortening the listing line. Each call starts with 1303 ;; side-effect of shortening the listing line. Each call starts with
1113 ;; 1306 ;;
1114 ;; Simplest possible one: 1307 ;; Simplest possible one:
1115 ;; (insert (concat x "\t"))) 1308 ;; (insert (concat x "\t")))
1116 ;; 1309 ;;
1117 ;; This code, like dired, assumes UNIX -l format. 1310 ;; This code, like dired, assumes UNIX -l format.
1118 (forward-word 1) ; skip over any extra field due to -ibs options 1311 (let ((pos (point)) limit perm owner date-and-file)
1119 (cond ((numberp x) ; This hack is used by the CVS code. See vc-locking-user. 1312 (end-of-line)
1120 (cond 1313 (setq limit (point))
1121 ((re-search-forward "\\([0-9]+ \\)\\([^ ]+\\)\\( .*\\)" nil 0) 1314 (goto-char pos)
1122 (save-excursion 1315 (cond
1123 (goto-char (match-beginning 2)) 1316 ((or
1124 (insert "(") 1317 (re-search-forward ;; owner and group
1125 (goto-char (1+ (match-end 2))) 1318 "\\([drwxlts-]+ \\) *[0-9]+ \\([^ ]+\\) +[^ ]+ +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)"
1126 (insert ")") 1319 limit t)
1127 (delete-char (- 17 (- (match-end 2) (match-beginning 2)))) 1320 (re-search-forward ;; only owner displayed
1128 (insert (substring " " 0 1321 "\\([drwxlts-]+ \\) *[0-9]+ \\([^ ]+\\) +[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)"
1129 (- 7 (- (match-end 2) (match-beginning 2))))))))) 1322 limit t))
1130 (t 1323 (setq perm (match-string 1)
1131 (if x (setq x (concat "(" x ")"))) 1324 owner (match-string 2)
1132 (if (re-search-forward "\\([0-9]+ \\).................\\( .*\\)" nil 0) 1325 date-and-file (match-string 3)))
1133 (let ((rep (substring (concat x " ") 0 9))) 1326 ((re-search-forward ;; OS/2 -l format, no links, owner, group
1134 (replace-match (concat "\\1" rep "\\2") t))) 1327 "\\([drwxlts-]+ \\) *[0-9]+\\( [^ 0-9]+ [0-9 ][0-9] .*\\)"
1135 ))) 1328 limit t)
1136 1329 (setq perm (match-string 1)
1330 date-and-file (match-string 2))))
1331 (if x (setq x (concat "(" x ")")))
1332 (let ((rep (substring (concat x " ") 0 10)))
1333 (replace-match (concat perm rep date-and-file)))))
1334
1335 (defun vc-dired-update-line (file)
1336 ;; Update the vc-dired listing line of file -- it is assumed
1337 ;; that point is already on this line. Don't use dired-do-redisplay
1338 ;; for this, because it cannot handle the way vc-dired deals with
1339 ;; subdirectories.
1340 (beginning-of-line)
1341 (forward-char 2)
1342 (let ((start (point)))
1343 (forward-line 1)
1344 (beginning-of-line)
1345 (delete-region start (point))
1346 (insert-directory file dired-listing-switches)
1347 (forward-line -1)
1348 (end-of-line)
1349 (delete-char (- (length file)))
1350 (insert (substring file (length (expand-file-name default-directory))))
1351 (goto-char start))
1352 (vc-dired-reformat-line (vc-dired-state-info file)))
1353
1354 (defun vc-dired-update (verbose)
1355 (interactive "P")
1356 (vc-directory default-directory verbose))
1357
1358 ;;; Note in Emacs 18 the following defun gets overridden
1359 ;;; with the symbol 'vc-directory-18. See below.
1137 ;;;###autoload 1360 ;;;###autoload
1138 (defun vc-directory (dir verbose &optional nested) 1361 (defun vc-directory (dirname verbose)
1139 "Show version-control status of all files in the directory DIR. 1362 "Show version-control status of the current directory and subdirectories.
1140 If the second argument VERBOSE is non-nil, show all files; 1363 Normally it creates a Dired buffer that lists only the locked files
1141 otherwise show only files that current locked in the version control system. 1364 in all these directories. With a prefix argument, it lists all files."
1142 Interactively, supply a prefix arg to make VERBOSE non-nil. 1365 (interactive "DDired under VC (directory): \nP")
1143 1366 (require 'dired)
1144 If the optional third argument NESTED is non-nil, 1367 (setq dirname (expand-file-name dirname))
1145 scan the entire tree of subdirectories of the current directory." 1368 ;; force a trailing slash
1146 (interactive "DVC status of directory: \nP") 1369 (if (not (eq (elt dirname (1- (length dirname))) ?/))
1147 (let* (nonempty 1370 (setq dirname (concat dirname "/")))
1148 (dl (+ 1 (length (directory-file-name (expand-file-name dir))))) 1371 (let (nonempty
1149 (filelist nil) (userlist nil) 1372 (dl (if (featurep 'xemacs)
1150 dired-buf 1373 (+ 1 (length (directory-file-name (expand-file-name dir))))
1151 (subfunction 1374 (length dirname)))
1152 (function (lambda (f) 1375 (filelist nil) (statelist nil)
1153 (if (vc-registered f) 1376 (old-dir default-directory)
1154 (let ((user (vc-locking-user f))) 1377 dired-buf
1155 (and (or verbose user) 1378 dired-buf-mod-count)
1156 (setq filelist (cons (substring f dl) filelist)) 1379 (vc-file-tree-walk
1157 (setq userlist (cons user userlist))))))))) 1380 dirname
1158 (let ((default-directory (expand-file-name dir))) 1381 (function
1159 (if nested 1382 (lambda (f)
1160 (vc-file-tree-walk subfunction) 1383 (if (vc-registered f)
1161 (vc-dir-all-files subfunction))) 1384 (let ((state (vc-dired-state-info f)))
1162 (save-excursion 1385 (and (or verbose state)
1163 (dired (cons dir (nreverse filelist)) 1386 (setq filelist (cons (substring f dl) filelist))
1164 dired-listing-switches) 1387 (setq statelist (cons state statelist))))))))
1165 (rename-buffer (generate-new-buffer-name "VC-DIRED")) 1388 (save-window-excursion
1166 (setq dired-buf (current-buffer)) 1389 (save-excursion
1167 (setq nonempty (not (zerop (buffer-size))))) 1390 ;; This uses a semi-documented feature of dired; giving a switch
1391 ;; argument forces the buffer to refresh each time.
1392 (setq dired-buf
1393 (dired-internal-noselect
1394 (cons dirname (nreverse filelist))
1395 dired-listing-switches 'vc-dired-mode))
1396 (setq nonempty (not (eq 0 (length filelist))))))
1397 (switch-to-buffer dired-buf)
1398 ;; Make a few modifications to the header
1399 (setq buffer-read-only nil)
1400 (goto-char (point-min))
1401 (forward-line 1) ;; Skip header line
1402 (let ((start (point))) ;; Erase (but don't remove) the
1403 (end-of-line) ;; "wildcard" line.
1404 (delete-region start (point)))
1405 (beginning-of-line)
1168 (if nonempty 1406 (if nonempty
1169 (progn 1407 (progn
1170 (pop-to-buffer dired-buf) 1408 ;; Plug the version information into the individual lines
1171 (vc-dired-mode)
1172 (goto-char (point-min))
1173 (setq buffer-read-only nil)
1174 (forward-line 1) ; Skip header line
1175 (mapcar 1409 (mapcar
1176 (function 1410 (function
1177 (lambda (x) 1411 (lambda (x)
1178 (forward-char 2) ; skip dired's mark area 1412 (forward-char 2) ;; skip dired's mark area
1179 (vc-dired-reformat-line x) 1413 (vc-dired-reformat-line x)
1180 (forward-line 1))) ; go to next line 1414 (forward-line 1))) ;; go to next line
1181 (nreverse userlist)) 1415 (nreverse statelist))
1182 (dired-insert-set-properties (point-min) (point-max)) 1416 (if (featurep 'xemacs)
1417 (dired-insert-set-properties (point-min) (point-max)))
1183 (setq buffer-read-only t) 1418 (setq buffer-read-only t)
1184 (goto-char (point-min)) 1419 (goto-char (point-min))
1420 (dired-next-line 2)
1185 ) 1421 )
1422 (dired-next-line 1)
1423 (insert " ")
1424 (setq buffer-read-only t)
1425 (message "No files are currently %s under %s"
1426 (if verbose "registered" "locked") dirname))
1427 ))
1428
1429 ;; Emacs 18 version
1430 (defun vc-directory-18 (verbose)
1431 "Show version-control status of all files under the current directory."
1432 (interactive "P")
1433 (let (nonempty (dir default-directory))
1434 (save-excursion
1435 (set-buffer (get-buffer-create "*vc-status*"))
1436 (erase-buffer)
1437 (cd dir)
1438 (vc-file-tree-walk
1439 default-directory
1440 (function (lambda (f)
1441 (if (vc-registered f)
1442 (let ((user (vc-locking-user f)))
1443 (if (or user verbose)
1444 (insert (format
1445 "%s %s\n"
1446 (concat user) f))))))))
1447 (setq nonempty (not (zerop (buffer-size)))))
1448
1449 (if nonempty
1450 (progn
1451 (pop-to-buffer "*vc-status*" t)
1452 (goto-char (point-min))
1453 (shrink-window-if-larger-than-buffer)))
1186 (message "No files are currently %s under %s" 1454 (message "No files are currently %s under %s"
1187 (if verbose "registered" "locked") default-directory)) 1455 (if verbose "registered" "locked") default-directory))
1188 )) 1456 )
1189 1457
1190 (defun make-string-stringlist (stringlist) 1458 (or (boundp 'minor-mode-map-alist)
1191 "Turn a list of strings into a string of space-delimited elements." 1459 (fset 'vc-directory 'vc-directory-18))
1192 (save-excursion
1193 (let ((tlist stringlist)
1194 (buf (generate-new-buffer "*stringlist*")))
1195 (set-buffer buf)
1196 (insert (car tlist))
1197 (setq tlist (cdr tlist))
1198 (while (not (null tlist))
1199 (setq s (car tlist))
1200 (insert s)
1201 (if (cdr tlist) (insert " "))
1202 (setq tlist (cdr tlist)))
1203 (setq string (buffer-string))
1204 (kill-this-buffer)
1205 string
1206 )))
1207 1460
1208 ;; Named-configuration support for SCCS 1461 ;; Named-configuration support for SCCS
1209 1462
1210 (defun vc-add-triple (name file rev) 1463 (defun vc-add-triple (name file rev)
1211 (save-excursion 1464 (save-excursion
1212 (find-file (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file)) 1465 (find-file (expand-file-name
1466 vc-name-assoc-file
1467 (file-name-as-directory
1468 (expand-file-name (vc-backend-subdirectory-name file)
1469 (file-name-directory file)))))
1213 (goto-char (point-max)) 1470 (goto-char (point-max))
1214 (insert name "\t:\t" file "\t" rev "\n") 1471 (insert name "\t:\t" file "\t" rev "\n")
1215 (basic-save-buffer) 1472 (basic-save-buffer)
1216 (kill-buffer (current-buffer)) 1473 (kill-buffer (current-buffer))
1217 )) 1474 ))
1218 1475
1219 (defun vc-record-rename (file newname) 1476 (defun vc-record-rename (file newname)
1220 (save-excursion 1477 (save-excursion
1221 (find-file (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file)) 1478 (find-file
1479 (expand-file-name
1480 vc-name-assoc-file
1481 (file-name-as-directory
1482 (expand-file-name (vc-backend-subdirectory-name file)
1483 (file-name-directory file)))))
1222 (goto-char (point-min)) 1484 (goto-char (point-min))
1223 ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname)) 1485 ;; (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname))
1224 (while (re-search-forward (concat ":" (regexp-quote file) "$") nil t) 1486 (while (re-search-forward (concat ":" (regexp-quote file) "$") nil t)
1225 (replace-match (concat ":" newname) nil nil)) 1487 (replace-match (concat ":" newname) nil nil))
1226 (basic-save-buffer) 1488 (basic-save-buffer)
1233 (cond ((null name) name) 1495 (cond ((null name) name)
1234 ((let ((firstchar (aref name 0))) 1496 ((let ((firstchar (aref name 0)))
1235 (and (>= firstchar ?0) (<= firstchar ?9))) 1497 (and (>= firstchar ?0) (<= firstchar ?9)))
1236 name) 1498 name)
1237 (t 1499 (t
1238 (car (vc-master-info 1500 (save-excursion
1239 (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file) 1501 (set-buffer (get-buffer-create "*vc-info*"))
1240 (list (concat name "\t:\t" file "\t\\(.+\\)")))) 1502 (vc-insert-file
1241 ))) 1503 (expand-file-name
1504 vc-name-assoc-file
1505 (file-name-as-directory
1506 (expand-file-name (vc-backend-subdirectory-name file)
1507 (file-name-directory file)))))
1508 (prog1
1509 (car (vc-parse-buffer
1510 (list (list (concat name "\t:\t" file "\t\\(.+\\)") 1))))
1511 (kill-buffer "*vc-info*"))))
1512 ))
1242 1513
1243 ;; Named-configuration entry points 1514 ;; Named-configuration entry points
1244 1515
1245 (defun vc-locked-example () 1516 (defun vc-snapshot-precondition ()
1246 ;; Return an example of why the current directory is not ready to be snapshot 1517 ;; Scan the tree below the current directory.
1247 ;; or nil if no such example exists. 1518 ;; If any files are locked, return the name of the first such file.
1248 (catch 'vc-locked-example 1519 ;; (This means, neither snapshot creation nor retrieval is allowed.)
1249 (vc-file-tree-walk 1520 ;; If one or more of the files are currently visited, return `visited'.
1250 (function (lambda (f) 1521 ;; Otherwise, return nil.
1251 (if (and (vc-registered f) (vc-locking-user f)) 1522 (let ((status nil))
1252 (throw 'vc-locked-example f))))) 1523 (catch 'vc-locked-example
1253 nil)) 1524 (vc-file-tree-walk
1525 default-directory
1526 (function (lambda (f)
1527 (and (vc-registered f)
1528 (if (vc-locking-user f) (throw 'vc-locked-example f)
1529 (if (get-file-buffer f) (setq status 'visited)))))))
1530 status)))
1254 1531
1255 ;;;###autoload 1532 ;;;###autoload
1256 (defun vc-create-snapshot (name) 1533 (defun vc-create-snapshot (name)
1257 "Make a snapshot called NAME. 1534 "Make a snapshot called NAME.
1258 The snapshot is made from all registered files at or below the current 1535 The snapshot is made from all registered files at or below the current
1259 directory. For each file, the version level of its latest 1536 directory. For each file, the version level of its latest
1260 version becomes part of the named configuration." 1537 version becomes part of the named configuration."
1261 (interactive "sNew snapshot name: ") 1538 (interactive "sNew snapshot name: ")
1262 (let ((locked (vc-locked-example))) 1539 (let ((result (vc-snapshot-precondition)))
1263 (if locked 1540 (if (stringp result)
1264 (error "File %s is locked" locked) 1541 (error "File %s is locked" result)
1265 (vc-file-tree-walk 1542 (vc-file-tree-walk
1543 default-directory
1266 (function (lambda (f) (and 1544 (function (lambda (f) (and
1267 (vc-name f) 1545 (vc-name f)
1268 (vc-backend-assign-name f name))))) 1546 (vc-backend-assign-name f name)))))
1269 ))) 1547 )))
1270 1548
1273 "Retrieve the snapshot called NAME. 1551 "Retrieve the snapshot called NAME.
1274 This function fails if any files are locked at or below the current directory 1552 This function fails if any files are locked at or below the current directory
1275 Otherwise, all registered files are checked out (unlocked) at their version 1553 Otherwise, all registered files are checked out (unlocked) at their version
1276 levels in the snapshot." 1554 levels in the snapshot."
1277 (interactive "sSnapshot name to retrieve: ") 1555 (interactive "sSnapshot name to retrieve: ")
1278 (let ((locked (vc-locked-example))) 1556 (let ((result (vc-snapshot-precondition))
1279 (if locked 1557 (update nil))
1280 (error "File %s is locked" locked) 1558 (if (stringp result)
1559 (error "File %s is locked" result)
1560 (if (eq result 'visited)
1561 (setq update (yes-or-no-p "Update the affected buffers? ")))
1281 (vc-file-tree-walk 1562 (vc-file-tree-walk
1563 default-directory
1282 (function (lambda (f) (and 1564 (function (lambda (f) (and
1283 (vc-name f) 1565 (vc-name f)
1284 (vc-error-occurred 1566 (vc-error-occurred
1285 (vc-backend-checkout f nil name)))))) 1567 (vc-backend-checkout f nil name)
1568 (if update (vc-resynch-buffer f t t)))))))
1286 ))) 1569 )))
1287 1570
1288 ;; Miscellaneous other entry points 1571 ;; Miscellaneous other entry points
1289 1572
1290 ;;;###autoload 1573 ;;;###autoload
1292 "List the change log of the current buffer in a window." 1575 "List the change log of the current buffer in a window."
1293 (interactive) 1576 (interactive)
1294 (if vc-dired-mode 1577 (if vc-dired-mode
1295 (set-buffer (find-file-noselect (dired-get-filename)))) 1578 (set-buffer (find-file-noselect (dired-get-filename))))
1296 (while vc-parent-buffer 1579 (while vc-parent-buffer
1297 (pop-to-buffer vc-parent-buffer)) 1580 (pop-to-buffer vc-parent-buffer))
1298 (if (and buffer-file-name (vc-name buffer-file-name)) 1581 (if (and buffer-file-name (vc-name buffer-file-name))
1299 (let ((file buffer-file-name)) 1582 (let ((file buffer-file-name))
1300 (vc-backend-print-log file) 1583 (vc-backend-print-log file)
1301 (pop-to-buffer (get-buffer-create "*vc*")) 1584 (pop-to-buffer (get-buffer-create "*vc*"))
1302 (setq default-directory (file-name-directory file)) 1585 (setq default-directory (file-name-directory file))
1586 (goto-char (point-max)) (forward-line -1)
1303 (while (looking-at "=*\n") 1587 (while (looking-at "=*\n")
1304 (delete-char (- (match-end 0) (match-beginning 0))) 1588 (delete-char (- (match-end 0) (match-beginning 0)))
1305 (forward-line -1)) 1589 (forward-line -1))
1306 (goto-char (point-min)) 1590 (goto-char (point-min))
1307 (if (looking-at "[\b\t\n\v\f\r ]+") 1591 (if (looking-at "[\b\t\n\v\f\r ]+")
1308 (delete-char (- (match-end 0) (match-beginning 0)))) 1592 (delete-char (- (match-end 0) (match-beginning 0))))
1309 (shrink-window-if-larger-than-buffer) 1593 (shrink-window-if-larger-than-buffer)
1594 ;; move point to the log entry for the current version
1595 (and (not (eq (vc-backend file) 'SCCS))
1596 (re-search-forward
1597 ;; also match some context, for safety
1598 (concat "----\nrevision " (vc-workfile-version file)
1599 "\\(\tlocked by:.*\n\\|\n\\)date: ") nil t)
1600 ;; set the display window so that
1601 ;; the whole log entry is displayed
1602 (let (start end lines)
1603 (beginning-of-line) (forward-line -1) (setq start (point))
1604 (if (not (re-search-forward "^----*\nrevision" nil t))
1605 (setq end (point-max))
1606 (beginning-of-line) (forward-line -1) (setq end (point)))
1607 (setq lines (count-lines start end))
1608 (cond
1609 ;; if the global information and this log entry fit
1610 ;; into the window, display from the beginning
1611 ((< (count-lines (point-min) end) (window-height))
1612 (goto-char (point-min))
1613 (recenter 0)
1614 (goto-char start))
1615 ;; if the whole entry fits into the window,
1616 ;; display it centered
1617 ((< (1+ lines) (window-height))
1618 (goto-char start)
1619 (recenter (1- (- (/ (window-height) 2) (/ lines 2)))))
1620 ;; otherwise (the entry is too large for the window),
1621 ;; display from the start
1622 (t
1623 (goto-char start)
1624 (recenter 0)))))
1310 ) 1625 )
1311 (vc-registration-error buffer-file-name))) 1626 (vc-registration-error buffer-file-name)
1627 )
1628 )
1312 1629
1313 ;;;###autoload 1630 ;;;###autoload
1314 (defun vc-revert-buffer () 1631 (defun vc-revert-buffer ()
1315 "Revert the current buffer's file back to the latest checked-in version. 1632 "Revert the current buffer's file back to the latest checked-in version.
1316 This asks for confirmation if the buffer contents are not identical 1633 This asks for confirmation if the buffer contents are not identical
1319 the file on the branch you are editing." 1636 the file on the branch you are editing."
1320 (interactive) 1637 (interactive)
1321 (if vc-dired-mode 1638 (if vc-dired-mode
1322 (find-file-other-window (dired-get-filename))) 1639 (find-file-other-window (dired-get-filename)))
1323 (while vc-parent-buffer 1640 (while vc-parent-buffer
1324 (pop-to-buffer vc-parent-buffer)) 1641 (pop-to-buffer vc-parent-buffer))
1325 (let ((file buffer-file-name) 1642 (let ((file buffer-file-name)
1643 ;; This operation should always ask for confirmation.
1644 (vc-suppress-confirm nil)
1326 (obuf (current-buffer)) (changed (vc-diff nil t))) 1645 (obuf (current-buffer)) (changed (vc-diff nil t)))
1327 (if (and changed (or vc-suppress-confirm 1646 (if (and changed (not (yes-or-no-p "Discard changes? ")))
1328 (not (yes-or-no-p "Discard changes? "))))
1329 (progn 1647 (progn
1330 (delete-window) 1648 (if (and (window-dedicated-p (selected-window))
1649 (one-window-p t 'selected-frame))
1650 (make-frame-invisible (selected-frame))
1651 (delete-window))
1331 (error "Revert cancelled")) 1652 (error "Revert cancelled"))
1332 (set-buffer obuf)) 1653 (set-buffer obuf))
1333 (if changed 1654 (if changed
1334 (delete-window)) 1655 (if (and (window-dedicated-p (selected-window))
1656 (one-window-p t 'selected-frame))
1657 (make-frame-invisible (selected-frame))
1658 (delete-window)))
1335 (vc-backend-revert file) 1659 (vc-backend-revert file)
1336 (vc-resynch-window file t t) 1660 (vc-resynch-window file t t)
1337 )) 1661 )
1662 )
1338 1663
1339 ;;;###autoload 1664 ;;;###autoload
1340 (defun vc-cancel-version (norevert) 1665 (defun vc-cancel-version (norevert)
1341 "Get rid of most recently checked in version of this file. 1666 "Get rid of most recently checked in version of this file.
1342 A prefix argument means do not revert the buffer afterwards." 1667 A prefix argument means do not revert the buffer afterwards."
1343 (interactive "P") 1668 (interactive "P")
1344 (if vc-dired-mode 1669 (if vc-dired-mode
1345 (find-file-other-window (dired-get-filename))) 1670 (find-file-other-window (dired-get-filename)))
1346 (while vc-parent-buffer 1671 (while vc-parent-buffer
1347 (pop-to-buffer vc-parent-buffer)) 1672 (pop-to-buffer vc-parent-buffer))
1348 (let* ((target (concat (vc-latest-version (buffer-file-name)))) 1673 (cond
1349 (yours (concat (vc-your-latest-version (buffer-file-name)))) 1674 ((not (vc-registered (buffer-file-name)))
1350 (prompt (if (string-equal yours target) 1675 (vc-registration-error (buffer-file-name)))
1351 "Remove your version %s from master? " 1676 ((eq (vc-backend (buffer-file-name)) 'CVS)
1352 "Version %s was not your change. Remove it anyway? "))) 1677 (error "Unchecking files under CVS is dangerous and not supported in VC"))
1353 (if (null (yes-or-no-p (format prompt target))) 1678 ((vc-locking-user (buffer-file-name))
1679 (error "This version is locked; use vc-revert-buffer to discard changes"))
1680 ((not (vc-latest-on-branch-p (buffer-file-name)))
1681 (error "This is not the latest version--VC cannot cancel it")))
1682 (let* ((target (vc-workfile-version (buffer-file-name)))
1683 (recent (if (vc-trunk-p target) "" (vc-branch-part target)))
1684 (config (current-window-configuration)) done)
1685 (if (null (yes-or-no-p (format "Remove version %s from master? " target)))
1354 nil 1686 nil
1687 (setq norevert (or norevert (not
1688 (yes-or-no-p "Revert buffer to most recent remaining version? "))))
1355 (vc-backend-uncheck (buffer-file-name) target) 1689 (vc-backend-uncheck (buffer-file-name) target)
1356 (if (or norevert 1690 ;; Check out the most recent remaining version. If it fails, because
1357 (not (yes-or-no-p "Revert buffer to most recent remaining version? "))) 1691 ;; the whole branch got deleted, do a double-take and check out the
1358 (vc-mode-line (buffer-file-name)) 1692 ;; version where the branch started.
1359 (vc-checkout (buffer-file-name) nil))) 1693 (while (not done)
1360 )) 1694 (condition-case err
1695 (progn
1696 (if norevert
1697 ;; Check out locked, but only to disc, and keep
1698 ;; modifications in the buffer.
1699 (vc-backend-checkout (buffer-file-name) t recent)
1700 ;; Check out unlocked, and revert buffer.
1701 (vc-checkout (buffer-file-name) nil recent))
1702 (setq done t))
1703 ;; If the checkout fails, vc-do-command signals an error.
1704 ;; We catch this error, check the reason, correct the
1705 ;; version number, and try a second time.
1706 (error (set-buffer "*vc*")
1707 (goto-char (point-min))
1708 (if (search-forward "no side branches present for" nil t)
1709 (progn (setq recent (vc-branch-part recent))
1710 ;; vc-do-command popped up a window with
1711 ;; the error message. Get rid of it, by
1712 ;; restoring the old window configuration.
1713 (set-window-configuration config))
1714 ;; No, it was some other error: re-signal it.
1715 (signal (car err) (cdr err))))))
1716 ;; If norevert, clear version headers and mark the buffer modified.
1717 (if norevert
1718 (progn
1719 (set-visited-file-name (buffer-file-name))
1720 (if (not vc-make-backup-files)
1721 ;; inhibit backup for this buffer
1722 (progn (make-local-variable 'backup-inhibited)
1723 (setq backup-inhibited t)))
1724 (if (eq (vc-backend (buffer-file-name)) 'RCS)
1725 (progn (setq buffer-read-only nil)
1726 (vc-clear-headers)))
1727 (vc-mode-line (buffer-file-name))))
1728 (message "Version %s has been removed from the master" target)
1729 )))
1361 1730
1362 ;;;###autoload 1731 ;;;###autoload
1363 (defun vc-rename-file (old new) 1732 (defun vc-rename-file (old new)
1364 "Rename file OLD to NEW, and rename its master file likewise." 1733 "Rename file OLD to NEW, and rename its master file likewise."
1365 (interactive "fVC rename file: \nFRename to: ") 1734 (interactive "fVC rename file: \nFRename to: ")
1367 ;; have serious disadvantages. See the FAQ (available from think.com in 1736 ;; have serious disadvantages. See the FAQ (available from think.com in
1368 ;; pub/cvs/). I'd rather send the user an error, than do something he might 1737 ;; pub/cvs/). I'd rather send the user an error, than do something he might
1369 ;; consider to be wrong. When the famous, long-awaited rename database is 1738 ;; consider to be wrong. When the famous, long-awaited rename database is
1370 ;; implemented things might change for the better. This is unlikely to occur 1739 ;; implemented things might change for the better. This is unlikely to occur
1371 ;; until CVS 2.0 is released. --ceder 1994-01-23 21:27:51 1740 ;; until CVS 2.0 is released. --ceder 1994-01-23 21:27:51
1372 (if (eq (vc-backend-deduce old) 'CVS) 1741 (if (eq (vc-backend old) 'CVS)
1373 (error "Renaming files under CVS is dangerous and not supported in VC.")) 1742 (error "Renaming files under CVS is dangerous and not supported in VC"))
1374 (if (eq (vc-backend-deduce old) 'CC)
1375 (error "VC's ClearCase support cannot rename files."))
1376 (let ((oldbuf (get-file-buffer old))) 1743 (let ((oldbuf (get-file-buffer old)))
1377 (if (and oldbuf (buffer-modified-p oldbuf)) 1744 (if (and oldbuf (buffer-modified-p oldbuf))
1378 (error "Please save files before moving them")) 1745 (error "Please save files before moving them"))
1379 (if (get-file-buffer new) 1746 (if (get-file-buffer new)
1380 (error "Already editing new file name")) 1747 (error "Already editing new file name"))
1381 (if (file-exists-p new) 1748 (if (file-exists-p new)
1382 (error "New file already exists")) 1749 (error "New file already exists"))
1383 (let ((oldmaster (vc-name old))) 1750 (let ((oldmaster (vc-name old)))
1384 (if oldmaster 1751 (if oldmaster
1385 (progn 1752 (progn
1386 (if (vc-locking-user old) 1753 (if (vc-locking-user old)
1387 (error "Please check in files before moving them")) 1754 (error "Please check in files before moving them"))
1388 (if (or (file-symlink-p oldmaster) 1755 (if (or (file-symlink-p oldmaster)
1389 ;; This had FILE, I changed it to OLD. -- rms. 1756 ;; This had FILE, I changed it to OLD. -- rms.
1390 (file-symlink-p (vc-backend-subdirectory-name old))) 1757 (file-symlink-p (vc-backend-subdirectory-name old)))
1391 (error "This is not a safe thing to do in the presence of symbolic links")) 1758 (error "This is not a safe thing to do in the presence of symbolic links"))
1392 (rename-file 1759 (rename-file
1393 oldmaster 1760 oldmaster
1394 (let ((backend (vc-backend-deduce old)) 1761 (let ((backend (vc-backend old))
1395 (newdir (or (file-name-directory new) "")) 1762 (newdir (or (file-name-directory new) ""))
1396 (newbase (file-name-nondirectory new))) 1763 (newbase (file-name-nondirectory new)))
1397 (catch 'found 1764 (catch 'found
1398 (mapcar 1765 (mapcar
1399 (function 1766 (function
1400 (lambda (s) 1767 (lambda (s)
1401 (if (eq backend (cdr s)) 1768 (if (eq backend (cdr s))
1402 (let* ((newmaster (format (car s) newdir newbase)) 1769 (let* ((newmaster (format (car s) newdir newbase))
1403 (newmasterdir (file-name-directory newmaster))) 1770 (newmasterdir (file-name-directory newmaster)))
1404 (if (or (not newmasterdir) 1771 (if (or (not newmasterdir)
1406 (throw 'found newmaster)))))) 1773 (throw 'found newmaster))))))
1407 vc-master-templates) 1774 vc-master-templates)
1408 (error "New file lacks a version control directory")))))) 1775 (error "New file lacks a version control directory"))))))
1409 (if (or (not oldmaster) (file-exists-p old)) 1776 (if (or (not oldmaster) (file-exists-p old))
1410 (rename-file old new))) 1777 (rename-file old new)))
1411 ;; ?? Renaming a file might change its contents due to keyword expansion. 1778 ; ?? Renaming a file might change its contents due to keyword expansion.
1412 ;; We should really check out a new copy if the old copy was precisely equal 1779 ; We should really check out a new copy if the old copy was precisely equal
1413 ;; to some checked in version. However, testing for this is tricky.... 1780 ; to some checked in version. However, testing for this is tricky....
1414 (if oldbuf 1781 (if oldbuf
1415 (save-excursion 1782 (save-excursion
1416 (set-buffer oldbuf) 1783 (set-buffer oldbuf)
1417 (set-visited-file-name new) 1784 (let ((buffer-read-only buffer-read-only))
1785 (set-visited-file-name new))
1786 (vc-backend new)
1787 (vc-mode-line new)
1418 (set-buffer-modified-p nil)))) 1788 (set-buffer-modified-p nil))))
1419 ;; This had FILE, I changed it to OLD. -- rms. 1789 ;; This had FILE, I changed it to OLD. -- rms.
1420 (vc-backend-dispatch old 1790 (vc-backend-dispatch old
1421 (vc-record-rename old new) ;SCCS 1791 (vc-record-rename old new) ;SCCS
1422 ;; #### - This CAN kinda be done for both rcs and 1792 nil ;RCS
1423 ;; cvs. It needs to be implemented. -- Stig 1793 nil ;CVS
1424 nil ;RCS 1794 )
1425 nil ;CVS
1426 nil ;CC
1427 )
1428 ) 1795 )
1429
1430 ;;;###autoload
1431 (defun vc-rename-this-file (new)
1432 (interactive "FVC rename file to: ")
1433 (vc-rename-file buffer-file-name new))
1434 1796
1435 ;;;###autoload 1797 ;;;###autoload
1436 (defun vc-update-change-log (&rest args) 1798 (defun vc-update-change-log (&rest args)
1437 "Find change log file and add entries from recent RCS logs. 1799 "Find change log file and add entries from recent RCS/CVS logs.
1800 Normally, find log entries for all registered files in the default
1801 directory using `rcs2log', which finds CVS logs preferentially.
1438 The mark is left at the end of the text prepended to the change log. 1802 The mark is left at the end of the text prepended to the change log.
1803
1439 With prefix arg of C-u, only find log entries for the current buffer's file. 1804 With prefix arg of C-u, only find log entries for the current buffer's file.
1440 With any numeric prefix arg, find log entries for all files currently visited. 1805
1441 Otherwise, find log entries for all registered files in the default directory. 1806 With any numeric prefix arg, find log entries for all currently visited
1442 From a program, any arguments are passed to the `rcs2log' script." 1807 files that are under version control. This puts all the entries in the
1808 log for the default directory, which may not be appropriate.
1809
1810 From a program, any arguments are assumed to be filenames and are
1811 passed to the `rcs2log' script after massaging to be relative to the
1812 default directory."
1443 (interactive 1813 (interactive
1444 (cond ((consp current-prefix-arg) ;C-u 1814 (cond ((consp current-prefix-arg) ;C-u
1445 (list buffer-file-name)) 1815 (list buffer-file-name))
1446 (current-prefix-arg ;Numeric argument. 1816 (current-prefix-arg ;Numeric argument.
1447 (let ((files nil) 1817 (let ((files nil)
1448 (buffers (buffer-list)) 1818 (buffers (buffer-list))
1449 file) 1819 file)
1450 (while buffers 1820 (while buffers
1451 (setq file (buffer-file-name (car buffers))) 1821 (setq file (buffer-file-name (car buffers)))
1452 (and file (vc-backend-deduce file) 1822 (and file (vc-backend file)
1453 (setq files (cons file files))) 1823 (setq files (cons file files)))
1454 (setq buffers (cdr buffers))) 1824 (setq buffers (cdr buffers)))
1455 files)) 1825 files))
1456 (t 1826 (t
1457 (let ((RCS (concat default-directory "RCS"))) 1827 ;; `rcs2log' will find the relevant RCS or CVS files
1458 (and (file-directory-p RCS) 1828 ;; relative to the curent directory if none supplied.
1459 (mapcar (function 1829 nil)))
1460 (lambda (f) 1830 (let ((odefault default-directory)
1461 (if (string-match "\\(.*\\),v$" f) 1831 (full-name (or add-log-full-name
1462 (substring f 0 (match-end 1)) 1832 (user-full-name)
1463 f))) 1833 (user-login-name)
1464 (directory-files RCS nil "...\\|^[^.]\\|^.[^.]"))))))) 1834 (format "uid%d" (number-to-string (user-uid)))))
1465 (let ((odefault default-directory)) 1835 (mailing-address (or add-log-mailing-address
1836 user-mail-address)))
1466 (find-file-other-window (find-change-log)) 1837 (find-file-other-window (find-change-log))
1467 (barf-if-buffer-read-only) 1838 (barf-if-buffer-read-only)
1468 (vc-buffer-sync) 1839 (vc-buffer-sync)
1469 (undo-boundary) 1840 (undo-boundary)
1470 (goto-char (point-min)) 1841 (goto-char (point-min))
1471 (push-mark) 1842 (push-mark)
1472 (message "Computing change log entries...") 1843 (message "Computing change log entries...")
1473 (message "Computing change log entries... %s" 1844 (message "Computing change log entries... %s"
1474 (if (or (null args) 1845 (if (eq 0 (apply 'call-process "rcs2log" nil '(t nil) nil
1475 (eq 0 (apply 'call-process "rcs2log" nil t nil 1846 "-u"
1476 "-n" 1847 (concat (vc-user-login-name)
1477 (user-login-name) 1848 "\t"
1478 (user-full-name) 1849 full-name
1479 user-mail-address 1850 "\t"
1480 (mapcar (function 1851 mailing-address)
1481 (lambda (f) 1852 (mapcar (function
1482 (file-relative-name 1853 (lambda (f)
1483 (if (file-name-absolute-p f) 1854 (file-relative-name
1484 f 1855 (if (file-name-absolute-p f)
1485 (concat odefault f))))) 1856 f
1486 args)))) 1857 (concat odefault f)))))
1858 args)))
1487 "done" "failed")))) 1859 "done" "failed"))))
1488 1860
1489 ;; Functions for querying the master and lock files.
1490
1491 ;; XEmacs - use match-string instead...
1492 ;; (defun vc-match-substring (bn)
1493 ;; (buffer-substring (match-beginning bn) (match-end bn)))
1494
1495 (defun vc-parse-buffer (patterns &optional file properties)
1496 ;; Each pattern is of the form:
1497 ;; regex ; subex is 1, and date-subex is 2 (or nil)
1498 ;; (regex subex date-subex)
1499 ;;
1500 ;; Use PATTERNS to parse information out of the current buffer by matching
1501 ;; each REGEX in the list and the returning the string matched by SUBEX.
1502 ;; If a DATE-SUBEX is present, then the SUBEX from the match with the
1503 ;; highest value for DATE-SUBEX (string comparison is used) will be
1504 ;; returned.
1505 ;;
1506 ;; If FILE and PROPERTIES are given, the latter must be a list of
1507 ;; properties of the same length as PATTERNS; each property is assigned
1508 ;; the corresponding value.
1509 ;;
1510 (let (pattern regex subex date-subex latest-date val values date)
1511 (while (setq pattern (car patterns))
1512 (if (stringp pattern)
1513 (setq regex pattern
1514 subex 1
1515 date-subex (and (string-match "\\\\(.*\\\\(" regex) 2))
1516 (setq regex (car pattern)
1517 subex (nth 1 pattern)
1518 date-subex (nth 2 pattern)))
1519 (goto-char (point-min))
1520 (if date-subex
1521 (progn
1522 (setq latest-date "" val nil)
1523 (while (re-search-forward regex nil t)
1524 (setq date (match-string date-subex))
1525 (if (string< latest-date date)
1526 (setq latest-date date
1527 val (match-string subex))))
1528 val)
1529 ;; no date subex, so just take the first match...
1530 (setq val (and (re-search-forward regex nil t) (match-string subex))))
1531 (if file (vc-file-setprop file (car properties) val))
1532 (setq values (cons val values)
1533 patterns (cdr patterns)
1534 properties (cdr properties)))
1535 values
1536 ))
1537
1538 (defun vc-master-info (file fields &optional rfile properties)
1539 ;; Search for information in a master file.
1540 (if (and file (file-exists-p file))
1541 (save-excursion
1542 (let ((buf))
1543 (setq buf (create-file-buffer file))
1544 (set-buffer buf))
1545 (erase-buffer)
1546 (insert-file-contents file)
1547 (set-buffer-modified-p nil)
1548 (auto-save-mode nil)
1549 (prog1
1550 (vc-parse-buffer fields rfile properties)
1551 (kill-buffer (current-buffer)))
1552 )
1553 (if rfile
1554 (mapcar
1555 (function (lambda (p) (vc-file-setprop rfile p nil)))
1556 properties))
1557 )
1558 )
1559
1560 (defun vc-log-info (command file last flags patterns &optional properties)
1561 ;; Search for information in log program output
1562 (if (and file (file-exists-p file))
1563 (save-excursion
1564 (set-buffer (get-buffer-create "*vc*"))
1565 (apply 'vc-do-command 0 command file last flags)
1566 (set-buffer-modified-p nil)
1567 (prog1
1568 (vc-parse-buffer patterns file properties)
1569 (kill-buffer (current-buffer))
1570 )
1571 )
1572 (if file
1573 (mapcar
1574 (function (lambda (p) (vc-file-setprop file p nil)))
1575 properties))
1576 )
1577 )
1578
1579 (defun vc-locking-user (file)
1580 "Return the name of the person currently holding a lock on FILE.
1581 Return nil if there is no such person.
1582 Under CVS, a file is considered locked if it has been modified since it
1583 was checked out...even though it may well be writable by you."
1584 (setq file (expand-file-name file)) ; use full pathname
1585 (cond ((eq (vc-backend-deduce file) 'CVS)
1586 (if (vc-workfile-unchanged-p file t)
1587 nil
1588 ;; XEmacs - ahead of the pack...
1589 (user-login-name (nth 2 (file-attributes file)))))
1590 (t
1591 ;; #### - this can probably be cleaned up as a result of the changes to
1592 ;; user-login-name...
1593 (if (or (not vc-keep-workfiles)
1594 (eq vc-mistrust-permissions 't)
1595 (and vc-mistrust-permissions
1596 (funcall vc-mistrust-permissions (vc-backend-subdirectory-name
1597 file))))
1598 (vc-true-locking-user file)
1599 ;; This implementation assumes that any file which is under version
1600 ;; control and has -rw-r--r-- is locked by its owner. This is true
1601 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
1602 ;; We have to be careful not to exclude files with execute bits on;
1603 ;; scripts can be under version control too. Also, we must ignore
1604 ;; the group-read and other-read bits, since paranoid users turn them off.
1605 ;; This hack wins because calls to the very expensive vc-fetch-properties
1606 ;; function only have to be made if (a) the file is locked by someone
1607 ;; other than the current user, or (b) some untoward manipulation
1608 ;; behind vc's back has changed the owner or the `group' or `other'
1609 ;; write bits.
1610 (let ((attributes (file-attributes file)))
1611 (cond ((string-match ".r-..-..-." (nth 8 attributes))
1612 nil)
1613 ((and (= (nth 2 attributes) (user-uid))
1614 (string-match ".rw..-..-." (nth 8 attributes)))
1615 (user-login-name))
1616 (t
1617 (vc-true-locking-user file)))) ; #### - this looks recursive!!!
1618 ))))
1619
1620 (defun vc-true-locking-user (file)
1621 ;; The slow but reliable version
1622 (vc-fetch-properties file)
1623 (vc-file-getprop file 'vc-locking-user))
1624
1625 (defun vc-latest-version (file)
1626 ;; Return version level of the latest version of FILE
1627 (vc-fetch-properties file)
1628 (vc-file-getprop file 'vc-latest-version))
1629
1630 (defun vc-your-latest-version (file)
1631 ;; Return version level of the latest version of FILE checked in by you
1632 (vc-fetch-properties file)
1633 (vc-file-getprop file 'vc-your-latest-version))
1634
1635 ;; Collect back-end-dependent stuff here 1861 ;; Collect back-end-dependent stuff here
1636 ;; 1862
1637 ;; Everything eventually funnels through these functions. To implement
1638 ;; support for a new version-control system, add another branch to the
1639 ;; vc-backend-dispatch macro and fill it in in each call. The variable
1640 ;; vc-master-templates in vc-hooks.el will also have to change.
1641
1642 (put 'vc-backend-dispatch 'lisp-indent-function 'defun)
1643
1644 (defmacro vc-backend-dispatch (f s r c a)
1645 "Execute FORM1, FORM2 or FORM3 depending whether we're using SCCS, RCS, CVS
1646 or ClearCase.
1647 If FORM3 is RCS, use FORM2 even if we are using CVS. (CVS shares some code
1648 with RCS)."
1649 (list 'let (list (list 'type (list 'vc-backend-deduce f)))
1650 (list 'cond
1651 (list (list 'eq 'type (quote 'SCCS)) s) ; SCCS
1652 (list (list 'eq 'type (quote 'RCS)) r) ; RCS
1653 (list (list 'eq 'type (quote 'CVS)) ; CVS
1654 (if (eq c 'RCS) r c))
1655 (list (list 'eq 'type (quote 'CC)) a) ; CC
1656 )))
1657
1658 (defun vc-lock-file (file)
1659 ;; Generate lock file name corresponding to FILE
1660 (let ((master (vc-name file)))
1661 (and
1662 master
1663 (string-match "\\(.*/\\)s\\.\\(.*\\)" master)
1664 (concat
1665 (substring master (match-beginning 1) (match-end 1))
1666 "p."
1667 (substring master (match-beginning 2) (match-end 2))))))
1668
1669
1670 (defun vc-fetch-properties (file)
1671 ;; Re-fetch all properties associated with the given file.
1672 ;; Currently these properties are:
1673 ;; vc-locking-user
1674 ;; vc-locked-version
1675 ;; vc-latest-version
1676 ;; vc-your-latest-version
1677 ;; vc-cvs-status (cvs only)
1678 ;; vc-cc-predecessor (ClearCase only)
1679 (vc-backend-dispatch
1680 file
1681 ;; SCCS
1682 (progn
1683 (vc-master-info (vc-lock-file file)
1684 (list
1685 "^[^ ]+ [^ ]+ \\([^ ]+\\)"
1686 "^\\([^ ]+\\)")
1687 file
1688 '(vc-locking-user vc-locked-version))
1689 (vc-master-info (vc-name file)
1690 (list
1691 "^\001d D \\([^ ]+\\)"
1692 (concat "^\001d D \\([^ ]+\\) .* "
1693 (regexp-quote (user-login-name)) " ")
1694 )
1695 file
1696 '(vc-latest-version vc-your-latest-version))
1697 )
1698 ;; RCS
1699 (vc-log-info "rlog" file 'MASTER nil
1700 (list
1701 "^locks: strict\n\t\\([^:]+\\)"
1702 "^locks: strict\n\t[^:]+: \\(.+\\)"
1703 "^revision[\t ]+\\([0-9.]+\\).*\ndate: \\([ /0-9:]+\\);"
1704 (concat
1705 "^revision[\t ]+\\([0-9.]+\\)\n.*author: "
1706 (regexp-quote (user-login-name))
1707 ";"))
1708 '(vc-locking-user vc-locked-version
1709 vc-latest-version vc-your-latest-version))
1710 ;; CVS
1711 ;; Don't fetch vc-locking-user and vc-locked-version here, since they
1712 ;; should always be nil anyhow. Don't fetch vc-your-latest-version, since
1713 ;; that is done in vc-find-cvs-master.
1714 (vc-log-info
1715 "cvs" file 'WORKFILE '("status")
1716 ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
1717 ;; and CVS 1.4a1 says "Repository revision:". The regexp below
1718 ;; matches much more, but because of the way vc-log-info is
1719 ;; implemented it is impossible to use additional groups.
1720 '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
1721 "Status: \\(.*\\)")
1722 '(vc-latest-version
1723 vc-cvs-status))
1724 ;; CC
1725 (vc-log-info "cleartool" file 'WORKFILE '("describe")
1726 (list
1727 "checked out .* by .* (\\([^ .]+\\)..*@.*)"
1728 "from \\([^ ]+\\) (reserved)"
1729 "version [^\"]*\".*@@\\([^ ]+\\)\""
1730 "version [^\"]*\".*@@\\([^ ]+\\)\""
1731 "predecessor version: \\([^ ]+\\)\n")
1732 '(vc-locking-user vc-locked-version
1733 vc-latest-version vc-your-latest-version
1734 vc-cc-predecessor))
1735 ))
1736
1737 (defun vc-backend-subdirectory-name (&optional file)
1738 ;; Where the master and lock files for the current directory are kept
1739 (let ((backend
1740 (or
1741 (and file (vc-backend-deduce file))
1742 vc-default-back-end
1743 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))
1744 (cond
1745 ((eq backend 'SCCS) "SCCS")
1746 ((eq backend 'RCS) "RCS")
1747 ((eq backend 'CVS) "CVS")
1748 ((eq backend 'CC) "@@"))
1749 ))
1750
1751 (defun vc-backend-admin (file &optional rev comment) 1863 (defun vc-backend-admin (file &optional rev comment)
1752 ;; Register a file into the version-control system 1864 ;; Register a file into the version-control system
1753 ;; Automatically retrieves a read-only version of the file with 1865 ;; Automatically retrieves a read-only version of the file with
1754 ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise 1866 ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise
1755 ;; it deletes the workfile. 1867 ;; it deletes the workfile.
1756 (vc-file-clearprops file) 1868 (vc-file-clearprops file)
1757 (or vc-default-back-end 1869 (or vc-default-back-end
1758 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS))) 1870 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))
1759 (message "Registering %s..." file) 1871 (message "Registering %s..." file)
1760 (let ((backend 1872 (let ((switches
1761 (cond 1873 (if (stringp vc-register-switches)
1874 (list vc-register-switches)
1875 vc-register-switches))
1876 (backend
1877 (cond
1762 ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end) 1878 ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end)
1763 ((file-exists-p "RCS") 'RCS) 1879 ((file-exists-p "RCS") 'RCS)
1764 ((file-exists-p "SCCS") 'SCCS) 1880 ((file-exists-p "SCCS") 'SCCS)
1765 ((file-exists-p "CVS") 'CVS) 1881 ((file-exists-p "CVS") 'CVS)
1766 ((file-exists-p "@@") 'CC)
1767 (t vc-default-back-end)))) 1882 (t vc-default-back-end))))
1768 (cond ((eq backend 'SCCS) 1883 (cond ((eq backend 'SCCS)
1769 (vc-do-command 0 "admin" file 'MASTER ; SCCS 1884 (apply 'vc-do-command nil 0 "admin" file 'MASTER ;; SCCS
1770 (and rev (concat "-r" rev)) 1885 (and rev (concat "-r" rev))
1771 "-fb" 1886 "-fb"
1772 (concat "-i" file) 1887 (concat "-i" file)
1773 (and comment (concat "-y" comment)) 1888 (and comment (concat "-y" comment))
1774 (format 1889 (format
1775 (car (rassq 'SCCS vc-master-templates)) 1890 (car (rassq 'SCCS vc-master-templates))
1776 (or (file-name-directory file) "") 1891 (or (file-name-directory file) "")
1777 (file-name-nondirectory file))) 1892 (file-name-nondirectory file))
1893 switches)
1778 (delete-file file) 1894 (delete-file file)
1779 (if vc-keep-workfiles 1895 (if vc-keep-workfiles
1780 (vc-do-command 0 "get" file 'MASTER))) 1896 (vc-do-command nil 0 "get" file 'MASTER)))
1781 ((eq backend 'RCS) 1897 ((eq backend 'RCS)
1782 (vc-do-command 0 "ci" file 'MASTER ; RCS 1898 (apply 'vc-do-command nil 0 "ci" file 'WORKFILE ;; RCS
1783 (concat (if vc-keep-workfiles "-u" "-r") rev) 1899 ;; if available, use the secure registering option
1784 (and comment (concat "-t-" comment)) 1900 (and (vc-backend-release-p 'RCS "5.6.4") "-i")
1785 file)) 1901 (concat (if vc-keep-workfiles "-u" "-r") rev)
1786 ((eq backend 'CVS) 1902 (and comment (concat "-t-" comment))
1787 ;; #### - should maybe check to see if the master file is 1903 switches))
1788 ;; already in the repository...in which case we need to add the 1904 ((eq backend 'CVS)
1789 ;; appropriate branch tag and do an update. 1905 (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE ;; CVS
1790 ;; #### - note that adding a file is a 2 step process in CVS... 1906 "add"
1791 (vc-do-command 0 "cvs" file 'WORKFILE "add") 1907 (and comment (string-match "[^\t\n ]" comment)
1792 (vc-do-command 0 "cvs" file 'WORKFILE "commit" 1908 (concat "-m" comment))
1793 (and comment (not (string= comment "")) 1909 switches)
1794 (concat "-m" comment)))
1795 )
1796 ((eq backend 'CC)
1797 (vc-do-command 0 "cleartool" file 'WORKFILE ; CC
1798 "mkelem"
1799 (if (string-equal "" comment)
1800 "-nc")
1801 (if (not (string-equal "" comment))
1802 "-c")
1803 (if (not (string-equal "" comment))
1804 comment)
1805 )
1806 (vc-do-command 0 "cleartool" file 'WORKFILE
1807 "checkin" "-identical" "-nc"
1808 )
1809 ))) 1910 )))
1810 (message "Registering %s...done" file) 1911 (message "Registering %s...done" file)
1811 ) 1912 )
1812 1913
1813 (defun vc-backend-checkout (file &optional writable rev workfile) 1914 (defun vc-backend-checkout (file &optional writable rev workfile)
1814 ;; Retrieve a copy of a saved version into a workfile 1915 ;; Retrieve a copy of a saved version into a workfile
1815 (let ((filename (or workfile file))) 1916 (let ((filename (or workfile file))
1917 (file-buffer (get-file-buffer file))
1918 switches)
1816 (message "Checking out %s..." filename) 1919 (message "Checking out %s..." filename)
1817 (save-excursion 1920 (save-excursion
1818 ;; Change buffers to get local value of vc-checkin-switches. 1921 ;; Change buffers to get local value of vc-checkout-switches.
1819 (set-buffer (or (get-file-buffer file) (current-buffer))) 1922 (if file-buffer (set-buffer file-buffer))
1820 (vc-backend-dispatch 1923 (setq switches (if (stringp vc-checkout-switches)
1821 file 1924 (list vc-checkout-switches)
1822 ;; SCCS 1925 vc-checkout-switches))
1823 (if workfile 1926 ;; Save this buffer's default-directory
1824 ;; Some SCCS implementations allow checking out directly to a 1927 ;; and use save-excursion to make sure it is restored
1825 ;; file using the -G option, but then some don't so use the 1928 ;; in the same buffer it was saved in.
1826 ;; least common denominator approach and use the -p option 1929 (let ((default-directory default-directory))
1827 ;; ala RCS. 1930 (save-excursion
1828 (let ((vc-modes (logior (file-modes (vc-name file)) 1931 ;; Adjust the default-directory so that the check-out creates
1829 (if writable 128 0))) 1932 ;; the file in the right place.
1830 (failed t)) 1933 (setq default-directory (file-name-directory filename))
1831 (unwind-protect 1934 (vc-backend-dispatch file
1832 (progn 1935 (progn ;; SCCS
1833 (apply 'vc-do-command 1936 (and rev (string= rev "") (setq rev nil))
1834 0 "/bin/sh" file 'MASTER "-c" 1937 (if workfile
1835 ;; Some shells make the "" dummy argument into $0 1938 ;; Some SCCS implementations allow checking out directly to a
1836 ;; while others use the shell's name as $0 and 1939 ;; file using the -G option, but then some don't so use the
1837 ;; use the "" as $1. The if-statement 1940 ;; least common denominator approach and use the -p option
1838 ;; converts the latter case to the former. 1941 ;; ala RCS.
1839 (format "if [ x\"$1\" = x ]; then shift; fi; \ 1942 (let ((vc-modes (logior (file-modes (vc-name file))
1840 umask %o; exec >\"$1\" || exit; \ 1943 (if writable 128 0)))
1841 shift; umask %o; exec get \"$@\"" 1944 (failed t))
1842 (logand 511 (lognot vc-modes)) 1945 (unwind-protect
1843 (logand 511 (lognot (default-file-modes)))) 1946 (progn
1844 "" ; dummy argument for shell's $0 1947 (apply 'vc-do-command
1845 filename 1948 nil 0 "/bin/sh" file 'MASTER "-c"
1846 (if writable "-e") 1949 ;; Some shells make the "" dummy argument into $0
1847 "-p" (and rev 1950 ;; while others use the shell's name as $0 and
1848 (concat "-r" (vc-lookup-triple file rev))) 1951 ;; use the "" as $1. The if-statement
1849 vc-checkout-switches) 1952 ;; converts the latter case to the former.
1850 (setq failed nil)) 1953 (format "if [ x\"$1\" = x ]; then shift; fi; \
1851 (and failed (file-exists-p filename) (delete-file filename)))) 1954 umask %o; exec >\"$1\" || exit; \
1852 (apply 'vc-do-command 0 "get" file 'MASTER ; SCCS 1955 shift; umask %o; exec get \"$@\""
1853 (if writable "-e") 1956 (logand 511 (lognot vc-modes))
1854 (and rev (concat "-r" (vc-lookup-triple file rev))) 1957 (logand 511 (lognot (default-file-modes))))
1855 vc-checkout-switches)) 1958 "" ; dummy argument for shell's $0
1856 ;; RCS 1959 filename
1857 (if workfile 1960 (if writable "-e")
1858 ;; RCS doesn't let us check out into arbitrary file names directly. 1961 "-p"
1859 ;; Use `co -p' and make stdout point to the correct file. 1962 (and rev
1860 (let ((vc-modes (logior (file-modes (vc-name file)) 1963 (concat "-r" (vc-lookup-triple file rev)))
1861 (if writable 128 0))) 1964 switches)
1862 (failed t)) 1965 (setq failed nil))
1863 (unwind-protect 1966 (and failed (file-exists-p filename)
1864 (progn 1967 (delete-file filename))))
1865 (apply 'vc-do-command 1968 (apply 'vc-do-command nil 0 "get" file 'MASTER ;; SCCS
1866 0 "/bin/sh" file 'MASTER "-c" 1969 (if writable "-e")
1867 ;; See the SCCS case, above, regarding the 1970 (and rev (concat "-r" (vc-lookup-triple file rev)))
1868 ;; if-statement. 1971 switches)
1869 (format "if [ x\"$1\" = x ]; then shift; fi; \ 1972 (vc-file-setprop file 'vc-workfile-version nil)))
1870 umask %o; exec >\"$1\" || exit; \ 1973 (if workfile ;; RCS
1871 shift; umask %o; exec co \"$@\"" 1974 ;; RCS doesn't let us check out into arbitrary file names directly.
1872 (logand 511 (lognot vc-modes)) 1975 ;; Use `co -p' and make stdout point to the correct file.
1873 (logand 511 (lognot (default-file-modes)))) 1976 (let ((vc-modes (logior (file-modes (vc-name file))
1874 "" ; dummy argument for shell's $0 1977 (if writable 128 0)))
1875 filename 1978 (failed t))
1876 (if writable "-l") 1979 (unwind-protect
1877 (concat "-p" rev) 1980 (progn
1878 vc-checkout-switches) 1981 (apply 'vc-do-command
1879 (setq failed nil)) 1982 nil 0 "/bin/sh" file 'MASTER "-c"
1880 (and failed (file-exists-p filename) (delete-file filename)))) 1983 ;; See the SCCS case, above, regarding the
1881 (apply 'vc-do-command 0 "co" file 'MASTER 1984 ;; if-statement.
1882 (if writable "-l") 1985 (format "if [ x\"$1\" = x ]; then shift; fi; \
1883 (and rev (concat "-r" rev)) 1986 umask %o; exec >\"$1\" || exit; \
1884 vc-checkout-switches)) 1987 shift; umask %o; exec co \"$@\""
1885 ;; CVS 1988 (logand 511 (lognot vc-modes))
1886 (if workfile 1989 (logand 511 (lognot (default-file-modes))))
1887 ;; CVS is much like RCS 1990 "" ; dummy argument for shell's $0
1888 (let ((failed t)) 1991 filename
1889 (unwind-protect 1992 (if writable "-l")
1890 (progn 1993 (concat "-p" rev)
1891 (apply 'vc-do-command 1994 switches)
1892 0 "/bin/sh" file 'WORKFILE "-c" 1995 (setq failed nil))
1893 "exec >\"$1\" || exit; shift; exec cvs update \"$@\"" 1996 (and failed (file-exists-p filename) (delete-file filename))))
1894 "" ; dummy argument for shell's $0 1997 (let (new-version)
1895 workfile 1998 ;; if we should go to the head of the trunk,
1896 (concat "-r" rev) 1999 ;; clear the default branch first
1897 "-p" 2000 (and rev (string= rev "")
1898 vc-checkout-switches) 2001 (vc-do-command nil 0 "rcs" file 'MASTER "-b"))
1899 (setq failed nil)) 2002 ;; now do the checkout
1900 (and failed (file-exists-p filename) (delete-file filename)))) 2003 (apply 'vc-do-command
1901 (apply 'vc-do-command 0 "cvs" file 'WORKFILE 2004 nil 0 "co" file 'MASTER
1902 "update" 2005 ;; If locking is not strict, force to overwrite
1903 (and rev (concat "-r" rev)) 2006 ;; the writable workfile.
1904 file 2007 (if (eq (vc-checkout-model file) 'implicit) "-f")
1905 vc-checkout-switches)) 2008 (if writable "-l")
1906 ;; CC 2009 (if rev (concat "-r" rev)
1907 (if (or rev workfile) 2010 ;; if no explicit revision was specified,
1908 (error "VC's ClearCase support currently checks out /main/LATEST.") 2011 ;; check out that of the working file
1909 (apply 'vc-do-command 0 "cleartool" file 'WORKFILE 2012 (let ((workrev (vc-workfile-version file)))
1910 "checkout" "-nc" 2013 (if workrev (concat "-r" workrev)
1911 vc-checkout-switches)) 2014 nil)))
1912 )) 2015 switches)
1913 (or workfile 2016 ;; determine the new workfile version
1914 (vc-file-setprop file 2017 (save-excursion
1915 'vc-checkout-time (nth 5 (file-attributes file)))) 2018 (set-buffer "*vc*")
1916 (message "Checking out %s...done" filename)) 2019 (goto-char (point-min))
1917 ) 2020 (setq new-version
2021 (if (re-search-forward "^revision \\([0-9.]+\\).*\n" nil t)
2022 (buffer-substring (match-beginning 1) (match-end 1)))))
2023 (vc-file-setprop file 'vc-workfile-version new-version)
2024 ;; if necessary, adjust the default branch
2025 (and rev (not (string= rev ""))
2026 (vc-do-command nil 0 "rcs" file 'MASTER
2027 (concat "-b" (if (vc-latest-on-branch-p file)
2028 (if (vc-trunk-p new-version) nil
2029 (vc-branch-part new-version))
2030 new-version))))))
2031 (if workfile ;; CVS
2032 ;; CVS is much like RCS
2033 (let ((failed t))
2034 (unwind-protect
2035 (progn
2036 (apply 'vc-do-command
2037 nil 0 "/bin/sh" file 'WORKFILE "-c"
2038 "exec >\"$1\" || exit; shift; exec cvs update \"$@\""
2039 "" ; dummy argument for shell's $0
2040 workfile
2041 (concat "-r" rev)
2042 "-p"
2043 switches)
2044 (setq failed nil))
2045 (and failed (file-exists-p filename) (delete-file filename))))
2046 ;; default for verbose checkout: clear the sticky tag
2047 ;; so that the actual update will get the head of the trunk
2048 (and rev (string= rev "")
2049 (vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A"))
2050 ;; If a revision was specified, check that out.
2051 (if rev
2052 (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE
2053 (and writable (eq (vc-checkout-model file) 'manual) "-w")
2054 "update"
2055 (and rev (not (string= rev ""))
2056 (concat "-r" rev))
2057 switches)
2058 ;; If no revision was specified, simply make the file writable.
2059 (and writable
2060 (or (eq (vc-checkout-model file) 'manual)
2061 (zerop (logand 128 (file-modes file))))
2062 (set-file-modes file (logior 128 (file-modes file)))))
2063 (if rev (vc-file-setprop file 'vc-workfile-version nil))))
2064 (cond
2065 ((not workfile)
2066 (vc-file-clear-masterprops file)
2067 (if writable
2068 (vc-file-setprop file 'vc-locking-user (vc-user-login-name)))
2069 (vc-file-setprop file
2070 'vc-checkout-time (nth 5 (file-attributes file)))))
2071 (message "Checking out %s...done" filename))))))
1918 2072
1919 (defun vc-backend-logentry-check (file) 2073 (defun vc-backend-logentry-check (file)
1920 (vc-backend-dispatch file 2074 (vc-backend-dispatch file
1921 (if (>= (buffer-size) 512) ; SCCS 2075 (if (>= (buffer-size) 512) ;; SCCS
1922 (progn 2076 (progn
1923 (goto-char 512) 2077 (goto-char 512)
1924 (error 2078 (error
1925 "Log must be less than 512 characters; point is now at pos 512"))) 2079 "Log must be less than 512 characters; point is now at pos 512")))
1926 nil ; RCS 2080 nil ;; RCS
1927 nil ; CVS 2081 nil) ;; CVS
1928 nil) ; CC
1929 ) 2082 )
1930 2083
1931 (defun vc-backend-checkin (file rev comment) 2084 (defun vc-backend-checkin (file rev comment)
1932 ;; Register changes to FILE as level REV with explanatory COMMENT. 2085 ;; Register changes to FILE as level REV with explanatory COMMENT.
1933 ;; Automatically retrieves a read-only version of the file with 2086 ;; Automatically retrieves a read-only version of the file with
1934 ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise 2087 ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise
1935 ;; it deletes the workfile. 2088 ;; it deletes the workfile.
2089 ;; Adaptation for RCS branch support: if this is an explicit checkin,
2090 ;; or if the checkin creates a new branch, set the master file branch
2091 ;; accordingly.
1936 (message "Checking in %s..." file) 2092 (message "Checking in %s..." file)
2093 ;; "This log message intentionally left almost blank".
2094 ;; RCS 5.7 gripes about white-space-only comments too.
2095 (or (and comment (string-match "[^\t\n ]" comment))
2096 (setq comment "*** empty log message ***"))
1937 (save-excursion 2097 (save-excursion
1938 ;; Change buffers to get local value of vc-checkin-switches. 2098 ;; Change buffers to get local value of vc-checkin-switches.
1939 (set-buffer (or (get-file-buffer file) (current-buffer))) 2099 (set-buffer (or (get-file-buffer file) (current-buffer)))
1940 (vc-backend-dispatch file 2100 (let ((switches
1941 (progn 2101 (if (stringp vc-checkin-switches)
1942 (apply 'vc-do-command 0 "delta" file 'MASTER 2102 (list vc-checkin-switches)
1943 (if rev (concat "-r" rev)) 2103 vc-checkin-switches)))
1944 (concat "-y" comment) 2104 ;; Clear the master-properties. Do that here, not at the
1945 vc-checkin-switches) 2105 ;; end, because if the check-in fails we want them to get
1946 (if vc-keep-workfiles 2106 ;; re-computed before the next try.
1947 (vc-do-command 0 "get" file 'MASTER)) 2107 (vc-file-clear-masterprops file)
1948 ) 2108 (vc-backend-dispatch file
1949 (apply 'vc-do-command 0 "ci" file 'MASTER 2109 ;; SCCS
1950 (concat (if vc-keep-workfiles "-u" "-r") rev) 2110 (progn
1951 (if (not (string-equal "" comment)) 2111 (apply 'vc-do-command nil 0 "delta" file 'MASTER
1952 (concat "-m" comment)) 2112 (if rev (concat "-r" rev))
1953 vc-checkin-switches) 2113 (concat "-y" comment)
1954 (progn 2114 switches)
1955 (apply 'vc-do-command 0 "cvs" file 'WORKFILE 2115 (vc-file-setprop file 'vc-locking-user 'none)
1956 "ci" 2116 (vc-file-setprop file 'vc-workfile-version nil)
1957 (if (not (string-equal "" comment)) 2117 (if vc-keep-workfiles
1958 (concat "-m" comment)) 2118 (vc-do-command nil 0 "get" file 'MASTER))
1959 vc-checkin-switches) 2119 )
1960 (vc-file-setprop file 'vc-checkout-time 2120 ;; RCS
1961 (nth 5 (file-attributes file)))) 2121 (let ((old-version (vc-workfile-version file)) new-version)
1962 (progn 2122 (apply 'vc-do-command nil 0 "ci" file 'MASTER
1963 (apply 'vc-do-command 0 "cleartool" file 'WORKFILE 2123 ;; if available, use the secure check-in option
1964 "checkin" "-identical" 2124 (and (vc-backend-release-p 'RCS "5.6.4") "-j")
1965 (if (string-equal "" comment) 2125 (concat (if vc-keep-workfiles "-u" "-r") rev)
1966 "-nc") 2126 (concat "-m" comment)
1967 (if (not (string-equal "" comment)) 2127 switches)
1968 "-c") 2128 (vc-file-setprop file 'vc-locking-user 'none)
1969 (if (not (string-equal "" comment)) 2129 (vc-file-setprop file 'vc-workfile-version nil)
1970 comment) 2130
1971 vc-checkin-switches) 2131 ;; determine the new workfile version
1972 (vc-file-setprop file 'vc-checkout-time 2132 (set-buffer "*vc*")
1973 (nth 5 (file-attributes file)))) 2133 (goto-char (point-min))
1974 )) 2134 (if (or (re-search-forward
1975 (vc-file-setprop file 'vc-locking-user nil) 2135 "new revision: \\([0-9.]+\\);" nil t)
1976 (message "Checking in %s...done" file) 2136 (re-search-forward
1977 ) 2137 "reverting to previous revision \\([0-9.]+\\)" nil t))
2138 (progn (setq new-version (buffer-substring (match-beginning 1)
2139 (match-end 1)))
2140 (vc-file-setprop file 'vc-workfile-version new-version)))
2141
2142 ;; if we got to a different branch, adjust the default
2143 ;; branch accordingly
2144 (cond
2145 ((and old-version new-version
2146 (not (string= (vc-branch-part old-version)
2147 (vc-branch-part new-version))))
2148 (vc-do-command nil 0 "rcs" file 'MASTER
2149 (if (vc-trunk-p new-version) "-b"
2150 (concat "-b" (vc-branch-part new-version))))
2151 ;; If this is an old RCS release, we might have
2152 ;; to remove a remaining lock.
2153 (if (not (vc-backend-release-p 'RCS "5.6.2"))
2154 ;; exit status of 1 is also accepted.
2155 ;; It means that the lock was removed before.
2156 (vc-do-command nil 1 "rcs" file 'MASTER
2157 (concat "-u" old-version))))))
2158 ;; CVS
2159 (progn
2160 ;; explicit check-in to the trunk requires a
2161 ;; double check-in (first unexplicit) (CVS-1.3)
2162 (condition-case nil
2163 (progn
2164 (if (and rev (vc-trunk-p rev))
2165 (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE
2166 "ci" "-m" "intermediate"
2167 switches))
2168 (apply 'vc-do-command nil 0 "cvs" file 'WORKFILE
2169 "ci" (if rev (concat "-r" rev))
2170 (concat "-m" comment)
2171 switches))
2172 (error (if (eq (vc-cvs-status file) 'needs-merge)
2173 ;; The CVS output will be on top of this message.
2174 (error "Type C-x 0 C-x C-q to merge in changes")
2175 (error "Check-in failed"))))
2176 ;; determine and store the new workfile version
2177 (set-buffer "*vc*")
2178 (goto-char (point-min))
2179 (if (re-search-forward
2180 "^\\(new\\|initial\\) revision: \\([0-9.]+\\)" nil t)
2181 (vc-file-setprop file 'vc-workfile-version
2182 (buffer-substring (match-beginning 2)
2183 (match-end 2)))
2184 (vc-file-setprop file 'vc-workfile-version nil))
2185 ;; if this was an explicit check-in, remove the sticky tag
2186 (if rev
2187 (vc-do-command nil 0 "cvs" file 'WORKFILE "update" "-A"))
2188 (vc-file-setprop file 'vc-locking-user 'none)
2189 (vc-file-setprop file 'vc-checkout-time
2190 (nth 5 (file-attributes file)))))))
2191 (message "Checking in %s...done" file))
1978 2192
1979 (defun vc-backend-revert (file) 2193 (defun vc-backend-revert (file)
1980 ;; Revert file to latest checked-in version. 2194 ;; Revert file to latest checked-in version.
2195 ;; (for RCS, to workfile version)
1981 (message "Reverting %s..." file) 2196 (message "Reverting %s..." file)
2197 (vc-file-clear-masterprops file)
1982 (vc-backend-dispatch 2198 (vc-backend-dispatch
1983 file 2199 file
1984 (progn ; SCCS 2200 ;; SCCS
1985 (vc-do-command 0 "unget" file 'MASTER nil) 2201 (progn
1986 (vc-do-command 0 "get" file 'MASTER nil)) 2202 (vc-do-command nil 0 "unget" file 'MASTER nil)
1987 (vc-do-command 0 "co" file 'MASTER ; RCS. This deletes the work file. 2203 (vc-do-command nil 0 "get" file 'MASTER nil))
1988 "-f" "-u") 2204 ;; RCS
1989 (progn ; CVS 2205 (vc-do-command nil 0 "co" file 'MASTER
1990 (delete-file file) 2206 "-f" (concat "-u" (vc-workfile-version file)))
1991 (vc-do-command 0 "cvs" file 'WORKFILE "update")) 2207 ;; CVS
1992 (vc-do-command 0 "cleartool" file 'WORKFILE ; CC 2208 (progn
1993 "unco" "-rm") 2209 (delete-file file)
1994 ) 2210 (vc-do-command nil 0 "cvs" file 'WORKFILE "update")))
1995 (vc-file-setprop file 'vc-locking-user nil) 2211 (vc-file-setprop file 'vc-locking-user 'none)
2212 (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file)))
1996 (message "Reverting %s...done" file) 2213 (message "Reverting %s...done" file)
1997 ) 2214 )
1998 2215
1999 (defun vc-backend-steal (file &optional rev) 2216 (defun vc-backend-steal (file &optional rev)
2000 ;; Steal the lock on the current workfile. Needs RCS 5.6.2 or later for -M. 2217 ;; Steal the lock on the current workfile. Needs RCS 5.6.2 or later for -M.
2001 (message "Stealing lock on %s..." file) 2218 (message "Stealing lock on %s..." file)
2002 (vc-backend-dispatch file 2219 (vc-backend-dispatch file
2003 (progn ; SCCS 2220 (progn ;SCCS
2004 (vc-do-command 0 "unget" file 'MASTER "-n" (if rev (concat "-r" rev))) 2221 (vc-do-command nil 0 "unget" file 'MASTER "-n" (if rev (concat "-r" rev)))
2005 (vc-do-command 0 "get" file 'MASTER "-g" (if rev (concat "-r" rev))) 2222 (vc-do-command nil 0 "get" file 'MASTER "-g" (if rev (concat "-r" rev)))
2006 ) 2223 )
2007 (vc-do-command 0 "rcs" file 'MASTER ; RCS 2224 (vc-do-command nil 0 "rcs" file 'MASTER ;RCS
2008 "-M" (concat "-u" rev) (concat "-l" rev)) 2225 "-M" (concat "-u" rev) (concat "-l" rev))
2009 (error "You cannot steal a CVS lock; there are no CVS locks to steal.") ; CVS 2226 (error "You cannot steal a CVS lock; there are no CVS locks to steal") ;CVS
2010 (error "VC's ClearCase support cannot steal locks.") ; CC 2227 )
2011 ) 2228 (vc-file-setprop file 'vc-locking-user (vc-user-login-name))
2012 (vc-file-setprop file 'vc-locking-user (user-login-name))
2013 (message "Stealing lock on %s...done" file) 2229 (message "Stealing lock on %s...done" file)
2014 ) 2230 )
2015 2231
2016 (defun vc-backend-uncheck (file target) 2232 (defun vc-backend-uncheck (file target)
2017 ;; Undo the latest checkin. Note: this code will have to get a lot 2233 ;; Undo the latest checkin.
2018 ;; smarter when we support multiple branches.
2019 (message "Removing last change from %s..." file) 2234 (message "Removing last change from %s..." file)
2020 (vc-backend-dispatch file 2235 (vc-backend-dispatch file
2021 (vc-do-command 0 "rmdel" file 'MASTER (concat "-r" target)) 2236 (vc-do-command nil 0 "rmdel" file 'MASTER (concat "-r" target))
2022 (vc-do-command 0 "rcs" file 'MASTER (concat "-o" target)) 2237 (vc-do-command nil 0 "rcs" file 'MASTER (concat "-o" target))
2023 (error "Unchecking files under CVS is dangerous and not supported in VC.") 2238 nil ;; this is never reached under CVS
2024 (error "VC's ClearCase support cannot cancel checkins.") 2239 )
2025 )
2026 (message "Removing last change from %s...done" file) 2240 (message "Removing last change from %s...done" file)
2027 ) 2241 )
2028 2242
2029 (defun vc-backend-print-log (file) 2243 (defun vc-backend-print-log (file)
2030 ;; Print change log associated with FILE to buffer *vc*. 2244 ;; Get change log associated with FILE.
2031 (vc-backend-dispatch 2245 (vc-backend-dispatch
2032 file 2246 file
2033 (vc-do-command 0 "prs" file 'MASTER) 2247 (vc-do-command nil 0 "prs" file 'MASTER)
2034 (vc-do-command 0 "rlog" file 'MASTER) 2248 (vc-do-command nil 0 "rlog" file 'MASTER)
2035 (vc-do-command 0 "cvs" file 'WORKFILE "log") 2249 (vc-do-command nil 0 "cvs" file 'WORKFILE "log")))
2036 (vc-do-command 0 "cleartool" file 'WORKFILE "lshistory")))
2037 2250
2038 (defun vc-backend-assign-name (file name) 2251 (defun vc-backend-assign-name (file name)
2039 ;; Assign to a FILE's latest version a given NAME. 2252 ;; Assign to a FILE's latest version a given NAME.
2040 (vc-backend-dispatch file 2253 (vc-backend-dispatch file
2041 (vc-add-triple name file (vc-latest-version file)) ; SCCS 2254 (vc-add-triple name file (vc-latest-version file)) ;; SCCS
2042 (vc-do-command 0 "rcs" file 'MASTER (concat "-n" name ":")) ; RCS 2255 (vc-do-command nil 0 "rcs" file 'MASTER (concat "-n" name ":")) ;; RCS
2043 (vc-do-command 0 "cvs" file 'WORKFILE "tag" name) ; CVS 2256 (vc-do-command nil 0 "cvs" file 'WORKFILE "tag" name) ;; CVS
2044 (vc-do-command 0 "cleartool" file 'WORKFILE ; CC 2257 )
2045 "mklabel" "-replace" "-nc" name)
2046 )
2047 ) 2258 )
2048 2259
2049 (defun vc-backend-diff (file &optional oldvers newvers cmp) 2260 (defun vc-backend-diff (file &optional oldvers newvers cmp)
2050 ;; Get a difference report between two versions of FILE. 2261 ;; Get a difference report between two versions of FILE.
2051 ;; Get only a brief comparison report if CMP, a difference report otherwise. 2262 ;; Get only a brief comparison report if CMP, a difference report otherwise.
2052 (let ((backend (vc-backend-deduce file))) 2263 (let ((backend (vc-backend file)) options status
2264 (diff-switches-list (if (listp diff-switches)
2265 diff-switches
2266 (list diff-switches))))
2053 (cond 2267 (cond
2054 ((eq backend 'SCCS) 2268 ((eq backend 'SCCS)
2055 (setq oldvers (vc-lookup-triple file oldvers)) 2269 (setq oldvers (vc-lookup-triple file oldvers))
2056 (setq newvers (vc-lookup-triple file newvers)))) 2270 (setq newvers (vc-lookup-triple file newvers))
2057 (cond 2271 (setq options (append (list (and cmp "--brief") "-q"
2058 ;; SCCS and RCS shares a lot of code. 2272 (and oldvers (concat "-r" oldvers))
2059 ((or (eq backend 'SCCS) (eq backend 'RCS)) 2273 (and newvers (concat "-r" newvers)))
2060 (let* ((command (if (eq backend 'SCCS) 2274 (and (not cmp) diff-switches-list)))
2061 "vcdiff" 2275 (apply 'vc-do-command "*vc-diff*" 1 "vcdiff" file 'MASTER options))
2062 "rcsdiff")) 2276 ((eq backend 'RCS)
2063 (mode (if (eq backend 'RCS) 'WORKFILE 'MASTER)) 2277 (if (not oldvers) (setq oldvers (vc-workfile-version file)))
2064 (options (append (list (and cmp "--brief") 2278 ;; If we know that --brief is not supported, don't try it.
2065 "-q" 2279 (setq cmp (and cmp (not (eq vc-rcsdiff-knows-brief 'no))))
2066 (and oldvers (concat "-r" oldvers)) 2280 (setq options (append (list (and cmp "--brief") "-q"
2067 (and newvers (concat "-r" newvers))) 2281 (concat "-r" oldvers)
2068 (and (not cmp) 2282 (and newvers (concat "-r" newvers)))
2069 (if (listp diff-switches) 2283 (and (not cmp) diff-switches-list)))
2070 diff-switches 2284 (setq status (apply 'vc-do-command "*vc-diff*" 2
2071 (list diff-switches))))) 2285 "rcsdiff" file 'WORKFILE options))
2072 (status (apply 'vc-do-command 2 command file mode options))) 2286 ;; If --brief didn't work, do a double-take and remember it
2073 ;; Some RCS versions don't understand "--brief"; work around this. 2287 ;; for the future.
2074 (if (eq status 2) 2288 (if (eq status 2)
2075 (apply 'vc-do-command 1 command file 'WORKFILE 2289 (prog1
2076 (if cmp (cdr options) options)) 2290 (apply 'vc-do-command "*vc-diff*" 1 "rcsdiff" file 'WORKFILE
2077 status))) 2291 (if cmp (cdr options) options))
2292 (if cmp (setq vc-rcsdiff-knows-brief 'no)))
2293 ;; If --brief DID work, remember that, too.
2294 (and cmp (not vc-rcsdiff-knows-brief)
2295 (setq vc-rcsdiff-knows-brief 'yes))
2296 status))
2078 ;; CVS is different. 2297 ;; CVS is different.
2079 ;; cmp is not yet implemented -- we always do a full diff.
2080 ((eq backend 'CVS) 2298 ((eq backend 'CVS)
2081 (if (string= (vc-file-getprop file 'vc-your-latest-version) "0") ; CVS 2299 (if (string= (vc-workfile-version file) "0")
2082 ;; This file is added but not yet committed; there is no master file. 2300 ;; This file is added but not yet committed; there is no master file.
2083 ;; diff it against /dev/null.
2084 (if (or oldvers newvers) 2301 (if (or oldvers newvers)
2085 (error "No revisions of %s exists" file) 2302 (error "No revisions of %s exist" file)
2086 (apply 'vc-do-command 2303 (if cmp 1 ;; file is added but not committed,
2087 1 "diff" file 'WORKFILE "/dev/null" 2304 ;; we regard this as "changed".
2088 (if (listp diff-switches) 2305 ;; diff it against /dev/null.
2089 diff-switches 2306 (apply 'vc-do-command
2090 (list diff-switches)))) 2307 "*vc-diff*" 1 "diff" file 'WORKFILE
2308 (append (if (listp diff-switches)
2309 diff-switches
2310 (list diff-switches)) '("/dev/null")))))
2311 ;; cmp is not yet implemented -- we always do a full diff.
2091 (apply 'vc-do-command 2312 (apply 'vc-do-command
2092 1 "cvs" file 'WORKFILE "diff" 2313 "*vc-diff*" 1 "cvs" file 'WORKFILE "diff"
2093 (and oldvers (concat "-r" oldvers)) 2314 (and oldvers (concat "-r" oldvers))
2094 (and newvers (concat "-r" newvers)) 2315 (and newvers (concat "-r" newvers))
2095 (if (listp diff-switches) 2316 (if (listp diff-switches)
2096 diff-switches 2317 diff-switches
2097 (list diff-switches))))) 2318 (list diff-switches)))))
2098 ;; ClearCase is completely different.
2099 ((eq backend 'CC)
2100 (apply 'vc-do-command 2 "cleardiff" file nil
2101 (if cmp "-status_only")
2102 (concat file "@@"
2103 (or oldvers
2104 (vc-file-getprop file 'vc-cc-predecessor)))
2105 (if newvers
2106 (concat file "@@" newvers)
2107 file)
2108 nil))
2109 (t 2319 (t
2110 (vc-registration-error file))))) 2320 (vc-registration-error file)))))
2111 2321
2112 (defun vc-backend-merge-news (file) 2322 (defun vc-backend-merge-news (file)
2113 ;; Merge in any new changes made to FILE. 2323 ;; Merge in any new changes made to FILE.
2114 (vc-backend-dispatch 2324 (message "Merging changes into %s..." file)
2115 file 2325 (prog1
2116 (error "vc-backend-merge-news not meaningful for SCCS files") ; SCCS 2326 (vc-backend-dispatch
2117 (error "vc-backend-merge-news not meaningful for RCS files") ; RCS 2327 file
2118 (vc-do-command 1 "cvs" file 'WORKFILE "update") ; CVS 2328 (error "vc-backend-merge-news not meaningful for SCCS files") ;SCCS
2119 (error "vc-backend-merge-news not meaningful for ClearCase files") ; CC 2329 (error "vc-backend-merge-news not meaningful for RCS files") ;RCS
2120 )) 2330 (save-excursion ; CVS
2331 (vc-file-clear-masterprops file)
2332 (vc-file-setprop file 'vc-workfile-version nil)
2333 (vc-file-setprop file 'vc-locking-user nil)
2334 (vc-do-command nil 0 "cvs" file 'WORKFILE "update")
2335 ;; CVS doesn't return an error code if conflicts are detected.
2336 ;; Since we want to warn the user about it (and possibly start
2337 ;; emerge later), scan the output and see if this occurred.
2338 (set-buffer (get-buffer "*vc*"))
2339 (goto-char (point-min))
2340 (if (re-search-forward "^cvs update: conflicts found in .*" nil t)
2341 1 ;; error code for caller
2342 0 ;; no conflict detected
2343 )))
2344 (message "Merging changes into %s...done" file)))
2121 2345
2122 (defun vc-check-headers () 2346 (defun vc-check-headers ()
2123 "Check if the current file has any headers in it." 2347 "Check if the current file has any headers in it."
2124 (interactive) 2348 (interactive)
2125 (save-excursion 2349 (save-excursion
2126 (goto-char (point-min)) 2350 (goto-char (point-min))
2127 (vc-backend-dispatch buffer-file-name 2351 (vc-backend-dispatch buffer-file-name
2128 (re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" nil t) ; SCCS 2352 (re-search-forward "%[MIRLBSDHTEGUYFPQCZWA]%" nil t) ;; SCCS
2129 (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t) ; RCS 2353 (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t) ;; RCS
2130 'RCS ; CVS works like RCS in this regard. 2354 'RCS ;; CVS works like RCS in this regard.
2131 nil ; ClearCase does not recognise headers. 2355 )
2132 )
2133 )) 2356 ))
2134 2357
2135 ;; Back-end-dependent stuff ends here. 2358 ;; Back-end-dependent stuff ends here.
2136 2359
2137 ;; Set up key bindings for use while editing log messages 2360 ;; Set up key bindings for use while editing log messages
2138 2361
2139 (defun vc-log-mode () 2362 (defun vc-log-mode (&optional file)
2140 "Minor mode for driving version-control tools. 2363 "Minor mode for driving version-control tools.
2141 These bindings are added to the global keymap when you enter this mode: 2364 These bindings are added to the global keymap when you enter this mode:
2142 \\[vc-next-action] perform next logical version-control operation on current file 2365 \\[vc-next-action] perform next logical version-control operation on current file
2143 \\[vc-register] register current file 2366 \\[vc-register] register current file
2144 \\[vc-toggle-read-only] like next-action, but won't register files 2367 \\[vc-toggle-read-only] like next-action, but won't register files
2145 \\[vc-insert-headers] insert version-control headers in current file 2368 \\[vc-insert-headers] insert version-control headers in current file
2146 \\[vc-print-log] display change history of current file 2369 \\[vc-print-log] display change history of current file
2147 \\[vc-revert-buffer] revert buffer to latest version 2370 \\[vc-revert-buffer] revert buffer to latest version
2148 \\[vc-cancel-version] undo latest checkin 2371 \\[vc-cancel-version] undo latest checkin
2149 \\[vc-diff] show diffs between file versions 2372 \\[vc-diff] show diffs between file versions
2150 \\[vc-version-other-window] visit old version in another window 2373 \\[vc-version-other-window] visit old version in another window
2151 \\[vc-directory] show all files locked by any user in or below . 2374 \\[vc-directory] show all files locked by any user in or below .
2152 \\[vc-update-change-log] add change log entry from recent checkins 2375 \\[vc-update-change-log] add change log entry from recent checkins
2153 2376
2154 While you are entering a change log message for a version, the following 2377 While you are entering a change log message for a version, the following
2155 additional bindings will be in effect. 2378 additional bindings will be in effect.
2156 2379
2157 \\[vc-finish-logentry] proceed with check in, ending log message entry 2380 \\[vc-finish-logentry] proceed with check in, ending log message entry
2158 2381
2159 Whenever you do a checkin, your log comment is added to a ring of 2382 Whenever you do a checkin, your log comment is added to a ring of
2160 saved comments. These can be recalled as follows: 2383 saved comments. These can be recalled as follows:
2161 2384
2162 \\[vc-next-comment] replace region with next message in comment ring 2385 \\[vc-next-comment] replace region with next message in comment ring
2163 \\[vc-previous-comment] replace region with previous message in comment ring 2386 \\[vc-previous-comment] replace region with previous message in comment ring
2164 \\[vc-comment-search-reverse] search backward for regexp in the comment ring 2387 \\[vc-comment-search-reverse] search backward for regexp in the comment ring
2165 \\[vc-comment-search-forward] search backward for regexp in the comment ring 2388 \\[vc-comment-search-forward] search backward for regexp in the comment ring
2166 2389
2167 Entry to the change-log submode calls the value of text-mode-hook, then 2390 Entry to the change-log submode calls the value of text-mode-hook, then
2168 the value of vc-log-mode-hook. 2391 the value of vc-log-mode-hook.
2169 2392
2170 Global user options: 2393 Global user options:
2171 vc-initial-comment If non-nil, require user to enter a change 2394 vc-initial-comment If non-nil, require user to enter a change
2172 comment upon first checkin of the file. 2395 comment upon first checkin of the file.
2173 2396
2174 vc-keep-workfiles Non-nil value prevents workfiles from being 2397 vc-keep-workfiles Non-nil value prevents workfiles from being
2175 deleted when changes are checked in 2398 deleted when changes are checked in
2176 2399
2177 vc-suppress-confirm Suppresses some confirmation prompts, 2400 vc-suppress-confirm Suppresses some confirmation prompts,
2178 notably for reversions. 2401 notably for reversions.
2179 2402
2180 vc-header-alist Which keywords to insert when adding headers 2403 vc-header-alist Which keywords to insert when adding headers
2181 with \\[vc-insert-headers]. Defaults to 2404 with \\[vc-insert-headers]. Defaults to
2182 '(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under 2405 '(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under
2183 RCS and CVS. 2406 RCS and CVS.
2184 2407
2185 vc-static-header-alist By default, version headers inserted in C files 2408 vc-static-header-alist By default, version headers inserted in C files
2186 get stuffed in a static string area so that 2409 get stuffed in a static string area so that
2187 ident(RCS/CVS) or what(SCCS) can see them in 2410 ident(RCS/CVS) or what(SCCS) can see them in
2188 the compiled object code. You can override 2411 the compiled object code. You can override
2189 this by setting this variable to nil, or change 2412 this by setting this variable to nil, or change
2190 the header template by changing it. 2413 the header template by changing it.
2191 2414
2192 vc-command-messages if non-nil, display run messages from the 2415 vc-command-messages if non-nil, display run messages from the
2193 actual version-control utilities (this is 2416 actual version-control utilities (this is
2194 intended primarily for people hacking vc 2417 intended primarily for people hacking vc
2195 itself). 2418 itself).
2196 " 2419 "
2197 (interactive) 2420 (interactive)
2198 (set-syntax-table text-mode-syntax-table) 2421 (set-syntax-table text-mode-syntax-table)
2199 (use-local-map vc-log-entry-mode) 2422 (use-local-map vc-log-entry-mode)
2200 (setq local-abbrev-table text-mode-abbrev-table) 2423 (setq local-abbrev-table text-mode-abbrev-table)
2201 (setq major-mode 'vc-log-mode) 2424 (setq major-mode 'vc-log-mode)
2202 (setq mode-name "VC-Log") 2425 (setq mode-name "VC-Log")
2203 (make-local-variable 'vc-log-file) 2426 (make-local-variable 'vc-log-file)
2427 (setq vc-log-file file)
2204 (make-local-variable 'vc-log-version) 2428 (make-local-variable 'vc-log-version)
2205 (make-local-variable 'vc-comment-ring-index) 2429 (make-local-variable 'vc-comment-ring-index)
2206 (set-buffer-modified-p nil) 2430 (set-buffer-modified-p nil)
2207 (setq buffer-file-name nil) 2431 (setq buffer-file-name nil)
2208 (run-hooks 'text-mode-hook 'vc-log-mode-hook) 2432 (run-hooks 'text-mode-hook 'vc-log-mode-hook)
2209 ) 2433 )
2210 2434
2211 ;; Initialization code, to be done just once at load-time 2435 ;; Initialization code, to be done just once at load-time
2212 (if vc-log-entry-mode 2436 (if vc-log-entry-mode
2213 nil 2437 nil
2214 (setq vc-log-entry-mode (make-sparse-keymap)) 2438 (setq vc-log-entry-mode (make-sparse-keymap))
2215 (set-keymap-name vc-log-entry-mode 'vc-log-entry-mode) ; XEmacs
2216 (define-key vc-log-entry-mode "\M-n" 'vc-next-comment) 2439 (define-key vc-log-entry-mode "\M-n" 'vc-next-comment)
2217 (define-key vc-log-entry-mode "\M-p" 'vc-previous-comment) 2440 (define-key vc-log-entry-mode "\M-p" 'vc-previous-comment)
2218 (define-key vc-log-entry-mode "\M-r" 'vc-comment-search-reverse) 2441 (define-key vc-log-entry-mode "\M-r" 'vc-comment-search-reverse)
2219 (define-key vc-log-entry-mode "\M-s" 'vc-comment-search-forward) 2442 (define-key vc-log-entry-mode "\M-s" 'vc-comment-search-forward)
2220 (define-key vc-log-entry-mode "\C-c\C-c" 'vc-finish-logentry) 2443 (define-key vc-log-entry-mode "\C-c\C-c" 'vc-finish-logentry)
2221 ) 2444 )
2222 2445
2223 ;;; These things should probably be generally available 2446 ;;; These things should probably be generally available
2224 2447
2225 (defun vc-file-tree-walk (func &rest args) 2448 (defun vc-file-tree-walk (dirname func &rest args)
2226 "Walk recursively through default directory. 2449 "Walk recursively through DIRNAME.
2227 Invoke FUNC f ARGS on each non-directory file f underneath it." 2450 Invoke FUNC f ARGS on each non-directory file f underneath it."
2228 (vc-file-tree-walk-internal default-directory func args) 2451 (vc-file-tree-walk-internal (expand-file-name dirname) func args)
2229 (message "Traversing directory %s...done" default-directory)) 2452 (message "Traversing directory %s...done" dirname))
2230 2453
2231 (defun vc-file-tree-walk-internal (file func args) 2454 (defun vc-file-tree-walk-internal (file func args)
2232 (if (not (file-directory-p file)) 2455 (if (not (file-directory-p file))
2233 (apply func file args) 2456 (apply func file args)
2234 (message "Traversing directory %s..." file) 2457 (message "Traversing directory %s..." (abbreviate-file-name file))
2235 (let ((dir (file-name-as-directory file))) 2458 (let ((dir (file-name-as-directory file)))
2236 (mapcar 2459 (mapcar
2237 (function 2460 (function
2238 (lambda (f) (or 2461 (lambda (f) (or
2239 (string-equal f ".") 2462 (string-equal f ".")
2240 (string-equal f "..") 2463 (string-equal f "..")
2241 (member f vc-directory-exclusion-list) 2464 (member f vc-directory-exclusion-list)
2242 (let ((dirf (concat dir f))) 2465 (let ((dirf (concat dir f)))
2243 (or 2466 (or
2244 (file-symlink-p dirf) ; Avoid possible loops 2467 (file-symlink-p dirf) ;; Avoid possible loops
2245 (vc-file-tree-walk-internal dirf func args)))))) 2468 (vc-file-tree-walk-internal dirf func args))))))
2246 (directory-files dir))))) 2469 (directory-files dir)))))
2247
2248 (defun vc-dir-all-files (func &rest args)
2249 "Invoke FUNC f ARGS on each regular file f in default directory."
2250 (let ((dir default-directory))
2251 (message "Scanning directory %s..." dir)
2252 (mapcar (function (lambda (f)
2253 (let ((dirf (expand-file-name f dir)))
2254 (if (not (file-directory-p dirf))
2255 (apply func dirf args)))))
2256 (directory-files dir))
2257 (message "Scanning directory %s...done" dir)))
2258 2470
2259 (provide 'vc) 2471 (provide 'vc)
2260 2472
2261 ;;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE 2473 ;;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE
2262 ;;; 2474 ;;;
2263 ;;; These may be useful to anyone who has to debug or extend the package. 2475 ;;; These may be useful to anyone who has to debug or extend the package.
2476 ;;; (Note that this information corresponds to versions 5.x. Some of it
2477 ;;; might have been invalidated by the additions to support branching
2478 ;;; and RCS keyword lookup. AS, 1995/03/24)
2264 ;;; 2479 ;;;
2265 ;;; A fundamental problem in VC is that there are time windows between 2480 ;;; A fundamental problem in VC is that there are time windows between
2266 ;;; vc-next-action's computations of the file's version-control state and 2481 ;;; vc-next-action's computations of the file's version-control state and
2267 ;;; the actions that change it. This is a window open to lossage in a 2482 ;;; the actions that change it. This is a window open to lossage in a
2268 ;;; multi-user environment; someone else could nip in and change the state 2483 ;;; multi-user environment; someone else could nip in and change the state
2281 ;;; 2496 ;;;
2282 ;;; The race condition implies that we have to either (a) lock the master 2497 ;;; The race condition implies that we have to either (a) lock the master
2283 ;;; during the entire execution of vc-next-action, or (b) detect and 2498 ;;; during the entire execution of vc-next-action, or (b) detect and
2284 ;;; recover from errors resulting from dispatch on an out-of-date state. 2499 ;;; recover from errors resulting from dispatch on an out-of-date state.
2285 ;;; 2500 ;;;
2286 ;;; Alternative (a) appears to be unfeasible. The problem is that we can't 2501 ;;; Alternative (a) appears to be infeasible. The problem is that we can't
2287 ;;; guarantee that the lock will ever be removed. Suppose a user starts a 2502 ;;; guarantee that the lock will ever be removed. Suppose a user starts a
2288 ;;; checkin, the change message buffer pops up, and the user, having wandered 2503 ;;; checkin, the change message buffer pops up, and the user, having wandered
2289 ;;; off to do something else, simply forgets about it? 2504 ;;; off to do something else, simply forgets about it?
2290 ;;; 2505 ;;;
2291 ;;; Alternative (b), on the other hand, works well with a cheap way to speed up 2506 ;;; Alternative (b), on the other hand, works well with a cheap way to speed up
2322 ;;; A B C D E 2537 ;;; A B C D E
2323 ;;; A . 1 2 3 4 ci -u -t- admin -fb -i<file> initial admin 2538 ;;; A . 1 2 3 4 ci -u -t- admin -fb -i<file> initial admin
2324 ;;; B 5 . 6 7 8 co -l get -e checkout 2539 ;;; B 5 . 6 7 8 co -l get -e checkout
2325 ;;; C 9 10 . 11 12 co -u unget; get revert 2540 ;;; C 9 10 . 11 12 co -u unget; get revert
2326 ;;; D 13 14 15 . 16 ci -u -m<comment> delta -y<comment>; get checkin 2541 ;;; D 13 14 15 . 16 ci -u -m<comment> delta -y<comment>; get checkin
2327 ;;; E 17 18 19 20 . rcs -u -M ; rcs -l unget -n ; get -g steal lock 2542 ;;; E 17 18 19 20 . rcs -u -M -l unget -n ; get -g steal lock
2328 ;;; 2543 ;;;
2329 ;;; All commands take the master file name as a last argument (not shown). 2544 ;;; All commands take the master file name as a last argument (not shown).
2330 ;;; 2545 ;;;
2331 ;;; In the discussion below, a "self-race" is a pathological situation in 2546 ;;; In the discussion below, a "self-race" is a pathological situation in
2332 ;;; which VC operations are being attempted simultaneously by two or more 2547 ;;; which VC operations are being attempted simultaneously by two or more
2380 ;;; 1. File looked unregistered but is actually registered and not locked. 2595 ;;; 1. File looked unregistered but is actually registered and not locked.
2381 ;;; 2596 ;;;
2382 ;;; Potential cause: someone else's admin during window P, with 2597 ;;; Potential cause: someone else's admin during window P, with
2383 ;;; caller's admin happening before their checkout. 2598 ;;; caller's admin happening before their checkout.
2384 ;;; 2599 ;;;
2385 ;;; RCS: ci will fail with a "no lock set by <user>" message. 2600 ;;; RCS: Prior to version 5.6.4, ci fails with message
2601 ;;; "no lock set by <user>". From 5.6.4 onwards, VC uses the new
2602 ;;; ci -i option and the message is "<file>,v: already exists".
2386 ;;; SCCS: admin will fail with error (ad19). 2603 ;;; SCCS: admin will fail with error (ad19).
2387 ;;; 2604 ;;;
2388 ;;; We can let these errors be passed up to the user. 2605 ;;; We can let these errors be passed up to the user.
2389 ;;; 2606 ;;;
2390 ;;; 2. File looked unregistered but is actually locked by caller, unchanged. 2607 ;;; 2. File looked unregistered but is actually locked by caller, unchanged.
2391 ;;; 2608 ;;;
2392 ;;; Potential cause: self-race during window P. 2609 ;;; Potential cause: self-race during window P.
2393 ;;; 2610 ;;;
2394 ;;; RCS: will revert the file to the last saved version and unlock it. 2611 ;;; RCS: Prior to version 5.6.4, reverts the file to the last saved
2612 ;;; version and unlocks it. From 5.6.4 onwards, VC uses the new
2613 ;;; ci -i option, failing with message "<file>,v: already exists".
2395 ;;; SCCS: will fail with error (ad19). 2614 ;;; SCCS: will fail with error (ad19).
2396 ;;; 2615 ;;;
2397 ;;; Either of these consequences is acceptable. 2616 ;;; Either of these consequences is acceptable.
2398 ;;; 2617 ;;;
2399 ;;; 3. File looked unregistered but is actually locked by caller, changed. 2618 ;;; 3. File looked unregistered but is actually locked by caller, changed.
2400 ;;; 2619 ;;;
2401 ;;; Potential cause: self-race during window P. 2620 ;;; Potential cause: self-race during window P.
2402 ;;; 2621 ;;;
2403 ;;; RCS: will register the caller's workfile as a delta with a 2622 ;;; RCS: Prior to version 5.6.4, VC registers the caller's workfile as
2404 ;;; null change comment (the -t- switch will be ignored). 2623 ;;; a delta with a null change comment (the -t- switch will be
2624 ;;; ignored). From 5.6.4 onwards, VC uses the new ci -i option,
2625 ;;; failing with message "<file>,v: already exists".
2405 ;;; SCCS: will fail with error (ad19). 2626 ;;; SCCS: will fail with error (ad19).
2406 ;;; 2627 ;;;
2407 ;;; 4. File looked unregistered but is locked by someone else. 2628 ;;; 4. File looked unregistered but is locked by someone else.
2408 ;;; 2629 ;;;
2409 ;;; Potential cause: someone else's admin during window P, with 2630 ;;; Potential cause: someone else's admin during window P, with
2410 ;;; caller's admin happening *after* their checkout. 2631 ;;; caller's admin happening *after* their checkout.
2411 ;;; 2632 ;;;
2412 ;;; RCS: will fail with a "no lock set by <user>" message. 2633 ;;; RCS: Prior to version 5.6.4, ci fails with a
2634 ;;; "no lock set by <user>" message. From 5.6.4 onwards,
2635 ;;; VC uses the new ci -i option, failing with message
2636 ;;; "<file>,v: already exists".
2413 ;;; SCCS: will fail with error (ad19). 2637 ;;; SCCS: will fail with error (ad19).
2414 ;;; 2638 ;;;
2415 ;;; We can let these errors be passed up to the user. 2639 ;;; We can let these errors be passed up to the user.
2416 ;;; 2640 ;;;
2417 ;;; Apparent state B --- 2641 ;;; Apparent state B ---
2495 ;;; 13. File looks like it's locked by the calling user and changed, but it's 2719 ;;; 13. File looks like it's locked by the calling user and changed, but it's
2496 ;;; actually unregistered. 2720 ;;; actually unregistered.
2497 ;;; 2721 ;;;
2498 ;;; Potential cause: master file got nuked during window P. 2722 ;;; Potential cause: master file got nuked during window P.
2499 ;;; 2723 ;;;
2500 ;;; RCS: Checks in the user's version as an initial delta. 2724 ;;; RCS: Prior to version 5.6.4, checks in the user's version as an
2725 ;;; initial delta. From 5.6.4 onwards, VC uses the new ci -j
2726 ;;; option, failing with message "no such file or directory".
2501 ;;; SCCS: will fail with error ut4. 2727 ;;; SCCS: will fail with error ut4.
2502 ;;; 2728 ;;;
2503 ;;; This case is kind of nasty. It means VC may fail to detect the 2729 ;;; This case is kind of nasty. Under RCS prior to version 5.6.4,
2504 ;;; loss of previous version information. 2730 ;;; VC may fail to detect the loss of previous version information.
2505 ;;; 2731 ;;;
2506 ;;; 14. File looks like it's locked by the calling user and changed, but it's 2732 ;;; 14. File looks like it's locked by the calling user and changed, but it's
2507 ;;; actually unlocked. 2733 ;;; actually unlocked.
2508 ;;; 2734 ;;;
2509 ;;; Potential cause: self-race in window V, or the checkin happening 2735 ;;; Potential cause: self-race in window V, or the checkin happening
2566 ;;; 2792 ;;;
2567 ;;; PROBLEM CASES: 2793 ;;; PROBLEM CASES:
2568 ;;; 2794 ;;;
2569 ;;; In order of decreasing severity: 2795 ;;; In order of decreasing severity:
2570 ;;; 2796 ;;;
2571 ;;; Cases 11 and 15 under RCS are the only one that potentially lose work. 2797 ;;; Cases 11 and 15 are the only ones that potentially lose work.
2572 ;;; They would require a self-race for this to happen. 2798 ;;; They would require a self-race for this to happen.
2573 ;;; 2799 ;;;
2574 ;;; Case 13 in RCS loses information about previous deltas, retaining 2800 ;;; Case 13 in RCS loses information about previous deltas, retaining
2575 ;;; only the information in the current workfile. This can only happen 2801 ;;; only the information in the current workfile. This can only happen
2576 ;;; if the master file gets nuked in window P. 2802 ;;; if the master file gets nuked in window P.