(make-variable-buffer-local 'vc-mode)
(put 'vc-mode 'permanent-local t)
-
-;; branch identification
-
-(defun vc-occurrences (object sequence)
- ;; return the number of occurences of OBJECT in SEQUENCE
- ;; (is it really true that Emacs Lisp doesn't provide such a function?)
- (let ((len (length sequence)) (index 0) (occ 0))
- (while (< index len)
- (if (eq object (elt sequence index))
- (setq occ (1+ occ)))
- (setq index (1+ index)))
- occ))
-
-(defun vc-branch-p (rev)
- ;; return t if REV is the branch part of a revision,
- ;; i.e. a revision without a minor number
- (eq 0 (% (vc-occurrences ?. rev) 2)))
-
;; We need a notion of per-file properties because the version
;; control state of a file is expensive to derive --- we compute
;; them when the file is initially found, keep them up to date
;; clear all properties of a given file
(setplist (intern file vc-file-prop-obarray) nil))
-;; basic properties
-
-(defun vc-name (file)
- "Return the master name of a file, nil if it is not registered."
- (or (vc-file-getprop file 'vc-name)
- (let ((name-and-type (vc-registered file)))
- (if name-and-type
- (progn
- (vc-file-setprop file 'vc-backend (cdr name-and-type))
- (vc-file-setprop file 'vc-name (car name-and-type)))))))
-
-(defun vc-backend (file)
- "Return the version-control type of a file, nil if it is not registered."
- (and file
- (or (vc-file-getprop file 'vc-backend)
- (let ((name-and-type (vc-registered file)))
- (if name-and-type
- (progn
- (vc-file-setprop file 'vc-name (car name-and-type))
- (vc-file-setprop file 'vc-backend (cdr name-and-type))))))))
-
-;; Functions for querying the master and lock files.
+;;; Functions that determine property values, by examining the
+;;; working file, the master file, or log program output
(defun vc-match-substring (bn)
(buffer-substring (match-beginning bn) (match-end bn)))
patterns)
)
-(defun vc-master-info (file fields &optional rfile properties)
- ;; Search for information in a master file.
- (if (and file (file-exists-p file))
- (save-excursion
- (let ((buf))
- (setq buf (create-file-buffer file))
- (set-buffer buf))
- (erase-buffer)
- (insert-file-contents file)
- (set-buffer-modified-p nil)
- (auto-save-mode nil)
- (prog1
- (vc-parse-buffer fields rfile properties)
- (kill-buffer (current-buffer)))
- )
- (if rfile
- (mapcar
- (function (lambda (p) (vc-file-setprop rfile p nil)))
- properties))
- )
- )
-
-(defun vc-log-info (command file flags patterns &optional properties)
- ;; Search for information in log program output.
- ;; If there is a string `\X' in any of the PATTERNS, replace
- ;; it with a regexp to search for a branch revision.
- (if (and file (file-exists-p file))
- (save-excursion
- ;; Run the command (not using vc-do-command, as that is
- ;; only available within vc.el)
- ;; Don't switch to the *vc* buffer before running the command
- ;; because that would change its default-directory.
- (save-excursion (set-buffer (get-buffer-create "*vc*"))
- (erase-buffer))
- (let ((exec-path (append vc-path exec-path))
- ;; 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)))
- (apply 'call-process command nil "*vc*" nil
- (append flags (list (file-name-nondirectory file)))))
- (set-buffer (get-buffer "*vc*"))
- (set-buffer-modified-p nil)
- ;; in the RCS case, insert branch version into
- ;; any patterns that contain \X
- (if (eq (vc-backend file) 'RCS)
- (let ((branch
- (car (vc-parse-buffer
- '(("^branch:[ \t]+\\([0-9.]+\\)$" 1))))))
- (setq patterns
- (mapcar
- (function
- (lambda (p)
- (if (string-match "\\\\X" (car p))
- (if branch
- (cond ((vc-branch-p branch)
- (cons
- (concat
- (substring (car p) 0 (match-beginning 0))
- (regexp-quote branch)
- "\\.[0-9]+"
- (substring (car p) (match-end 0)))
- (cdr p)))
- (t
- (cons
- (concat
- (substring (car p) 0 (match-beginning 0))
- (regexp-quote branch)
- (substring (car p) (match-end 0)))
- (cdr p))))
- ;; if there is no current branch,
- ;; return a completely different regexp,
- ;; which searches for the *head*
- '("^head:[ \t]+\\([0-9.]+\\)$" 1))
- p)))
- patterns))))
- (prog1
- (vc-parse-buffer patterns file properties)
- (kill-buffer (current-buffer))
- )
- )
- (if file
- (mapcar
- (function (lambda (p) (vc-file-setprop file p nil)))
- properties))
- )
- )
+(defun vc-insert-file (file &optional limit blocksize)
+ ;; Insert the contents of FILE into the current buffer.
+ ;; Optional argument LIMIT is a regexp. If present,
+ ;; the file is inserted in chunks of size BLOCKSIZE
+ ;; (default 8 kByte), until the first occurence of
+ ;; LIMIT is found. The function returns nil if FILE
+ ;; doesn't exist.
+ (cond ((file-exists-p file)
+ (cond (limit
+ (if (not blocksize) (setq blocksize 8192))
+ (let (found s)
+ (while (not found)
+ (setq s (buffer-size))
+ (goto-char (1+ s))
+ (setq found
+ (or (zerop (car (cdr
+ (insert-file-contents file nil s
+ (+ s blocksize)))))
+ (progn (beginning-of-line)
+ (re-search-forward limit nil t)))))))
+ (t (insert-file-contents file)))
+ (set-buffer-modified-p nil)
+ (auto-save-mode nil)
+ t)
+ (t nil)))
+
+(defun vc-parse-locks (file locks)
+ ;; Parse RCS or SCCS locks.
+ ;; The result is a list of the form ((VERSION USER) (VERSION USER) ...),
+ ;; which is returned and stored into the property `vc-master-locks'.
+ (if (not locks)
+ (vc-file-setprop file 'vc-master-locks 'none)
+ (let ((found t) (index 0) master-locks version user)
+ (cond ((eq (vc-backend file) 'SCCS)
+ (while (string-match "^\\([0-9.]+\\) [0-9.]+ \\([^ ]+\\) .*\n?"
+ locks index)
+ (setq version (substring locks
+ (match-beginning 1) (match-end 1)))
+ (setq user (substring locks
+ (match-beginning 2) (match-end 2)))
+ (setq master-locks (append master-locks
+ (list (cons version user))))
+ (setq index (match-end 0))))
+ ((eq (vc-backend file) 'RCS)
+ (while (string-match "[ \t\n]*\\([^:]+\\):\\([0-9.]+\\)"
+ locks index)
+ (setq version (substring locks
+ (match-beginning 2) (match-end 2)))
+ (setq user (substring locks
+ (match-beginning 1) (match-end 1)))
+ (setq master-locks (append master-locks
+ (list (cons version user))))
+ (setq index (match-end 0)))))
+ (vc-file-setprop file 'vc-master-locks (or master-locks 'none)))))
+
+(defun vc-fetch-master-properties (file)
+ ;; Fetch those properties of FILE that are stored in the master file.
+ (save-excursion
+ (cond
+ ((eq (vc-backend file) 'SCCS)
+ (set-buffer (get-buffer-create "*vc-info*"))
+ (if (vc-insert-file (vc-lock-file file))
+ (progn (vc-parse-locks file (buffer-string))
+ (erase-buffer))
+ (vc-file-setprop file 'vc-master-locks 'none))
+ (vc-insert-file (vc-name file) "^\001e")
+ (vc-parse-buffer
+ (list '("^\001d D \\([^ ]+\\)" 1)
+ (list (concat "^\001d D \\([^ ]+\\) .* "
+ (regexp-quote (user-login-name)) " ") 1))
+ file
+ '(vc-latest-version vc-your-latest-version)))
+
+ ((eq (vc-backend file) 'RCS)
+ (set-buffer (get-buffer-create "*vc-info*"))
+ (vc-insert-file (vc-name file) "^desc")
+ (vc-parse-buffer
+ (list '("^head[ \t\n]+\\([^;]+\\);" 1)
+ '("^branch[ \t\n]+\\([^;]+\\);" 1)
+ '("^locks\\([^;]+\\);" 1)
+ '("^\\([0-9]+\\.[0-9.]+\\)\ndate[ \t]+\\([0-9.]+\\);" 1 2)
+ (list (concat "^\\([0-9]+\\.[0-9.]+\\)\n"
+ "date[ \t]+\\([0-9.]+\\);[ \t]+"
+ "author[ \t]+"
+ (regexp-quote (user-login-name)) ";") 1 2))
+ file
+ '(vc-head-version
+ vc-default-branch
+ vc-master-locks
+ vc-latest-version
+ vc-your-latest-version))
+ ;; determine vc-top-version: it is either the head version,
+ ;; or the tip of the default branch
+ (let ((default-branch (vc-file-getprop file 'vc-default-branch)))
+ (cond
+ ;; no default branch
+ ((or (not default-branch) (string= "" default-branch))
+ (vc-file-setprop file 'vc-top-version
+ (vc-file-getprop file 'vc-head-version)))
+ ;; default branch is actually a revision
+ ((string-match "^[0-9]+\\.[0-9]+\\(\\.[0-9]+\\.[0-9]+\\)*$"
+ default-branch)
+ (vc-file-setprop file 'vc-top-version default-branch))
+ ;; else, search for the tip of the default branch
+ (t (vc-parse-buffer (list (list
+ (concat "^\\("
+ (regexp-quote default-branch)
+ "\\.[0-9]+\\)\ndate[ \t]+\\([0-9.]+\\);") 1 2))
+ file '(vc-top-version)))))
+ ;; translate the locks
+ (vc-parse-locks file (vc-file-getprop file 'vc-master-locks)))
+
+ ((eq (vc-backend file) 'CVS)
+ ;; 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))
+ ;; Add vc-path to PATH for the execution of this command.
+ (process-environment
+ (cons (concat "PATH=" (getenv "PATH")
+ ":" (mapconcat 'identity vc-path ":"))
+ process-environment)))
+ (apply 'call-process "cvs" nil "*vc-info*" nil
+ (list "status" (file-name-nondirectory file))))
+ (set-buffer (get-buffer "*vc-info*"))
+ (set-buffer-modified-p nil)
+ (auto-save-mode nil)
+ (vc-parse-buffer
+ ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
+ ;; and CVS 1.4a1 says "Repository revision:".
+ '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
+ ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
+ file
+ '(vc-latest-version vc-cvs-status))
+ ;; Translate those status values that are needed into symbols.
+ ;; Any other value is converted to nil.
+ (let ((status (vc-file-getprop file 'vc-cvs-status)))
+ (cond ((string-match "Up-to-date" status)
+ (vc-file-setprop file 'vc-cvs-status 'up-to-date)
+ (vc-file-setprop file 'vc-checkout-time
+ (nth 5 (file-attributes file))))
+ ((string-match "Locally Modified" status)
+ (vc-file-setprop file 'vc-cvs-status 'locally-modified))
+ ((string-match "Needs Merge" status)
+ (vc-file-setprop file 'vc-cvs-status 'needs-merge))
+ (t (vc-file-setprop file 'vc-cvs-status nil))))))
+ (kill-buffer (current-buffer))))
;;; Functions that determine property values, by examining the
;;; working file, the master file, or log program output
;; 'rev-and-lock if revision and lock info was found
(cond
((or (not vc-consult-headers)
- (not (get-file-buffer file)) nil))
+ (not (get-file-buffer file))) nil)
((save-excursion
(set-buffer (get-file-buffer file))
(goto-char (point-min))
;; unlocked revision
((looking-at "\\$")
(vc-file-setprop file 'vc-workfile-version rev)
- (vc-file-setprop file 'vc-locking-user nil)
- (vc-file-setprop file 'vc-locked-version nil)
+ (vc-file-setprop file 'vc-locking-user 'none)
'rev-and-lock)
;; revision is locked by some user
((looking-at "\\([^ ]+\\) \\$")
(vc-file-setprop file 'vc-locking-user
(buffer-substring (match-beginning 1)
(match-end 1)))
- (vc-file-setprop file 'vc-locked-version rev)
'rev-and-lock)
;; everything else: false
(nil))
(vc-file-setprop file 'vc-locking-user
(buffer-substring (match-beginning 1)
(match-end 1)))
- (vc-file-setprop file 'vc-locked-version rev)
'rev-and-lock)
((looking-at " *\\$")
(vc-file-setprop file 'vc-workfile-version rev)
- (vc-file-setprop file 'vc-locking-user nil)
- (vc-file-setprop file 'vc-locked-version nil)
+ (vc-file-setprop file 'vc-locking-user 'none)
'rev-and-lock)
(t
(vc-file-setprop file 'vc-workfile-version rev)
+ (vc-file-setprop file 'vc-locking-user 'none)
'rev-and-lock))
(vc-file-setprop file 'vc-workfile-version rev)
'rev)))
;; -------------------
(t nil))))))
-(defun vc-fetch-properties (file)
- ;; Re-fetch some properties associated with the given file.
- (cond
- ((eq (vc-backend file) 'SCCS)
- (progn
- (vc-master-info (vc-lock-file file)
- (list
- '("^[^ ]+ [^ ]+ \\([^ ]+\\)" 1)
- '("^\\([^ ]+\\)" 1))
- file
- '(vc-locking-user vc-locked-version))
- (vc-master-info (vc-name file)
- (list
- '("^\001d D \\([^ ]+\\)" 1)
- (list (concat "^\001d D \\([^ ]+\\) .* "
- (regexp-quote (user-login-name)) " ")
- 1)
- )
- file
- '(vc-latest-version vc-your-latest-version))
- ))
- ((eq (vc-backend file) 'RCS)
- (vc-log-info "rlog" file nil
- (list
- '("^locks: strict\n\t\\([^:]+\\)" 1)
- '("^locks: strict\n\t[^:]+: \\(.+\\)" 1)
- '("^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3)
- (list
- (concat
- "^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\); *author: "
- (regexp-quote (user-login-name))
- ";") 1 3)
- ;; special regexp to search for branch revision:
- ;; \X will be replaced by vc-log-info (see there)
- '("^revision[\t ]+\\(\\X\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3))
-
- '(vc-locking-user
- vc-locked-version
- vc-latest-version
- vc-your-latest-version
- vc-branch-version)))
- ((eq (vc-backend file) 'CVS)
- (vc-log-info "cvs" file '("status")
- ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
- ;; and CVS 1.4a1 says "Repository revision:".
- '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
- ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
- '(vc-latest-version vc-cvs-status))
- ;; Translate those status values that are needed into symbols.
- ;; Any other value is converted to nil.
- (let ((status (vc-file-getprop file 'vc-cvs-status)))
- (cond ((string-match "Up-to-date" status)
- (vc-file-setprop file 'vc-cvs-status 'up-to-date)
- (vc-file-setprop file 'vc-checkout-time
- (nth 5 (file-attributes file))))
- ((string-match "Locally Modified" status)
- (vc-file-setprop file 'vc-cvs-status 'locally-modified))
- ((string-match "Needs Merge" status)
- (vc-file-setprop file 'vc-cvs-status 'needs-merge))
- (t (vc-file-setprop file 'vc-cvs-status nil))))
- )))
+;;; Access functions to file properties
+;;; (Properties should be _set_ using vc-file-setprop, but
+;;; _retrieved_ only through these functions, which decide
+;;; if the property is already known or not. A property should
+;;; only be retrieved by vc-file-getprop if there is no
+;;; access function.)
+
+;;; properties indicating the backend
+;;; being used for FILE
(defun vc-backend-subdirectory-name (&optional file)
;; Where the master and lock files for the current directory are kept
vc-default-back-end
(setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))
+(defun vc-name (file)
+ "Return the master name of a file, nil if it is not registered."
+ (or (vc-file-getprop file 'vc-name)
+ (let ((name-and-type (vc-registered file)))
+ (if name-and-type
+ (progn
+ (vc-file-setprop file 'vc-backend (cdr name-and-type))
+ (vc-file-setprop file 'vc-name (car name-and-type)))))))
-;;; Access functions to file properties
-;;; (Properties should be _set_ using vc-file-setprop, but
-;;; _retrieved_ only through these functions, which decide
-;;; if the property is already known or not. A property should
-;;; only be retrieved by vc-file-getprop if there is no
-;;; access function.)
+(defun vc-backend (file)
+ "Return the version-control type of a file, nil if it is not registered."
+ (and file
+ (or (vc-file-getprop file 'vc-backend)
+ (let ((name-and-type (vc-registered file)))
+ (if name-and-type
+ (progn
+ (vc-file-setprop file 'vc-name (car name-and-type))
+ (vc-file-setprop file 'vc-backend (cdr name-and-type))))))))
-;; functions vc-name and vc-backend come earlier above,
-;; because they are needed by vc-log-info etc.
+;;; properties indicating the locking state
(defun vc-cvs-status (file)
;; Return the cvs status of FILE
;; (Status field in output of "cvs status")
(cond ((vc-file-getprop file 'vc-cvs-status))
- (t (vc-fetch-properties file)
+ (t (vc-fetch-master-properties file)
(vc-file-getprop file 'vc-cvs-status))))
+(defun vc-master-locks (file)
+ ;; Return the lock entries in the master of FILE.
+ ;; Return 'none if there are no such entries, and a list
+ ;; of the form ((VERSION USER) (VERSION USER) ...) otherwise.
+ (cond ((vc-file-getprop file 'vc-master-locks))
+ (t (vc-fetch-master-properties file)
+ (vc-file-getprop file 'vc-master-locks))))
+
+(defun vc-master-locking-user (file)
+ ;; Return the master file's idea of who is locking
+ ;; the current workfile version of FILE.
+ ;; Return 'none if it is not locked.
+ (let ((master-locks (vc-master-locks file)) lock)
+ (if (eq master-locks 'none) 'none
+ ;; search for a lock on the current workfile version
+ (setq lock (assoc (vc-workfile-version file) master-locks))
+ (cond (lock (cdr lock))
+ ('none)))))
+
(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.
-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. If it is non-nil, it is simply returned.
- ;; The other routines clear it when the locking state changes.
- (setq file (expand-file-name file));; ??? Work around bug in 19.0.4
- (cond
- ((vc-file-getprop file 'vc-locking-user))
- ((eq (vc-backend file) 'CVS)
- (if (eq (vc-cvs-status file) 'up-to-date)
- nil
- ;; 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)))))
- (t
- (if (and (eq (vc-backend file) 'RCS)
- (eq (vc-consult-rcs-headers file) 'rev-and-lock))
- (vc-file-getprop file 'vc-locking-user)
- (if (or (not vc-keep-workfiles)
- (eq vc-mistrust-permissions 't)
- (and vc-mistrust-permissions
- (funcall vc-mistrust-permissions
- (vc-backend-subdirectory-name file))))
- (vc-file-setprop file 'vc-locking-user (vc-true-locking-user file))
- ;; This implementation assumes that any file which is under version
- ;; 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--.
- ;; We have to be careful not to exclude files with execute bits on;
- ;; scripts can be under version control too. Also, we must ignore
- ;; the group-read and other-read bits, since paranoid users turn them off.
- ;; This hack wins because calls to the very expensive vc-fetch-properties
- ;; function only have to be made if (a) the file is locked by someone
- ;; other than the current user, or (b) some untoward manipulation
- ;; behind vc's back has changed the owner or the `group' or `other'
- ;; write bits.
- (let ((attributes (file-attributes file)))
- (cond ((string-match ".r-..-..-." (nth 8 attributes))
- nil)
- ((and (= (nth 2 attributes) (user-uid))
- (string-match ".rw..-..-." (nth 8 attributes)))
- (vc-file-setprop file 'vc-locking-user (user-login-name)))
- (t
- (vc-file-setprop file 'vc-locking-user
- (vc-true-locking-user file))))))))))
-
-(defun vc-true-locking-user (file)
- ;; The slow but reliable version
- (vc-fetch-properties file)
- (vc-file-getprop file 'vc-locking-user))
+ ;; Return the name of the person currently holding a lock on FILE.
+ ;; Return nil if there is no such person.
+ ;; 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 (eq (vc-cvs-status file) 'up-to-date)
+ (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,
+ ;; use the information from the master file
+ ((or (not vc-keep-workfiles)
+ (eq vc-mistrust-permissions 't)
+ (and vc-mistrust-permissions
+ (funcall vc-mistrust-permissions
+ (vc-backend-subdirectory-name file))))
+ (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
+ ;; 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--.
+ ;; We have to be careful not to exclude files with execute bits on;
+ ;; scripts can be under version control too. Also, we must ignore the
+ ;; group-read and other-read bits, since paranoid users turn them off.
+ ;; This hack wins because calls to the somewhat expensive
+ ;; `vc-fetch-master-properties' function only have to be made if
+ ;; (a) the file is locked by someone other than the current user,
+ ;; or (b) some untoward manipulation behind vc's back has changed
+ ;; the owner or the `group' or `other' write bits.
+ (t
+ (let ((attributes (file-attributes file)))
+ (cond ((string-match ".r-..-..-." (nth 8 attributes))
+ (vc-file-setprop file 'vc-locking-user 'none))
+ ((and (= (nth 2 attributes) (user-uid))
+ (string-match ".rw..-..-." (nth 8 attributes)))
+ (vc-file-setprop file 'vc-locking-user (user-login-name)))
+ (t
+ (vc-file-setprop file 'vc-locking-user
+ (vc-master-locking-user file))))
+ )))
+ ;; recursively call the function again,
+ ;; to convert a possible 'none value
+ (vc-locking-user file))))
+
+;;; properties to store current and recent version numbers
(defun vc-latest-version (file)
;; Return version level of the latest version of FILE
- (vc-fetch-properties file)
- (vc-file-getprop file 'vc-latest-version))
+ (cond ((vc-file-getprop file 'vc-latest-version))
+ (t (vc-fetch-master-properties file)
+ (vc-file-getprop file 'vc-latest-version))))
(defun vc-your-latest-version (file)
;; Return version level of the latest version of FILE checked in by you
- (vc-fetch-properties file)
- (vc-file-getprop file 'vc-your-latest-version))
+ (cond ((vc-file-getprop file 'vc-your-latest-version))
+ (t (vc-fetch-master-properties file)
+ (vc-file-getprop file 'vc-your-latest-version))))
-(defun vc-branch-version (file)
+(defun vc-top-version (file)
;; Return version level of the highest revision on the default branch
;; If there is no default branch, return the highest version number
;; on the trunk.
;; This property is defined for RCS only.
- (vc-fetch-properties file)
- (vc-file-getprop file 'vc-branch-version))
+ (cond ((vc-file-getprop file 'vc-top-version))
+ (t (vc-fetch-master-properties file)
+ (vc-file-getprop file 'vc-top-version))))
(defun vc-workfile-version (file)
;; Return version level of the current workfile FILE
;; This is attempted by first looking at the RCS keywords.
;; If there are no keywords in the working file,
- ;; vc-branch-version is taken.
+ ;; vc-top-version is taken.
;; Note that this property is cached, that is, it is only
;; looked up if it is nil.
;; For SCCS, this property is equivalent to vc-latest-version.
((eq (vc-backend file) 'RCS)
(if (vc-consult-rcs-headers file)
(vc-file-getprop file 'vc-workfile-version)
- (let ((rev (cond ((vc-branch-version file))
+ (let ((rev (cond ((vc-top-version file))
((vc-latest-version file)))))
(vc-file-setprop file 'vc-workfile-version rev)
rev)))
(if (vc-backend buffer-file-name)
(save-excursion
(require 'vc)
+ (setq default-directory (file-name-directory (buffer-file-name)))
(not (vc-error-occurred (vc-checkout buffer-file-name))))))
(add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook)
HCoop / bpt / emacs.git / blobdiff