Mercurial > hg > xemacs-beta
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. |