Commit 7064821c authored by André Spiegel's avatar André Spiegel
Browse files

(vc-simple-command): New function.

(vc-fetch-master-properties): CVS case: Use it.
(vc-lock-from-permissions, vc-file-owner, vc-rcs-lock-from-diff):
New functions.
(vc-locking-user): Largely rewritten.  Uses the above, handles RCS
non-strict locking.  Under CVS in CVSREAD-mode, learn the locking state
from the permissions.
(vc-find-cvs-master): Use vc-insert-file, rather than
find-file-noselect. Greatly speeds up things.
(vc-consult-rcs-headers): Bug fix, return status in all cases.
parent 8967cd6e
...@@ -231,6 +231,29 @@ value of this flag.") ...@@ -231,6 +231,29 @@ value of this flag.")
(vc-file-setprop file 'vc-checkout-model 'implicit)))) (vc-file-setprop file 'vc-checkout-model 'implicit))))
(vc-file-setprop file 'vc-master-locks (or master-locks 'none))))) (vc-file-setprop file 'vc-master-locks (or master-locks 'none)))))
(defun vc-simple-command (okstatus command file &rest args)
;; Simple version of vc-do-command, for use in vc-hooks only.
;; Don't switch to the *vc-info* buffer before running the
;; command, because that would change its default directory
(save-excursion (set-buffer (get-buffer-create "*vc-info*"))
(erase-buffer))
(let ((exec-path (append vc-path exec-path)) exec-status
;; Add vc-path to PATH for the execution of this command.
(process-environment
(cons (concat "PATH=" (getenv "PATH")
path-separator
(mapconcat 'identity vc-path path-separator))
process-environment)))
(setq exec-status
(apply 'call-process command nil "*vc-info*" nil
(append args (list file))))
(cond ((> exec-status okstatus)
(switch-to-buffer (get-file-buffer file))
(shrink-window-if-larger-than-buffer
(display-buffer "*vc-info*"))
(error "Couldn't find version control information")))
exec-status))
(defun vc-fetch-master-properties (file) (defun vc-fetch-master-properties (file)
;; Fetch those properties of FILE that are stored in the master file. ;; Fetch those properties of FILE that are stored in the master file.
;; For an RCS file, we don't get vc-latest-version vc-your-latest-version ;; For an RCS file, we don't get vc-latest-version vc-your-latest-version
...@@ -287,28 +310,9 @@ value of this flag.") ...@@ -287,28 +310,9 @@ value of this flag.")
(vc-parse-locks file (vc-file-getprop file 'vc-master-locks))) (vc-parse-locks file (vc-file-getprop file 'vc-master-locks)))
((eq (vc-backend file) 'CVS) ((eq (vc-backend file) 'CVS)
;; don't switch to the *vc-info* buffer before running the (save-excursion
;; command, because that would change its default directory (vc-simple-command 0 "cvs" file "status")
(save-excursion (set-buffer (get-buffer-create "*vc-info*"))
(erase-buffer))
(let ((exec-path (append vc-path exec-path)) exec-status
;; Add vc-path to PATH for the execution of this command.
(process-environment
(cons (concat "PATH=" (getenv "PATH")
path-separator
(mapconcat 'identity vc-path path-separator))
process-environment)))
(setq exec-status
(apply 'call-process "cvs" nil "*vc-info*" nil
(list "status" file)))
(cond ((> exec-status 0)
(switch-to-buffer (get-file-buffer file))
(shrink-window-if-larger-than-buffer
(display-buffer "*vc-info*"))
(error "Couldn't find version control information"))))
(set-buffer (get-buffer "*vc-info*")) (set-buffer (get-buffer "*vc-info*"))
(set-buffer-modified-p nil)
(auto-save-mode nil)
(vc-parse-buffer (vc-parse-buffer
;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:", ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
;; and CVS 1.4a1 says "Repository revision:". ;; and CVS 1.4a1 says "Repository revision:".
...@@ -316,7 +320,7 @@ value of this flag.") ...@@ -316,7 +320,7 @@ value of this flag.")
("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1)) ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
file file
'(vc-latest-version vc-cvs-status)) '(vc-latest-version vc-cvs-status))
;; Translate those status values that are needed into symbols. ;; Translate those status values that we understand into symbols.
;; Any other value is converted to nil. ;; Any other value is converted to nil.
(let ((status (vc-file-getprop file 'vc-cvs-status))) (let ((status (vc-file-getprop file 'vc-cvs-status)))
(cond (cond
...@@ -331,7 +335,7 @@ value of this flag.") ...@@ -331,7 +335,7 @@ value of this flag.")
((string-match "Needs Checkout" status) 'needs-checkout) ((string-match "Needs Checkout" status) 'needs-checkout)
((string-match "Unresolved Conflict" status) 'unresolved-conflict) ((string-match "Unresolved Conflict" status) 'unresolved-conflict)
((string-match "Locally Added" status) 'locally-added) ((string-match "Locally Added" status) 'locally-added)
))))))) ))))))))
(if (get-buffer "*vc-info*") (if (get-buffer "*vc-info*")
(kill-buffer (get-buffer "*vc-info*"))))) (kill-buffer (get-buffer "*vc-info*")))))
...@@ -426,8 +430,8 @@ value of this flag.") ...@@ -426,8 +430,8 @@ value of this flag.")
(not (vc-locking-user file)) (not (vc-locking-user file))
(if (string-match ".r-..-..-." (nth 8 (file-attributes file))) (if (string-match ".r-..-..-." (nth 8 (file-attributes file)))
(vc-file-setprop file 'vc-checkout-model 'manual) (vc-file-setprop file 'vc-checkout-model 'manual)
(vc-file-setprop file 'vc-checkout-model 'implicit)) (vc-file-setprop file 'vc-checkout-model 'implicit)))
status))))) status))))
;;; Access functions to file properties ;;; Access functions to file properties
;;; (Properties should be _set_ using vc-file-setprop, but ;;; (Properties should be _set_ using vc-file-setprop, but
...@@ -511,62 +515,9 @@ value of this flag.") ...@@ -511,62 +515,9 @@ value of this flag.")
(cond (lock (cdr lock)) (cond (lock (cdr lock))
('none))))) ('none)))))
(defun vc-locking-user (file) (defun vc-lock-from-permissions (file)
;; Return the name of the person currently holding a lock on FILE. ;; If the permissions can be trusted for this file, determine the
;; Return nil if there is no such person. ;; locking state from them. Returns (user-login-name), `none', or nil.
;; Under CVS, a file is considered locked if it has been modified since
;; it was checked out. Under CVS, this will sometimes return the uid of
;; the owner of the file (as a number) instead of a string.
;; The property is cached. It is only looked up if it is currently nil.
;; Note that, for a file that is not locked, the actual property value
;; is 'none, to distinguish it from an unknown locking state. That value
;; is converted to nil by this function, and returned to the caller.
(let ((locking-user (vc-file-getprop file 'vc-locking-user)))
(if locking-user
;; if we already know the property, return it
(if (eq locking-user 'none) nil locking-user)
;; otherwise, infer the property...
(cond
;; in the CVS case, check the status
((eq (vc-backend file) 'CVS)
(if (or (eq (vc-cvs-status file) 'up-to-date)
(eq (vc-cvs-status file) 'needs-checkout))
(vc-file-setprop file 'vc-locking-user 'none)
;; The expression below should return the username of the owner
;; of the file. It doesn't. It returns the username if it is
;; you, or otherwise the UID of the owner of the file. The
;; return value from this function is only used by
;; vc-dired-reformat-line, and it does the proper thing if a UID
;; is returned.
;;
;; The *proper* way to fix this would be to implement a built-in
;; function in Emacs, say, (username UID), that returns the
;; username of a given UID.
;;
;; The result of this hack is that vc-directory will print the
;; name of the owner of the file for any files that are
;; modified.
(let ((uid (nth 2 (file-attributes file))))
(if (= uid (user-uid))
(vc-file-setprop file 'vc-locking-user (user-login-name))
(vc-file-setprop file 'vc-locking-user uid)))))
;; RCS case: attempt a header search. If this feature is
;; disabled, vc-consult-rcs-headers always returns nil.
((and (eq (vc-backend file) 'RCS)
(eq (vc-consult-rcs-headers file) 'rev-and-lock)))
;; if the file permissions are not trusted,
;; or if locking is not strict,
;; use the information from the master file
((or (not vc-keep-workfiles)
(vc-mistrust-permissions file)
(eq (vc-checkout-model file) 'implicit))
(vc-file-setprop file 'vc-locking-user (vc-master-locking-user file)))
;; Otherwise: Use the file permissions. (But if it turns out that the
;; file is not owned by the user, use the master file.)
;; This implementation assumes that any file which is under version ;; This implementation assumes that any file which is under version
;; control and has -rw-r--r-- is locked by its owner. This is true ;; control and has -rw-r--r-- is locked by its owner. This is true
;; for both RCS and SCCS, which keep unlocked files at -r--r--r--. ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
...@@ -578,20 +529,104 @@ value of this flag.") ...@@ -578,20 +529,104 @@ value of this flag.")
;; (a) the file is locked by someone other than the current user, ;; (a) the file is locked by someone other than the current user,
;; or (b) some untoward manipulation behind vc's back has changed ;; or (b) some untoward manipulation behind vc's back has changed
;; the owner or the `group' or `other' write bits. ;; the owner or the `group' or `other' write bits.
(t
(let ((attributes (file-attributes file))) (let ((attributes (file-attributes file)))
(if (not (vc-mistrust-permissions file))
(cond ((string-match ".r-..-..-." (nth 8 attributes)) (cond ((string-match ".r-..-..-." (nth 8 attributes))
(vc-file-setprop file 'vc-locking-user 'none)) (vc-file-setprop file 'vc-locking-user 'none))
((and (= (nth 2 attributes) (user-uid)) ((and (= (nth 2 attributes) (user-uid))
(string-match ".rw..-..-." (nth 8 attributes))) (string-match ".rw..-..-." (nth 8 attributes)))
(vc-file-setprop file 'vc-locking-user (user-login-name))) (vc-file-setprop file 'vc-locking-user (user-login-name)))
(t (nil)))))
(defun vc-file-owner (file)
;; The expression below should return the username of the owner
;; of the file. It doesn't. It returns the username if it is
;; you, or otherwise the UID of the owner of the file. The
;; return value from this function is only used by
;; vc-dired-reformat-line, and it does the proper thing if a UID
;; is returned.
;; The *proper* way to fix this would be to implement a built-in
;; function in Emacs, say, (username UID), that returns the
;; username of a given UID.
;; The result of this hack is that vc-directory will print the
;; name of the owner of the file for any files that are
;; modified.
(let ((uid (nth 2 (file-attributes file))))
(if (= uid (user-uid)) (user-login-name) uid)))
(defun vc-rcs-lock-from-diff (file)
;; Diff the file against the master version. If differences are found,
;; mark the file locked. This is only meaningful for RCS with non-strict
;; locking.
(if (zerop (vc-simple-command 1 "rcsdiff" file
"--brief" ; Some diffs don't understand "--brief", but
; for non-strict locking under VC we require it.
(concat "-r" (vc-workfile-version file))))
(vc-file-setprop file 'vc-locking-user 'none)
(vc-file-setprop file 'vc-locking-user (vc-file-owner file))))
(defun vc-locking-user (file)
;; Return the name of the person currently holding a lock on FILE.
;; Return nil if there is no such person. (Sometimes, not the name
;; of the locking user but his uid will be returned.)
;; Under CVS, a file is considered locked if it has been modified since
;; it was checked out.
;; The property is cached. It is only looked up if it is currently nil.
;; Note that, for a file that is not locked, the actual property value
;; is `none', to distinguish it from an unknown locking state. That value
;; is converted to nil by this function, and returned to the caller.
(let ((locking-user (vc-file-getprop file 'vc-locking-user)))
(if locking-user
;; if we already know the property, return it
(if (eq locking-user 'none) nil locking-user)
;; otherwise, infer the property...
(cond
((eq (vc-backend file) 'CVS)
(or (and (eq (vc-checkout-model file) 'manual)
(vc-lock-from-permissions file))
(if (or (eq (vc-cvs-status file) 'up-to-date)
(eq (vc-cvs-status file) 'needs-checkout))
(vc-file-setprop file 'vc-locking-user 'none)
(vc-file-setprop file 'vc-locking-user (vc-file-owner file)))))
((eq (vc-backend file) 'RCS)
(let (p-lock)
;; Check for RCS headers first
(or (eq (vc-consult-rcs-headers file) 'rev-and-lock)
;; If there are no headers, try to learn it
;; from the permissions.
(and (setq p-lock (vc-lock-from-permissions file))
(if (eq p-lock 'none)
;; If the permissions say "not locked", we know
;; that the checkout model must be `manual'.
(vc-file-setprop file 'vc-checkout-model 'manual)
;; If the permissions say "locked", we can only trust
;; this *if* the checkout model is `manual'.
(eq (vc-checkout-model file) 'manual)))
;; Otherwise, use lock information from the master file.
(vc-file-setprop file 'vc-locking-user (vc-file-setprop file 'vc-locking-user
(vc-master-locking-user file)))) (vc-master-locking-user file)))
)))
;; recursively call the function again, ;; Finally, if the file is not explicitly locked
;; to convert a possible 'none value ;; it might still be locked implicitly.
(vc-locking-user file)))) (and (eq (vc-file-getprop file 'vc-locking-user) 'none)
(eq (vc-checkout-model file) 'implicit)
(vc-rcs-lock-from-diff file))))
((eq (vc-backend file) 'SCCS)
(or (vc-lock-from-permissions file)
(vc-file-setprop file 'vc-locking-user
(vc-master-locking-user file))))))
;; convert a possible 'none value
(setq locking-user (vc-file-getprop file 'vc-locking-user))
(if (eq locking-user 'none) nil locking-user)))
;;; properties to store current and recent version numbers ;;; properties to store current and recent version numbers
...@@ -704,12 +739,11 @@ value of this flag.") ...@@ -704,12 +739,11 @@ value of this flag.")
(file-directory-p (concat dirname "CVS/")) (file-directory-p (concat dirname "CVS/"))
(file-readable-p (concat dirname "CVS/Entries")) (file-readable-p (concat dirname "CVS/Entries"))
(file-readable-p (concat dirname "CVS/Repository"))) (file-readable-p (concat dirname "CVS/Repository")))
(let ((bufs nil) (fold case-fold-search)) (let (buffer (fold case-fold-search))
(unwind-protect (unwind-protect
(save-excursion (save-excursion
(setq bufs (list (setq buffer (set-buffer (get-buffer-create "*vc-info*")))
(find-file-noselect (concat dirname "CVS/Entries")))) (vc-insert-file (concat dirname "CVS/Entries"))
(set-buffer (car bufs))
(goto-char (point-min)) (goto-char (point-min))
;; make sure the file name is searched ;; make sure the file name is searched
;; case-sensitively ;; case-sensitively
...@@ -725,10 +759,7 @@ value of this flag.") ...@@ -725,10 +759,7 @@ value of this flag.")
'vc-workfile-version 'vc-workfile-version
(buffer-substring (match-beginning 1) (buffer-substring (match-beginning 1)
(match-end 1))) (match-end 1)))
(setq bufs (cons (find-file-noselect (vc-insert-file (concat dirname "CVS/Repository"))
(concat dirname "CVS/Repository"))
bufs))
(set-buffer (car bufs))
(let ((master (let ((master
(concat (file-name-as-directory (concat (file-name-as-directory
(buffer-substring (point-min) (buffer-substring (point-min)
...@@ -738,7 +769,7 @@ value of this flag.") ...@@ -738,7 +769,7 @@ value of this flag.")
(throw 'found (cons master 'CVS)))) (throw 'found (cons master 'CVS))))
(t (setq case-fold-search fold) ;; restore the old value (t (setq case-fold-search fold) ;; restore the old value
nil))) nil)))
(mapcar (function kill-buffer) bufs))))) (kill-buffer buffer)))))
(defun vc-buffer-backend () (defun vc-buffer-backend ()
"Return the version-control type of the visited file, or nil if none." "Return the version-control type of the visited file, or nil if none."
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment