Commit | Line | Data |
---|---|---|
aae56ea7 | 1 | ;;; vc-hooks.el --- resident support for version-control |
594722a8 | 2 | |
137fcf31 | 3 | ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc. |
594722a8 ER |
4 | |
5 | ;; Author: Eric S. Raymond <esr@snark.thyrsus.com> | |
7bc2b98b | 6 | ;; Version: 5.3 |
594722a8 ER |
7 | |
8 | ;; This file is part of GNU Emacs. | |
9 | ||
10 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
11 | ;; it under the terms of the GNU General Public License as published by | |
12 | ;; the Free Software Foundation; either version 2, or (at your option) | |
13 | ;; any later version. | |
14 | ||
15 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ;; GNU General Public License for more details. | |
19 | ||
20 | ;; You should have received a copy of the GNU General Public License | |
21 | ;; along with GNU Emacs; see the file COPYING. If not, write to | |
22 | ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
23 | ||
24 | ;;; Commentary: | |
25 | ||
26 | ;; See the commentary of vc.el. | |
27 | ||
28 | ;;; Code: | |
29 | ||
30 | (defvar vc-master-templates | |
31 | '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS) | |
32 | ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS)) | |
33 | "*Where to look for version-control master files. | |
34 | The first pair corresponding to a given back end is used as a template | |
35 | when creating new masters.") | |
36 | ||
37 | (defvar vc-make-backup-files nil | |
5032bd23 | 38 | "*If non-nil, backups of registered files are made as with other files. |
9228cfac | 39 | If nil (the default), files covered by version control don't get backups.") |
594722a8 | 40 | |
198d5c00 RS |
41 | (defvar vc-rcs-status t |
42 | "*If non-nil, revision and locks on RCS working file displayed in modeline. | |
43 | Otherwise, not displayed.") | |
44 | ||
594722a8 | 45 | ;; Tell Emacs about this new kind of minor mode |
7bc2b98b ER |
46 | (if (not (assoc 'vc-mode minor-mode-alist)) |
47 | (setq minor-mode-alist (cons '(vc-mode vc-mode) | |
594722a8 ER |
48 | minor-mode-alist))) |
49 | ||
7bc2b98b | 50 | (make-variable-buffer-local 'vc-mode) |
c43e436c | 51 | (put 'vc-mode 'permanent-local t) |
594722a8 ER |
52 | |
53 | ;; We need a notion of per-file properties because the version | |
54 | ;; control state of a file is expensive to derive --- we don't | |
55 | ;; want to recompute it even on every find. | |
56 | ||
80169ab5 ER |
57 | (defmacro vc-error-occurred (&rest body) |
58 | (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t))) | |
59 | ||
594722a8 ER |
60 | (defvar vc-file-prop-obarray [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0] |
61 | "Obarray for per-file properties.") | |
62 | ||
63 | (defun vc-file-setprop (file property value) | |
64 | ;; set per-file property | |
65 | (put (intern file vc-file-prop-obarray) property value)) | |
66 | ||
67 | (defun vc-file-getprop (file property) | |
68 | ;; get per-file property | |
69 | (get (intern file vc-file-prop-obarray) property)) | |
70 | ||
71 | ;;; actual version-control code starts here | |
72 | ||
73 | (defun vc-registered (file) | |
18c8a18e PE |
74 | (let (handler handlers) |
75 | (if (boundp 'file-name-handler-alist) | |
76 | (save-match-data | |
77 | (setq handlers file-name-handler-alist) | |
78 | (while (and (consp handlers) (null handler)) | |
79 | (if (and (consp (car handlers)) | |
80 | (stringp (car (car handlers))) | |
81 | (string-match (car (car handlers)) file)) | |
82 | (setq handler (cdr (car handlers)))) | |
83 | (setq handlers (cdr handlers))))) | |
84 | (if handler | |
85 | (funcall handler 'vc-registered file) | |
86 | ;; Search for a master corresponding to the given file | |
87 | (let ((dirname (or (file-name-directory file) "")) | |
88 | (basename (file-name-nondirectory file))) | |
89 | (catch 'found | |
90 | (mapcar | |
91 | (function (lambda (s) | |
92 | (let ((trial (format (car s) dirname basename))) | |
93 | (if (and (file-exists-p trial) | |
94 | ;; Make sure the file we found with name | |
95 | ;; TRIAL is not the source file itself. | |
96 | ;; That can happen with RCS-style names | |
97 | ;; if the file name is truncated | |
98 | ;; (e.g. to 14 chars). See if either | |
99 | ;; directory or attributes differ. | |
100 | (or (not (string= dirname | |
101 | (file-name-directory trial))) | |
102 | (not (equal | |
103 | (file-attributes file) | |
104 | (file-attributes trial))))) | |
105 | (throw 'found (cons trial (cdr s))))))) | |
106 | vc-master-templates) | |
107 | nil))))) | |
594722a8 | 108 | |
a03140c8 PE |
109 | (defun vc-name (file) |
110 | "Return the master name of a file, nil if it is not registered." | |
111 | (or (vc-file-getprop file 'vc-name) | |
112 | (let ((name-and-type (vc-registered file))) | |
113 | (if name-and-type | |
114 | (progn | |
115 | (vc-file-setprop file 'vc-backend (cdr name-and-type)) | |
116 | (vc-file-setprop file 'vc-name (car name-and-type))))))) | |
117 | ||
594722a8 | 118 | (defun vc-backend-deduce (file) |
a03140c8 | 119 | "Return the version-control type of a file, nil if it is not registered." |
594722a8 ER |
120 | (and file |
121 | (or (vc-file-getprop file 'vc-backend) | |
a03140c8 PE |
122 | (let ((name-and-type (vc-registered file))) |
123 | (if name-and-type | |
124 | (progn | |
125 | (vc-file-setprop file 'vc-name (car name-and-type)) | |
126 | (vc-file-setprop file 'vc-backend (cdr name-and-type)))))))) | |
594722a8 ER |
127 | |
128 | (defun vc-toggle-read-only () | |
c43e436c RS |
129 | "Change read-only status of current buffer, perhaps via version control. |
130 | If the buffer is visiting a file registered with version control, | |
131 | then check the file in or out. Otherwise, just change the read-only flag | |
132 | of the buffer." | |
594722a8 ER |
133 | (interactive) |
134 | (if (vc-backend-deduce (buffer-file-name)) | |
135 | (vc-next-action nil) | |
136 | (toggle-read-only))) | |
c43e436c | 137 | (define-key global-map "\C-x\C-q" 'vc-toggle-read-only) |
594722a8 ER |
138 | |
139 | (defun vc-mode-line (file &optional label) | |
7bc2b98b | 140 | "Set `vc-mode' to display type of version control for FILE. |
594722a8 ER |
141 | The value is set in the current buffer, which should be the buffer |
142 | visiting FILE." | |
18c8a18e | 143 | (interactive (list buffer-file-name nil)) |
594722a8 | 144 | (let ((vc-type (vc-backend-deduce file))) |
e6258b33 PE |
145 | (setq vc-mode |
146 | (and vc-type | |
147 | (concat " " (or label (symbol-name vc-type)) | |
148 | (if (and vc-rcs-status (eq vc-type 'RCS)) | |
149 | (vc-rcs-status file))))) | |
4a7e63b9 RS |
150 | ;; Even root shouldn't modify a registered file without locking it first. |
151 | (and vc-type | |
152 | (not buffer-read-only) | |
153 | (zerop (user-uid)) | |
154 | (require 'vc) | |
155 | (not (string-equal (user-login-name) (vc-locking-user file))) | |
156 | (setq buffer-read-only t)) | |
d4353b20 ER |
157 | (force-mode-line-update) |
158 | ;;(set-buffer-modified-p (buffer-modified-p)) ;;use this if Emacs 18 | |
594722a8 ER |
159 | vc-type)) |
160 | ||
198d5c00 | 161 | (defun vc-rcs-status (file) |
45c92c0c PE |
162 | ;; Return string for placement in modeline by `vc-mode-line'. |
163 | ;; If FILE is not registered under RCS, return nil. | |
164 | ;; If FILE is registered but not locked, return " REV" if there is a head | |
165 | ;; revision and " @@" otherwise. | |
166 | ;; If FILE is locked then return all locks in a string of the | |
b0c901a3 PE |
167 | ;; form " LOCKER1:REV1 LOCKER2:REV2 ...", where "LOCKERi:" is empty if you |
168 | ;; are the locker, and otherwise is the name of the locker followed by ":". | |
198d5c00 RS |
169 | |
170 | ;; Algorithm: | |
171 | ||
a03140c8 | 172 | ;; 1. Check for master file corresponding to FILE being visited. |
198d5c00 | 173 | ;; |
a03140c8 | 174 | ;; 2. Insert the first few characters of the master file into a work |
198d5c00 RS |
175 | ;; buffer. |
176 | ;; | |
137fcf31 PE |
177 | ;; 3. Search work buffer for "locks...;" phrase; if not found, then |
178 | ;; keep inserting more characters until the phrase is found. | |
198d5c00 | 179 | ;; |
137fcf31 | 180 | ;; 4. Extract the locks, and remove control characters |
198d5c00 RS |
181 | ;; separating them, like newlines; the string " user1:revision1 |
182 | ;; user2:revision2 ..." is returned. | |
198d5c00 RS |
183 | |
184 | ;; Limitations: | |
185 | ||
186 | ;; The output doesn't show which version you are actually looking at. | |
187 | ;; The modeline can get quite cluttered when there are multiple locks. | |
45c92c0c | 188 | ;; The head revision is probably not what you want if you've used `rcs -b'. |
198d5c00 | 189 | |
a03140c8 | 190 | (let ((master (vc-name file)) |
137fcf31 | 191 | found) |
198d5c00 RS |
192 | |
193 | ;; If master file exists, then parse its contents, otherwise we return the | |
194 | ;; nil value of this if form. | |
a03140c8 | 195 | (if master |
198d5c00 RS |
196 | (save-excursion |
197 | ||
198 | ;; Create work buffer. | |
e4953cae | 199 | (set-buffer (get-buffer-create " *vc-rcs-status*")) |
198d5c00 RS |
200 | (setq buffer-read-only nil |
201 | default-directory (file-name-directory master)) | |
202 | (erase-buffer) | |
203 | ||
a03140c8 PE |
204 | ;; Check if we have enough of the header. |
205 | ;; If not, then keep including more. | |
206 | (while | |
207 | (not (or found | |
208 | (let ((s (buffer-size))) | |
209 | (goto-char (1+ s)) | |
210 | (zerop (car (cdr (insert-file-contents | |
211 | master nil s (+ s 8192)))))))) | |
212 | (beginning-of-line) | |
213 | (setq found (re-search-forward "^locks\\([^;]*\\);" nil t))) | |
198d5c00 | 214 | |
198d5c00 | 215 | (if found |
b0c901a3 PE |
216 | ;; Clean control characters and self-locks from text. |
217 | (let* ((lock-pattern | |
218 | (concat "[ \b\t\n\v\f\r]+\\(" | |
219 | (regexp-quote (user-login-name)) | |
f5baea11 | 220 | ":\\)?")) |
b0c901a3 | 221 | (locks |
45c92c0c PE |
222 | (save-restriction |
223 | (narrow-to-region (match-beginning 1) (match-end 1)) | |
224 | (goto-char (point-min)) | |
b0c901a3 | 225 | (while (re-search-forward lock-pattern nil t) |
5032bd23 | 226 | (replace-match (if (eobp) "" ":") t t)) |
45c92c0c PE |
227 | (buffer-string))) |
228 | (status | |
229 | (if (not (string-equal locks "")) | |
230 | locks | |
231 | (goto-char (point-min)) | |
232 | (if (looking-at "head[ \b\t\n\v\f\r]+\\([.0-9]+\\)") | |
f5baea11 | 233 | (concat "-" (buffer-substring (match-beginning 1) |
45c92c0c PE |
234 | (match-end 1))) |
235 | " @@")))) | |
a03140c8 PE |
236 | ;; Clean work buffer. |
237 | (erase-buffer) | |
238 | (set-buffer-modified-p nil) | |
239 | status)))))) | |
198d5c00 | 240 | |
594722a8 ER |
241 | ;;; install a call to the above as a find-file hook |
242 | (defun vc-find-file-hook () | |
18c8a18e PE |
243 | ;; Recompute whether file is version controlled, |
244 | ;; if user has killed the buffer and revisited. | |
3c9c43d9 RS |
245 | (if buffer-file-name |
246 | (vc-file-setprop buffer-file-name 'vc-backend nil)) | |
594722a8 ER |
247 | (if (and (vc-mode-line buffer-file-name) (not vc-make-backup-files)) |
248 | (progn | |
b5bcaf3e RS |
249 | ;; Use this variable, not make-backup-files, |
250 | ;; because this is for things that depend on the file name. | |
251 | (make-local-variable 'backup-inhibited) | |
252 | (setq backup-inhibited t)))) | |
594722a8 | 253 | |
6379911c | 254 | (add-hook 'find-file-hooks 'vc-find-file-hook) |
594722a8 ER |
255 | |
256 | ;;; more hooks, this time for file-not-found | |
257 | (defun vc-file-not-found-hook () | |
258 | "When file is not found, try to check it out from RCS or SCCS. | |
259 | Returns t if checkout was successful, nil otherwise." | |
260 | (if (vc-backend-deduce buffer-file-name) | |
261 | (progn | |
262 | (require 'vc) | |
263 | (not (vc-error-occurred (vc-checkout buffer-file-name)))))) | |
264 | ||
6379911c | 265 | (add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook) |
594722a8 ER |
266 | |
267 | ;;; Now arrange for bindings and autoloading of the main package. | |
7bc2b98b ER |
268 | ;;; Bindings for this have to go in the global map, as we'll often |
269 | ;;; want to call them from random buffers. | |
594722a8 ER |
270 | |
271 | (setq vc-prefix-map (lookup-key global-map "\C-xv")) | |
272 | (if (not (keymapp vc-prefix-map)) | |
273 | (progn | |
274 | (setq vc-prefix-map (make-sparse-keymap)) | |
275 | (define-key global-map "\C-xv" vc-prefix-map) | |
276 | (define-key vc-prefix-map "a" 'vc-update-change-log) | |
277 | (define-key vc-prefix-map "c" 'vc-cancel-version) | |
18c8a18e | 278 | (define-key vc-prefix-map "d" 'vc-directory) |
594722a8 ER |
279 | (define-key vc-prefix-map "h" 'vc-insert-headers) |
280 | (define-key vc-prefix-map "i" 'vc-register) | |
281 | (define-key vc-prefix-map "l" 'vc-print-log) | |
282 | (define-key vc-prefix-map "r" 'vc-retrieve-snapshot) | |
283 | (define-key vc-prefix-map "s" 'vc-create-snapshot) | |
284 | (define-key vc-prefix-map "u" 'vc-revert-buffer) | |
285 | (define-key vc-prefix-map "v" 'vc-next-action) | |
18c8a18e | 286 | (define-key vc-prefix-map "=" 'vc-diff) |
c574acf0 | 287 | (define-key vc-prefix-map "~" 'vc-version-other-window) |
594722a8 ER |
288 | )) |
289 | ||
594722a8 ER |
290 | (provide 'vc-hooks) |
291 | ||
292 | ;;; vc-hooks.el ends here |