aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorRichard M. Stallman1995-06-15 23:06:45 +0000
committerRichard M. Stallman1995-06-15 23:06:45 +0000
commit02d383ebf9018c5fbf241dac931964a52252aecb (patch)
tree5683e886723a5cbc4658f5b459dbc1ee7f242119
parentdc88ce1a488138628a28f8230105f64fa4237a0f (diff)
downloademacs-02d383ebf9018c5fbf241dac931964a52252aecb.tar.gz
emacs-02d383ebf9018c5fbf241dac931964a52252aecb.zip
The RCS status is now found by reading the
master file directly, instead of using rlog. The properties retrieved from the master file are kept separately. The two main properties, `vc-workfile-version' and `vc-locking-user', are inferred from those master file properties if the information cannot be found elsehow. All properties are consistently cached now. (vc-master-info, vc-log-info, vc-fetch-properties): functions removed. Their job is now done by `vc-fetch-master-properties' and `vc-insert-file'. (vc-fetch-master-properties): new function, replaces vc-fetch-properties. Retrieves all the properties that can be found in the master file, for all three backends (calls `cvs status' in the CVS case). (vc-insert-file): new function. Inserts an arbitrary file into the current buffer, optionally chunkwise, until a certain regexp shows up. (vc-parse-locks): new function. Translates SCCS or RCS lock lists, as found in the master files, into lisp lists. Sets the new property `vc-master-locks'. (vc-locked-version): property removed. Was unnecessary, and only referenced in vc-hooks.el. (vc-head-version, vc-default-branch, vc-master-locks): new properties. (vc-top-version): new name for the old property `vc-branch-version'. ("top-version" is better because it might also be the RCS "head" if there is no default branch.) (vc-master-locking-user): replaces `vc-true-locking-user'. Scans the new `vc-master-locks' property, yielding the master file's idea of who is locking the current workfile version. (vc-locking-user): slightly changed to use the new properties. Changed the actual property value for an unlocked file to 'none. This is to distinguish it from an unknown locking state, which is represented by nil. The function vc-locking-user returns nil if the property is 'none, to make it compatible with the rest of VC. (vc-consult-rcs-headers, vc-master-locking-user): adpated to the new 'none-value of vc-locking-user. (vc-consult-rcs-headers): fixed bug that prevented (not vc-consult-headers) from working (vc-file-not-found-hook): set the default-directory of the new buffer before check-out. (Otherwise, setting vc-keep-workfiles to nil doesn't work.) (vc-occurences, vc-branch-p): functions removed (no longer needed) Reordered some defuns so they are grouped in a logical way.
-rw-r--r--lisp/vc-hooks.el577
1 files changed, 296 insertions, 281 deletions
diff --git a/lisp/vc-hooks.el b/lisp/vc-hooks.el
index c875a581024..f537980fbd3 100644
--- a/lisp/vc-hooks.el
+++ b/lisp/vc-hooks.el
@@ -79,24 +79,6 @@ value of this flag.")
79(make-variable-buffer-local 'vc-mode) 79(make-variable-buffer-local 'vc-mode)
80(put 'vc-mode 'permanent-local t) 80(put 'vc-mode 'permanent-local t)
81 81
82
83;; branch identification
84
85(defun vc-occurrences (object sequence)
86 ;; return the number of occurences of OBJECT in SEQUENCE
87 ;; (is it really true that Emacs Lisp doesn't provide such a function?)
88 (let ((len (length sequence)) (index 0) (occ 0))
89 (while (< index len)
90 (if (eq object (elt sequence index))
91 (setq occ (1+ occ)))
92 (setq index (1+ index)))
93 occ))
94
95(defun vc-branch-p (rev)
96 ;; return t if REV is the branch part of a revision,
97 ;; i.e. a revision without a minor number
98 (eq 0 (% (vc-occurrences ?. rev) 2)))
99
100;; We need a notion of per-file properties because the version 82;; We need a notion of per-file properties because the version
101;; control state of a file is expensive to derive --- we compute 83;; control state of a file is expensive to derive --- we compute
102;; them when the file is initially found, keep them up to date 84;; them when the file is initially found, keep them up to date
@@ -124,28 +106,8 @@ value of this flag.")
124 ;; clear all properties of a given file 106 ;; clear all properties of a given file
125 (setplist (intern file vc-file-prop-obarray) nil)) 107 (setplist (intern file vc-file-prop-obarray) nil))
126 108
127;; basic properties 109;;; Functions that determine property values, by examining the
128 110;;; working file, the master file, or log program output
129(defun vc-name (file)
130 "Return the master name of a file, nil if it is not registered."
131 (or (vc-file-getprop file 'vc-name)
132 (let ((name-and-type (vc-registered file)))
133 (if name-and-type
134 (progn
135 (vc-file-setprop file 'vc-backend (cdr name-and-type))
136 (vc-file-setprop file 'vc-name (car name-and-type)))))))
137
138(defun vc-backend (file)
139 "Return the version-control type of a file, nil if it is not registered."
140 (and file
141 (or (vc-file-getprop file 'vc-backend)
142 (let ((name-and-type (vc-registered file)))
143 (if name-and-type
144 (progn
145 (vc-file-setprop file 'vc-name (car name-and-type))
146 (vc-file-setprop file 'vc-backend (cdr name-and-type))))))))
147
148;; Functions for querying the master and lock files.
149 111
150(defun vc-match-substring (bn) 112(defun vc-match-substring (bn)
151 (buffer-substring (match-beginning bn) (match-end bn))) 113 (buffer-substring (match-beginning bn) (match-end bn)))
@@ -199,95 +161,154 @@ value of this flag.")
199 patterns) 161 patterns)
200 ) 162 )
201 163
202(defun vc-master-info (file fields &optional rfile properties) 164(defun vc-insert-file (file &optional limit blocksize)
203 ;; Search for information in a master file. 165 ;; Insert the contents of FILE into the current buffer.
204 (if (and file (file-exists-p file)) 166 ;; Optional argument LIMIT is a regexp. If present,
205 (save-excursion 167 ;; the file is inserted in chunks of size BLOCKSIZE
206 (let ((buf)) 168 ;; (default 8 kByte), until the first occurence of
207 (setq buf (create-file-buffer file)) 169 ;; LIMIT is found. The function returns nil if FILE
208 (set-buffer buf)) 170 ;; doesn't exist.
209 (erase-buffer) 171 (cond ((file-exists-p file)
210 (insert-file-contents file) 172 (cond (limit
211 (set-buffer-modified-p nil) 173 (if (not blocksize) (setq blocksize 8192))
212 (auto-save-mode nil) 174 (let (found s)
213 (prog1 175 (while (not found)
214 (vc-parse-buffer fields rfile properties) 176 (setq s (buffer-size))
215 (kill-buffer (current-buffer))) 177 (goto-char (1+ s))
216 ) 178 (setq found
217 (if rfile 179 (or (zerop (car (cdr
218 (mapcar 180 (insert-file-contents file nil s
219 (function (lambda (p) (vc-file-setprop rfile p nil))) 181 (+ s blocksize)))))
220 properties)) 182 (progn (beginning-of-line)
221 ) 183 (re-search-forward limit nil t)))))))
222 ) 184 (t (insert-file-contents file)))
223 185 (set-buffer-modified-p nil)
224(defun vc-log-info (command file flags patterns &optional properties) 186 (auto-save-mode nil)
225 ;; Search for information in log program output. 187 t)
226 ;; If there is a string `\X' in any of the PATTERNS, replace 188 (t nil)))
227 ;; it with a regexp to search for a branch revision. 189
228 (if (and file (file-exists-p file)) 190(defun vc-parse-locks (file locks)
229 (save-excursion 191 ;; Parse RCS or SCCS locks.
230 ;; Run the command (not using vc-do-command, as that is 192 ;; The result is a list of the form ((VERSION USER) (VERSION USER) ...),
231 ;; only available within vc.el) 193 ;; which is returned and stored into the property `vc-master-locks'.
232 ;; Don't switch to the *vc* buffer before running the command 194 (if (not locks)
233 ;; because that would change its default-directory. 195 (vc-file-setprop file 'vc-master-locks 'none)
234 (save-excursion (set-buffer (get-buffer-create "*vc*")) 196 (let ((found t) (index 0) master-locks version user)
235 (erase-buffer)) 197 (cond ((eq (vc-backend file) 'SCCS)
236 (let ((exec-path (append vc-path exec-path)) 198 (while (string-match "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
237 ;; Add vc-path to PATH for the execution of this command. 199 locks index)
238 (process-environment 200 (setq version (substring locks
239 (cons (concat "PATH=" (getenv "PATH") 201 (match-beginning 1) (match-end 1)))
240 path-separator 202 (setq user (substring locks
241 (mapconcat 'identity vc-path path-separator)) 203 (match-beginning 2) (match-end 2)))
242 process-environment))) 204 (setq master-locks (append master-locks
243 (apply 'call-process command nil "*vc*" nil 205 (list (cons version user))))
244 (append flags (list (file-name-nondirectory file))))) 206 (setq index (match-end 0))))
245 (set-buffer (get-buffer "*vc*")) 207 ((eq (vc-backend file) 'RCS)
246 (set-buffer-modified-p nil) 208 (while (string-match "[ \t\n]*\\([^:]+\\):\\([0-9.]+\\)"
247 ;; in the RCS case, insert branch version into 209 locks index)
248 ;; any patterns that contain \X 210 (setq version (substring locks
249 (if (eq (vc-backend file) 'RCS) 211 (match-beginning 2) (match-end 2)))
250 (let ((branch 212 (setq user (substring locks
251 (car (vc-parse-buffer 213 (match-beginning 1) (match-end 1)))
252 '(("^branch:[ \t]+\\([0-9.]+\\)$" 1)))))) 214 (setq master-locks (append master-locks
253 (setq patterns 215 (list (cons version user))))
254 (mapcar 216 (setq index (match-end 0)))))
255 (function 217 (vc-file-setprop file 'vc-master-locks (or master-locks 'none)))))
256 (lambda (p) 218
257 (if (string-match "\\\\X" (car p)) 219(defun vc-fetch-master-properties (file)
258 (if branch 220 ;; Fetch those properties of FILE that are stored in the master file.
259 (cond ((vc-branch-p branch) 221 (save-excursion
260 (cons 222 (cond
261 (concat 223 ((eq (vc-backend file) 'SCCS)
262 (substring (car p) 0 (match-beginning 0)) 224 (set-buffer (get-buffer-create "*vc-info*"))
263 (regexp-quote branch) 225 (if (vc-insert-file (vc-lock-file file))
264 "\\.[0-9]+" 226 (progn (vc-parse-locks file (buffer-string))
265 (substring (car p) (match-end 0))) 227 (erase-buffer))
266 (cdr p))) 228 (vc-file-setprop file 'vc-master-locks 'none))
267 (t 229 (vc-insert-file (vc-name file) "^\001e")
268 (cons 230 (vc-parse-buffer
269 (concat 231 (list '("^\001d D \\([^ ]+\\)" 1)
270 (substring (car p) 0 (match-beginning 0)) 232 (list (concat "^\001d D \\([^ ]+\\) .* "
271 (regexp-quote branch) 233 (regexp-quote (user-login-name)) " ") 1))
272 (substring (car p) (match-end 0))) 234 file
273 (cdr p)))) 235 '(vc-latest-version vc-your-latest-version)))
274 ;; if there is no current branch, 236
275 ;; return a completely different regexp, 237 ((eq (vc-backend file) 'RCS)
276 ;; which searches for the *head* 238 (set-buffer (get-buffer-create "*vc-info*"))
277 '("^head:[ \t]+\\([0-9.]+\\)$" 1)) 239 (vc-insert-file (vc-name file) "^desc")
278 p))) 240 (vc-parse-buffer
279 patterns)))) 241 (list '("^head[ \t\n]+\\([^;]+\\);" 1)
280 (prog1 242 '("^branch[ \t\n]+\\([^;]+\\);" 1)
281 (vc-parse-buffer patterns file properties) 243 '("^locks\\([^;]+\\);" 1)
282 (kill-buffer (current-buffer)) 244 '("^\\([0-9]+\\.[0-9.]+\\)\ndate[ \t]+\\([0-9.]+\\);" 1 2)
283 ) 245 (list (concat "^\\([0-9]+\\.[0-9.]+\\)\n"
284 ) 246 "date[ \t]+\\([0-9.]+\\);[ \t]+"
285 (if file 247 "author[ \t]+"
286 (mapcar 248 (regexp-quote (user-login-name)) ";") 1 2))
287 (function (lambda (p) (vc-file-setprop file p nil))) 249 file
288 properties)) 250 '(vc-head-version
289 ) 251 vc-default-branch
290 ) 252 vc-master-locks
253 vc-latest-version
254 vc-your-latest-version))
255 ;; determine vc-top-version: it is either the head version,
256 ;; or the tip of the default branch
257 (let ((default-branch (vc-file-getprop file 'vc-default-branch)))
258 (cond
259 ;; no default branch
260 ((or (not default-branch) (string= "" default-branch))
261 (vc-file-setprop file 'vc-top-version
262 (vc-file-getprop file 'vc-head-version)))
263 ;; default branch is actually a revision
264 ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
265 default-branch)
266 (vc-file-setprop file 'vc-top-version default-branch))
267 ;; else, search for the tip of the default branch
268 (t (vc-parse-buffer (list (list
269 (concat "^\\("
270 (regexp-quote default-branch)
271 "\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2))
272 file '(vc-top-version)))))
273 ;; translate the locks
274 (vc-parse-locks file (vc-file-getprop file 'vc-master-locks)))
275
276 ((eq (vc-backend file) 'CVS)
277 ;; don't switch to the *vc-info* buffer before running the
278 ;; command, because that would change its default directory
279 (save-excursion (set-buffer (get-buffer-create "*vc-info*"))
280 (erase-buffer))
281 (let ((exec-path (append vc-path exec-path))
282 ;; Add vc-path to PATH for the execution of this command.
283 (process-environment
284 (cons (concat "PATH=" (getenv "PATH")
285 ":" (mapconcat 'identity vc-path ":"))
286 process-environment)))
287 (apply 'call-process "cvs" nil "*vc-info*" nil
288 (list "status" (file-name-nondirectory file))))
289 (set-buffer (get-buffer "*vc-info*"))
290 (set-buffer-modified-p nil)
291 (auto-save-mode nil)
292 (vc-parse-buffer
293 ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
294 ;; and CVS 1.4a1 says "Repository revision:".
295 '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
296 ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
297 file
298 '(vc-latest-version vc-cvs-status))
299 ;; Translate those status values that are needed into symbols.
300 ;; Any other value is converted to nil.
301 (let ((status (vc-file-getprop file 'vc-cvs-status)))
302 (cond ((string-match "Up-to-date" status)
303 (vc-file-setprop file 'vc-cvs-status 'up-to-date)
304 (vc-file-setprop file 'vc-checkout-time
305 (nth 5 (file-attributes file))))
306 ((string-match "Locally Modified" status)
307 (vc-file-setprop file 'vc-cvs-status 'locally-modified))
308 ((string-match "Needs Merge" status)
309 (vc-file-setprop file 'vc-cvs-status 'needs-merge))
310 (t (vc-file-setprop file 'vc-cvs-status nil))))))
311 (kill-buffer (current-buffer))))
291 312
292;;; Functions that determine property values, by examining the 313;;; Functions that determine property values, by examining the
293;;; working file, the master file, or log program output 314;;; working file, the master file, or log program output
@@ -304,7 +325,7 @@ value of this flag.")
304 ;; 'rev-and-lock if revision and lock info was found 325 ;; 'rev-and-lock if revision and lock info was found
305 (cond 326 (cond
306 ((or (not vc-consult-headers) 327 ((or (not vc-consult-headers)
307 (not (get-file-buffer file)) nil)) 328 (not (get-file-buffer file))) nil)
308 ((save-excursion 329 ((save-excursion
309 (set-buffer (get-file-buffer file)) 330 (set-buffer (get-file-buffer file))
310 (goto-char (point-min)) 331 (goto-char (point-min))
@@ -326,8 +347,7 @@ value of this flag.")
326 ;; unlocked revision 347 ;; unlocked revision
327 ((looking-at "\\$") 348 ((looking-at "\\$")
328 (vc-file-setprop file 'vc-workfile-version rev) 349 (vc-file-setprop file 'vc-workfile-version rev)
329 (vc-file-setprop file 'vc-locking-user nil) 350 (vc-file-setprop file 'vc-locking-user 'none)
330 (vc-file-setprop file 'vc-locked-version nil)
331 'rev-and-lock) 351 'rev-and-lock)
332 ;; revision is locked by some user 352 ;; revision is locked by some user
333 ((looking-at "\\([^ ]+\\) \\$") 353 ((looking-at "\\([^ ]+\\) \\$")
@@ -335,7 +355,6 @@ value of this flag.")
335 (vc-file-setprop file 'vc-locking-user 355 (vc-file-setprop file 'vc-locking-user
336 (buffer-substring (match-beginning 1) 356 (buffer-substring (match-beginning 1)
337 (match-end 1))) 357 (match-end 1)))
338 (vc-file-setprop file 'vc-locked-version rev)
339 'rev-and-lock) 358 'rev-and-lock)
340 ;; everything else: false 359 ;; everything else: false
341 (nil)) 360 (nil))
@@ -358,15 +377,14 @@ value of this flag.")
358 (vc-file-setprop file 'vc-locking-user 377 (vc-file-setprop file 'vc-locking-user
359 (buffer-substring (match-beginning 1) 378 (buffer-substring (match-beginning 1)
360 (match-end 1))) 379 (match-end 1)))
361 (vc-file-setprop file 'vc-locked-version rev)
362 'rev-and-lock) 380 'rev-and-lock)
363 ((looking-at " *\\$") 381 ((looking-at " *\\$")
364 (vc-file-setprop file 'vc-workfile-version rev) 382 (vc-file-setprop file 'vc-workfile-version rev)
365 (vc-file-setprop file 'vc-locking-user nil) 383 (vc-file-setprop file 'vc-locking-user 'none)
366 (vc-file-setprop file 'vc-locked-version nil)
367 'rev-and-lock) 384 'rev-and-lock)
368 (t 385 (t
369 (vc-file-setprop file 'vc-workfile-version rev) 386 (vc-file-setprop file 'vc-workfile-version rev)
387 (vc-file-setprop file 'vc-locking-user 'none)
370 'rev-and-lock)) 388 'rev-and-lock))
371 (vc-file-setprop file 'vc-workfile-version rev) 389 (vc-file-setprop file 'vc-workfile-version rev)
372 'rev))) 390 'rev)))
@@ -374,67 +392,15 @@ value of this flag.")
374 ;; ------------------- 392 ;; -------------------
375 (t nil)))))) 393 (t nil))))))
376 394
377(defun vc-fetch-properties (file) 395;;; Access functions to file properties
378 ;; Re-fetch some properties associated with the given file. 396;;; (Properties should be _set_ using vc-file-setprop, but
379 (cond 397;;; _retrieved_ only through these functions, which decide
380 ((eq (vc-backend file) 'SCCS) 398;;; if the property is already known or not. A property should
381 (progn 399;;; only be retrieved by vc-file-getprop if there is no
382 (vc-master-info (vc-lock-file file) 400;;; access function.)
383 (list 401
384 '("^[^ ]+ [^ ]+ \\([^ ]+\\)" 1) 402;;; properties indicating the backend
385 '("^\\([^ ]+\\)" 1)) 403;;; being used for FILE
386 file
387 '(vc-locking-user vc-locked-version))
388 (vc-master-info (vc-name file)
389 (list
390 '("^\001d D \\([^ ]+\\)" 1)
391 (list (concat "^\001d D \\([^ ]+\\) .* "
392 (regexp-quote (user-login-name)) " ")
393 1)
394 )
395 file
396 '(vc-latest-version vc-your-latest-version))
397 ))
398 ((eq (vc-backend file) 'RCS)
399 (vc-log-info "rlog" file nil
400 (list
401 '("^locks: strict\n\t\\([^:]+\\)" 1)
402 '("^locks: strict\n\t[^:]+: \\(.+\\)" 1)
403 '("^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3)
404 (list
405 (concat
406 "^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\); *author: "
407 (regexp-quote (user-login-name))
408 ";") 1 3)
409 ;; special regexp to search for branch revision:
410 ;; \X will be replaced by vc-log-info (see there)
411 '("^revision[\t ]+\\(\\X\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3))
412
413 '(vc-locking-user
414 vc-locked-version
415 vc-latest-version
416 vc-your-latest-version
417 vc-branch-version)))
418 ((eq (vc-backend file) 'CVS)
419 (vc-log-info "cvs" file '("status")
420 ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
421 ;; and CVS 1.4a1 says "Repository revision:".
422 '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
423 ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
424 '(vc-latest-version vc-cvs-status))
425 ;; Translate those status values that are needed into symbols.
426 ;; Any other value is converted to nil.
427 (let ((status (vc-file-getprop file 'vc-cvs-status)))
428 (cond ((string-match "Up-to-date" status)
429 (vc-file-setprop file 'vc-cvs-status 'up-to-date)
430 (vc-file-setprop file 'vc-checkout-time
431 (nth 5 (file-attributes file))))
432 ((string-match "Locally Modified" status)
433 (vc-file-setprop file 'vc-cvs-status 'locally-modified))
434 ((string-match "Needs Merge" status)
435 (vc-file-setprop file 'vc-cvs-status 'needs-merge))
436 (t (vc-file-setprop file 'vc-cvs-status nil))))
437 )))
438 404
439(defun vc-backend-subdirectory-name (&optional file) 405(defun vc-backend-subdirectory-name (&optional file)
440 ;; Where the master and lock files for the current directory are kept 406 ;; Where the master and lock files for the current directory are kept
@@ -444,115 +410,163 @@ value of this flag.")
444 vc-default-back-end 410 vc-default-back-end
445 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS))))) 411 (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))
446 412
413(defun vc-name (file)
414 "Return the master name of a file, nil if it is not registered."
415 (or (vc-file-getprop file 'vc-name)
416 (let ((name-and-type (vc-registered file)))
417 (if name-and-type
418 (progn
419 (vc-file-setprop file 'vc-backend (cdr name-and-type))
420 (vc-file-setprop file 'vc-name (car name-and-type)))))))
447 421
448;;; Access functions to file properties 422(defun vc-backend (file)
449;;; (Properties should be _set_ using vc-file-setprop, but 423 "Return the version-control type of a file, nil if it is not registered."
450;;; _retrieved_ only through these functions, which decide 424 (and file
451;;; if the property is already known or not. A property should 425 (or (vc-file-getprop file 'vc-backend)
452;;; only be retrieved by vc-file-getprop if there is no 426 (let ((name-and-type (vc-registered file)))
453;;; access function.) 427 (if name-and-type
428 (progn
429 (vc-file-setprop file 'vc-name (car name-and-type))
430 (vc-file-setprop file 'vc-backend (cdr name-and-type))))))))
454 431
455;; functions vc-name and vc-backend come earlier above, 432;;; properties indicating the locking state
456;; because they are needed by vc-log-info etc.
457 433
458(defun vc-cvs-status (file) 434(defun vc-cvs-status (file)
459 ;; Return the cvs status of FILE 435 ;; Return the cvs status of FILE
460 ;; (Status field in output of "cvs status") 436 ;; (Status field in output of "cvs status")
461 (cond ((vc-file-getprop file 'vc-cvs-status)) 437 (cond ((vc-file-getprop file 'vc-cvs-status))
462 (t (vc-fetch-properties file) 438 (t (vc-fetch-master-properties file)
463 (vc-file-getprop file 'vc-cvs-status)))) 439 (vc-file-getprop file 'vc-cvs-status))))
464 440
441(defun vc-master-locks (file)
442 ;; Return the lock entries in the master of FILE.
443 ;; Return 'none if there are no such entries, and a list
444 ;; of the form ((VERSION USER) (VERSION USER) ...) otherwise.
445 (cond ((vc-file-getprop file 'vc-master-locks))
446 (t (vc-fetch-master-properties file)
447 (vc-file-getprop file 'vc-master-locks))))
448
449(defun vc-master-locking-user (file)
450 ;; Return the master file's idea of who is locking
451 ;; the current workfile version of FILE.
452 ;; Return 'none if it is not locked.
453 (let ((master-locks (vc-master-locks file)) lock)
454 (if (eq master-locks 'none) 'none
455 ;; search for a lock on the current workfile version
456 (setq lock (assoc (vc-workfile-version file) master-locks))
457 (cond (lock (cdr lock))
458 ('none)))))
459
465(defun vc-locking-user (file) 460(defun vc-locking-user (file)
466 "Return the name of the person currently holding a lock on FILE. 461 ;; Return the name of the person currently holding a lock on FILE.
467Return nil if there is no such person. 462 ;; Return nil if there is no such person.
468Under CVS, a file is considered locked if it has been modified since it 463 ;; Under CVS, a file is considered locked if it has been modified since
469was checked out. Under CVS, this will sometimes return the uid of 464 ;; it was checked out. Under CVS, this will sometimes return the uid of
470the owner of the file (as a number) instead of a string." 465 ;; the owner of the file (as a number) instead of a string.
471 ;; The property is cached. If it is non-nil, it is simply returned. 466 ;; The property is cached. It is only looked up if it is currently nil.
472 ;; The other routines clear it when the locking state changes. 467 ;; Note that, for a file that is not locked, the actual property value
473 (setq file (expand-file-name file));; ??? Work around bug in 19.0.4 468 ;; is 'none, to distinguish it from an unknown locking state. That value
474 (cond 469 ;; is converted to nil by this function, and returned to the caller.
475 ((vc-file-getprop file 'vc-locking-user)) 470 (let ((locking-user (vc-file-getprop file 'vc-locking-user)))
476 ((eq (vc-backend file) 'CVS) 471 (if locking-user
477 (if (eq (vc-cvs-status file) 'up-to-date) 472 ;; if we already know the property, return it
478 nil 473 (if (eq locking-user 'none) nil locking-user)
479 ;; The expression below should return the username of the owner 474
480 ;; of the file. It doesn't. It returns the username if it is 475 ;; otherwise, infer the property...
481 ;; you, or otherwise the UID of the owner of the file. The 476 (cond
482 ;; return value from this function is only used by 477 ;; in the CVS case, check the status
483 ;; vc-dired-reformat-line, and it does the proper thing if a UID 478 ((eq (vc-backend file) 'CVS)
484 ;; is returned. 479 (if (eq (vc-cvs-status file) 'up-to-date)
485 ;; 480 (vc-file-setprop file 'vc-locking-user 'none)
486 ;; The *proper* way to fix this would be to implement a built-in 481 ;; The expression below should return the username of the owner
487 ;; function in Emacs, say, (username UID), that returns the 482 ;; of the file. It doesn't. It returns the username if it is
488 ;; username of a given UID. 483 ;; you, or otherwise the UID of the owner of the file. The
489 ;; 484 ;; return value from this function is only used by
490 ;; The result of this hack is that vc-directory will print the 485 ;; vc-dired-reformat-line, and it does the proper thing if a UID
491 ;; name of the owner of the file for any files that are 486 ;; is returned.
492 ;; modified. 487 ;;
493 (let ((uid (nth 2 (file-attributes file)))) 488 ;; The *proper* way to fix this would be to implement a built-in
494 (if (= uid (user-uid)) 489 ;; function in Emacs, say, (username UID), that returns the
495 (vc-file-setprop file 'vc-locking-user (user-login-name)) 490 ;; username of a given UID.
496 (vc-file-setprop file 'vc-locking-user uid))))) 491 ;;
497 (t 492 ;; The result of this hack is that vc-directory will print the
498 (if (and (eq (vc-backend file) 'RCS) 493 ;; name of the owner of the file for any files that are
499 (eq (vc-consult-rcs-headers file) 'rev-and-lock)) 494 ;; modified.
500 (vc-file-getprop file 'vc-locking-user) 495 (let ((uid (nth 2 (file-attributes file))))
501 (if (or (not vc-keep-workfiles) 496 (if (= uid (user-uid))
502 (eq vc-mistrust-permissions 't) 497 (vc-file-setprop file 'vc-locking-user (user-login-name))
503 (and vc-mistrust-permissions 498 (vc-file-setprop file 'vc-locking-user uid)))))
504 (funcall vc-mistrust-permissions 499
505 (vc-backend-subdirectory-name file)))) 500 ;; RCS case: attempt a header search. If this feature is
506 (vc-file-setprop file 'vc-locking-user (vc-true-locking-user file)) 501 ;; disabled, vc-consult-rcs-headers always returns nil.
507 ;; This implementation assumes that any file which is under version 502 ((and (eq (vc-backend file) 'RCS)
508 ;; control and has -rw-r--r-- is locked by its owner. This is true 503 (eq (vc-consult-rcs-headers file) 'rev-and-lock)))
509 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. 504
510 ;; We have to be careful not to exclude files with execute bits on; 505 ;; if the file permissions are not trusted,
511 ;; scripts can be under version control too. Also, we must ignore 506 ;; use the information from the master file
512 ;; the group-read and other-read bits, since paranoid users turn them off. 507 ((or (not vc-keep-workfiles)
513 ;; This hack wins because calls to the very expensive vc-fetch-properties 508 (eq vc-mistrust-permissions 't)
514 ;; function only have to be made if (a) the file is locked by someone 509 (and vc-mistrust-permissions
515 ;; other than the current user, or (b) some untoward manipulation 510 (funcall vc-mistrust-permissions
516 ;; behind vc's back has changed the owner or the `group' or `other' 511 (vc-backend-subdirectory-name file))))
517 ;; write bits. 512 (vc-file-setprop file 'vc-locking-user (vc-master-locking-user file)))
518 (let ((attributes (file-attributes file))) 513
519 (cond ((string-match ".r-..-..-." (nth 8 attributes)) 514 ;; Otherwise: Use the file permissions. (But if it turns out that the
520 nil) 515 ;; file is not owned by the user, use the master file.)
521 ((and (= (nth 2 attributes) (user-uid)) 516 ;; This implementation assumes that any file which is under version
522 (string-match ".rw..-..-." (nth 8 attributes))) 517 ;; control and has -rw-r--r-- is locked by its owner. This is true
523 (vc-file-setprop file 'vc-locking-user (user-login-name))) 518 ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
524 (t 519 ;; We have to be careful not to exclude files with execute bits on;
525 (vc-file-setprop file 'vc-locking-user 520 ;; scripts can be under version control too. Also, we must ignore the
526 (vc-true-locking-user file)))))))))) 521 ;; group-read and other-read bits, since paranoid users turn them off.
527 522 ;; This hack wins because calls to the somewhat expensive
528(defun vc-true-locking-user (file) 523 ;; `vc-fetch-master-properties' function only have to be made if
529 ;; The slow but reliable version 524 ;; (a) the file is locked by someone other than the current user,
530 (vc-fetch-properties file) 525 ;; or (b) some untoward manipulation behind vc's back has changed
531 (vc-file-getprop file 'vc-locking-user)) 526 ;; the owner or the `group' or `other' write bits.
527 (t
528 (let ((attributes (file-attributes file)))
529 (cond ((string-match ".r-..-..-." (nth 8 attributes))
530 (vc-file-setprop file 'vc-locking-user 'none))
531 ((and (= (nth 2 attributes) (user-uid))
532 (string-match ".rw..-..-." (nth 8 attributes)))
533 (vc-file-setprop file 'vc-locking-user (user-login-name)))
534 (t
535 (vc-file-setprop file 'vc-locking-user
536 (vc-master-locking-user file))))
537 )))
538 ;; recursively call the function again,
539 ;; to convert a possible 'none value
540 (vc-locking-user file))))
541
542;;; properties to store current and recent version numbers
532 543
533(defun vc-latest-version (file) 544(defun vc-latest-version (file)
534 ;; Return version level of the latest version of FILE 545 ;; Return version level of the latest version of FILE
535 (vc-fetch-properties file) 546 (cond ((vc-file-getprop file 'vc-latest-version))
536 (vc-file-getprop file 'vc-latest-version)) 547 (t (vc-fetch-master-properties file)
548 (vc-file-getprop file 'vc-latest-version))))
537 549
538(defun vc-your-latest-version (file) 550(defun vc-your-latest-version (file)
539 ;; Return version level of the latest version of FILE checked in by you 551 ;; Return version level of the latest version of FILE checked in by you
540 (vc-fetch-properties file) 552 (cond ((vc-file-getprop file 'vc-your-latest-version))
541 (vc-file-getprop file 'vc-your-latest-version)) 553 (t (vc-fetch-master-properties file)
554 (vc-file-getprop file 'vc-your-latest-version))))
542 555
543(defun vc-branch-version (file) 556(defun vc-top-version (file)
544 ;; Return version level of the highest revision on the default branch 557 ;; Return version level of the highest revision on the default branch
545 ;; If there is no default branch, return the highest version number 558 ;; If there is no default branch, return the highest version number
546 ;; on the trunk. 559 ;; on the trunk.
547 ;; This property is defined for RCS only. 560 ;; This property is defined for RCS only.
548 (vc-fetch-properties file) 561 (cond ((vc-file-getprop file 'vc-top-version))
549 (vc-file-getprop file 'vc-branch-version)) 562 (t (vc-fetch-master-properties file)
563 (vc-file-getprop file 'vc-top-version))))
550 564
551(defun vc-workfile-version (file) 565(defun vc-workfile-version (file)
552 ;; Return version level of the current workfile FILE 566 ;; Return version level of the current workfile FILE
553 ;; This is attempted by first looking at the RCS keywords. 567 ;; This is attempted by first looking at the RCS keywords.
554 ;; If there are no keywords in the working file, 568 ;; If there are no keywords in the working file,
555 ;; vc-branch-version is taken. 569 ;; vc-top-version is taken.
556 ;; Note that this property is cached, that is, it is only 570 ;; Note that this property is cached, that is, it is only
557 ;; looked up if it is nil. 571 ;; looked up if it is nil.
558 ;; For SCCS, this property is equivalent to vc-latest-version. 572 ;; For SCCS, this property is equivalent to vc-latest-version.
@@ -561,7 +575,7 @@ the owner of the file (as a number) instead of a string."
561 ((eq (vc-backend file) 'RCS) 575 ((eq (vc-backend file) 'RCS)
562 (if (vc-consult-rcs-headers file) 576 (if (vc-consult-rcs-headers file)
563 (vc-file-getprop file 'vc-workfile-version) 577 (vc-file-getprop file 'vc-workfile-version)
564 (let ((rev (cond ((vc-branch-version file)) 578 (let ((rev (cond ((vc-top-version file))
565 ((vc-latest-version file))))) 579 ((vc-latest-version file)))))
566 (vc-file-setprop file 'vc-workfile-version rev) 580 (vc-file-setprop file 'vc-workfile-version rev)
567 rev))) 581 rev)))
@@ -759,6 +773,7 @@ Returns t if checkout was successful, nil otherwise."
759 (if (vc-backend buffer-file-name) 773 (if (vc-backend buffer-file-name)
760 (save-excursion 774 (save-excursion
761 (require 'vc) 775 (require 'vc)
776 (setq default-directory (file-name-directory (buffer-file-name)))
762 (not (vc-error-occurred (vc-checkout buffer-file-name)))))) 777 (not (vc-error-occurred (vc-checkout buffer-file-name))))))
763 778
764(add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook) 779(add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook)