X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/ce27f2642eec3e03f4cac171634c2dd494c2636a..d5ec6a2da4b2138be6bf183b797eed40291dc89e:/lisp/vc-hooks.el diff --git a/lisp/vc-hooks.el b/lisp/vc-hooks.el dissimilarity index 86% index 1ae9ecfe64..c8b9d2000c 100644 --- a/lisp/vc-hooks.el +++ b/lisp/vc-hooks.el @@ -1,884 +1,781 @@ -;;; vc-hooks.el --- resident support for version-control - -;; Copyright (C) 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - -;; Author: Eric S. Raymond -;; Modified by: -;; Per Cederqvist -;; Andre Spiegel - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 2, or (at your option) -;; any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. - -;;; Commentary: - -;; This is the always-loaded portion of VC. -;; It takes care VC-related activities that are done when you visit a file, -;; so that vc.el itself is loaded only when you use a VC command. -;; See the commentary of vc.el. - -;;; Code: - -;; Customization Variables (the rest is in vc.el) - -(defvar vc-default-back-end nil - "*Back-end actually used by this interface; may be SCCS or RCS. -The value is only computed when needed to avoid an expensive search.") - -(defvar vc-handle-cvs t - "*If non-nil, use VC for files managed with CVS. -If it is nil, don't use VC for those files.") - -(defvar vc-path - (if (file-directory-p "/usr/sccs") - '("/usr/sccs") - nil) - "*List of extra directories to search for version control commands.") - -(defvar vc-master-templates - '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS) - ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS) - vc-find-cvs-master) - "*Where to look for version-control master files. -The first pair corresponding to a given back end is used as a template -when creating new masters.") - -(defvar vc-make-backup-files nil - "*If non-nil, backups of registered files are made as with other files. -If nil (the default), files covered by version control don't get backups.") - -(defvar vc-display-status t - "*If non-nil, display revision number and lock status in modeline. -Otherwise, not displayed.") - -(defvar vc-consult-headers t - "*Identify work files by searching for version headers.") - -(defvar vc-mistrust-permissions nil - "*Don't assume that permissions and ownership track version-control status.") - -(defvar vc-keep-workfiles t - "*If non-nil, don't delete working files after registering changes. -If the back-end is CVS, workfiles are always kept, regardless of the -value of this flag.") - -;; Tell Emacs about this new kind of minor mode -(if (not (assoc 'vc-mode minor-mode-alist)) - (setq minor-mode-alist (cons '(vc-mode vc-mode) - minor-mode-alist))) - -(make-variable-buffer-local 'vc-mode) -(put 'vc-mode 'permanent-local t) - -;; 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 -;; during any subsequent VC operations, and forget them when -;; the buffer is killed. - -(defmacro vc-error-occurred (&rest body) - (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t))) - -(defvar vc-file-prop-obarray [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0] - "Obarray for per-file properties.") - -(defvar vc-buffer-backend t) -(make-variable-buffer-local 'vc-buffer-backend) - -(defun vc-file-setprop (file property value) - ;; set per-file property - (put (intern file vc-file-prop-obarray) property value)) - -(defun vc-file-getprop (file property) - ;; get per-file property - (get (intern file vc-file-prop-obarray) property)) - -(defun vc-file-clearprops (file) - ;; clear all properties of a given file - (setplist (intern file vc-file-prop-obarray) nil)) - -;;; 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))) - -(defun vc-lock-file (file) - ;; Generate lock file name corresponding to FILE - (let ((master (vc-name file))) - (and - master - (string-match "\\(.*/\\)s\\.\\(.*\\)" master) - (concat - (substring master (match-beginning 1) (match-end 1)) - "p." - (substring master (match-beginning 2) (match-end 2)))))) - -(defun vc-parse-buffer (patterns &optional file properties) - ;; Use PATTERNS to parse information out of the current buffer. - ;; Each element of PATTERNS is a list of 2 to 3 elements. The first element - ;; is the pattern to be matched, and the second (an integer) is the - ;; number of the subexpression that should be returned. If there's - ;; a third element (also the number of a subexpression), that - ;; subexpression is assumed to be a date field and we want the most - ;; recent entry matching the template. - ;; If FILE and PROPERTIES are given, the latter must be a list of - ;; properties of the same length as PATTERNS; each property is assigned - ;; the corresponding value. - (mapcar (function (lambda (p) - (goto-char (point-min)) - (cond - ((eq (length p) 2) ;; search for first entry - (let ((value nil)) - (if (re-search-forward (car p) nil t) - (setq value (vc-match-substring (elt p 1)))) - (if file - (progn (vc-file-setprop file (car properties) value) - (setq properties (cdr properties)))) - value)) - ((eq (length p) 3) ;; search for latest entry - (let ((latest-date "") (latest-val)) - (while (re-search-forward (car p) nil t) - (let ((date (vc-match-substring (elt p 2)))) - (if (string< latest-date date) - (progn - (setq latest-date date) - (setq latest-val - (vc-match-substring (elt p 1))))))) - (if file - (progn (vc-file-setprop file (car properties) latest-val) - (setq properties (cdr properties)))) - latest-val))))) - patterns) - ) - -(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. - (erase-buffer) - (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. - ;; For an RCS file, we don't get vc-latest-version vc-your-latest-version - ;; here because that is slow. - ;; That gets done if/when the functions vc-latest-version - ;; and vc-your-latest-version get called. - (save-excursion - (cond - ((eq (vc-backend file) 'SCCS) - (set-buffer (get-buffer-create "*vc-info*")) - (if (vc-insert-file (vc-lock-file file)) - (vc-parse-locks file (buffer-string)) - (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) "^locks") - (vc-parse-buffer - (list '("^head[ \t\n]+\\([^;]+\\);" 1) - '("^branch[ \t\n]+\\([^;]+\\);" 1) - '("^locks\\([^;]+\\);" 1)) - file - '(vc-head-version - vc-default-branch - vc-master-locks)) - ;; 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-insert-file (vc-name file) "^desc") - (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") - path-separator - (mapconcat 'identity vc-path path-separator)) - process-environment))) - (apply 'call-process "cvs" nil "*vc-info*" nil - (list "status" 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)))))) - (if (get-buffer "*vc-info*") - (kill-buffer (get-buffer "*vc-info*"))))) - -;;; Functions that determine property values, by examining the -;;; working file, the master file, or log program output - -(defun vc-consult-rcs-headers (file) - ;; Search for RCS headers in FILE, and set properties - ;; accordingly. This function can be disabled by setting - ;; vc-consult-headers to nil. - ;; Returns: nil if no headers were found - ;; (or if the feature is disabled, - ;; or if there is currently no buffer - ;; visiting FILE) - ;; 'rev if a workfile revision was found - ;; 'rev-and-lock if revision and lock info was found - (cond - ((or (not vc-consult-headers) - (not (get-file-buffer file))) nil) - ((save-excursion - (set-buffer (get-file-buffer file)) - (goto-char (point-min)) - (cond - ;; search for $Id or $Header - ;; ------------------------- - ((or (and (search-forward "$Id: " nil t) - (looking-at "[^ ]+ \\([0-9.]+\\) ")) - (and (progn (goto-char (point-min)) - (search-forward "$Header: " nil t)) - (looking-at "[^ ]+ \\([0-9.]+\\) "))) - (goto-char (match-end 0)) - ;; if found, store the revision number ... - (let ((rev (buffer-substring (match-beginning 1) - (match-end 1)))) - ;; ... and check for the locking state - (cond - ((looking-at - (concat "[0-9]+[/-][01][0-9][/-][0-3][0-9] " ; date - "[0-2][0-9]:[0-5][0-9]+:[0-6][0-9]+\\([+-][0-9:]+\\)? " ; time - "[^ ]+ [^ ]+ ")) ; author & state - (goto-char (match-end 0)) ; [0-6] in regexp handles leap seconds - (cond - ;; unlocked revision - ((looking-at "\\$") - (vc-file-setprop file 'vc-workfile-version rev) - (vc-file-setprop file 'vc-locking-user 'none) - 'rev-and-lock) - ;; revision is locked by some user - ((looking-at "\\([^ ]+\\) \\$") - (vc-file-setprop file 'vc-workfile-version rev) - (vc-file-setprop file 'vc-locking-user - (buffer-substring (match-beginning 1) - (match-end 1))) - 'rev-and-lock) - ;; everything else: false - (nil))) - ;; unexpected information in - ;; keyword string --> quit - (nil)))) - ;; search for $Revision - ;; -------------------- - ((re-search-forward (concat "\\$" - "Revision: \\([0-9.]+\\) \\$") - nil t) - ;; if found, store the revision number ... - (let ((rev (buffer-substring (match-beginning 1) - (match-end 1)))) - ;; and see if there's any lock information - (goto-char (point-min)) - (if (re-search-forward (concat "\\$" "Locker:") nil t) - (cond ((looking-at " \\([^ ]+\\) \\$") - (vc-file-setprop file 'vc-workfile-version rev) - (vc-file-setprop file 'vc-locking-user - (buffer-substring (match-beginning 1) - (match-end 1))) - 'rev-and-lock) - ((looking-at " *\\$") - (vc-file-setprop file 'vc-workfile-version rev) - (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))) - ;; else: nothing found - ;; ------------------- - (t 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 - (symbol-name - (or - (and file (vc-backend file)) - 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))))))) - -(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)))))))) - -;;; 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-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. 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 - (cond ((vc-file-getprop file 'vc-latest-version)) - (t (vc-fetch-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 - (cond ((vc-file-getprop file 'vc-your-latest-version)) - (t (vc-fetch-properties file) - (vc-file-getprop file 'vc-your-latest-version)))) - -(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. - (cond ((vc-file-getprop file 'vc-top-version)) - (t (vc-fetch-master-properties file) - (vc-file-getprop file 'vc-top-version)))) - -(defun vc-fetch-properties (file) - ;; Fetch vc-latest-version and vc-your-latest-version - ;; if that wasn't already done. - (cond - ((eq (vc-backend file) 'RCS) - (save-excursion - (set-buffer (get-buffer-create "*vc-info*")) - (vc-insert-file (vc-name file) "^desc") - (vc-parse-buffer - (list '("^\\([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-latest-version vc-your-latest-version)) - (if (get-buffer "*vc-info*") - (kill-buffer (get-buffer "*vc-info*"))))) - (t (vc-fetch-master-properties file)) - )) - -(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-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. - (cond ((vc-file-getprop file 'vc-workfile-version)) - ((eq (vc-backend file) 'SCCS) (vc-latest-version file)) - ((eq (vc-backend file) 'RCS) - (if (vc-consult-rcs-headers file) - (vc-file-getprop file 'vc-workfile-version) - (let ((rev (cond ((vc-top-version file)) - ((vc-latest-version file))))) - (vc-file-setprop file 'vc-workfile-version rev) - rev))) - ((eq (vc-backend file) 'CVS) - (if (vc-consult-rcs-headers file) ;; CVS - (vc-file-getprop file 'vc-workfile-version) - (vc-find-cvs-master (file-name-directory file) - (file-name-nondirectory file)) - (vc-file-getprop file 'vc-workfile-version))))) - -;;; actual version-control code starts here - -(defun vc-registered (file) - (let (handler handlers) - (if (boundp 'file-name-handler-alist) - (setq handler (find-file-name-handler file 'vc-registered))) - (if handler - (funcall handler 'vc-registered file) - ;; Search for a master corresponding to the given file - (let ((dirname (or (file-name-directory file) "")) - (basename (file-name-nondirectory file))) - (catch 'found - (mapcar - (function (lambda (s) - (if (atom s) - (funcall s dirname basename) - (let ((trial (format (car s) dirname basename))) - (if (and (file-exists-p trial) - ;; Make sure the file we found with name - ;; TRIAL is not the source file itself. - ;; That can happen with RCS-style names - ;; if the file name is truncated - ;; (e.g. to 14 chars). See if either - ;; directory or attributes differ. - (or (not (string= dirname - (file-name-directory trial))) - (not (equal - (file-attributes file) - (file-attributes trial))))) - (throw 'found (cons trial (cdr s)))))))) - vc-master-templates) - nil))))) - -(defun vc-find-cvs-master (dirname basename) - ;; Check if DIRNAME/BASENAME is handled by CVS. - ;; If it is, do a (throw 'found (cons MASTER 'CVS)). - ;; Note: If the file is ``cvs add''ed but not yet ``cvs commit''ed - ;; the MASTER will not actually exist yet. The other parts of VC - ;; checks for this condition. This function returns nil if - ;; DIRNAME/BASENAME is not handled by CVS. - (if (and vc-handle-cvs - (file-directory-p (concat dirname "CVS/")) - (file-readable-p (concat dirname "CVS/Entries")) - (file-readable-p (concat dirname "CVS/Repository"))) - (let ((bufs nil) (fold case-fold-search)) - (unwind-protect - (save-excursion - (setq bufs (list - (find-file-noselect (concat dirname "CVS/Entries")))) - (set-buffer (car bufs)) - (goto-char (point-min)) - ;; make sure the file name is searched - ;; case-sensitively - (setq case-fold-search nil) - (cond - ((re-search-forward - (concat "^/" (regexp-quote basename) "/\\([^/]*\\)/") - nil t) - (setq case-fold-search fold) ;; restore the old value - ;; We found it. Store away version number, now - ;; that we are anyhow so close to finding it. - (vc-file-setprop (concat dirname basename) - 'vc-workfile-version - (buffer-substring (match-beginning 1) - (match-end 1))) - (setq bufs (cons (find-file-noselect - (concat dirname "CVS/Repository")) - bufs)) - (set-buffer (car bufs)) - (let ((master - (concat (file-name-as-directory - (buffer-substring (point-min) - (1- (point-max)))) - basename - ",v"))) - (throw 'found (cons master 'CVS)))) - (t (setq case-fold-search fold) ;; restore the old value - nil))) - (mapcar (function kill-buffer) bufs))))) - -(defun vc-buffer-backend () - "Return the version-control type of the visited file, or nil if none." - (if (eq vc-buffer-backend t) - (setq vc-buffer-backend (vc-backend (buffer-file-name))) - vc-buffer-backend)) - -(defun vc-toggle-read-only (&optional verbose) - "Change read-only status of current buffer, perhaps via version control. -If the buffer is visiting a file registered with version control, -then check the file in or out. Otherwise, just change the read-only flag -of the buffer. With prefix argument, ask for version number." - (interactive "P") - (if (vc-backend (buffer-file-name)) - (vc-next-action verbose) - (toggle-read-only))) -(define-key global-map "\C-x\C-q" 'vc-toggle-read-only) - -(defun vc-mode-line (file &optional label) - "Set `vc-mode' to display type of version control for FILE. -The value is set in the current buffer, which should be the buffer -visiting FILE. Second optional arg LABEL is put in place of version -control system name." - (interactive (list buffer-file-name nil)) - (let ((vc-type (vc-backend file)) - (vc-status-string (and vc-display-status (vc-status file)))) - (setq vc-mode - (concat " " (or label (symbol-name vc-type)) vc-status-string)) - ;; Make the buffer read-only if the file is not locked - ;; (or unchanged, in the CVS case). - ;; Determine this by looking at the mode string, - ;; so that no further external status query is necessary - (if vc-status-string - (if (eq (elt vc-status-string 0) ?-) - (setq buffer-read-only t)) - (if (not (vc-locking-user file)) - (setq buffer-read-only t))) - ;; Even root shouldn't modify a registered file without - ;; locking it first. - (and vc-type - (not buffer-read-only) - (zerop (user-uid)) - (require 'vc) - (not (equal (user-login-name) (vc-locking-user file))) - (setq buffer-read-only t)) - (and (null vc-type) - (file-symlink-p file) - (let ((link-type (vc-backend (file-symlink-p file)))) - (if link-type - (message - "Warning: symbolic link to %s-controlled source file" - link-type)))) - (force-mode-line-update) - ;;(set-buffer-modified-p (buffer-modified-p)) ;;use this if Emacs 18 - vc-type)) - -(defun vc-status (file) - ;; Return string for placement in modeline by `vc-mode-line'. - ;; Format: - ;; - ;; "-REV" if the revision is not locked - ;; ":REV" if the revision is locked by the user - ;; ":LOCKER:REV" if the revision is locked by somebody else - ;; " @@" for a CVS file that is added, but not yet committed - ;; - ;; In the CVS case, a "locked" working file is a - ;; working file that is modified with respect to the master. - ;; The file is "locked" from the moment when the user makes - ;; the buffer writable. - ;; - ;; This function assumes that the file is registered. - - (let ((locker (vc-locking-user file)) - (rev (vc-workfile-version file))) - (cond ((string= "0" rev) - " @@") - ((not locker) - (concat "-" rev)) - ((if (stringp locker) - (string= locker (user-login-name)) - (= locker (user-uid))) - (concat ":" rev)) - (t - (concat ":" locker ":" rev))))) - -;;; install a call to the above as a find-file hook -(defun vc-find-file-hook () - ;; Recompute whether file is version controlled, - ;; if user has killed the buffer and revisited. - (cond - (buffer-file-name - (vc-file-clearprops buffer-file-name) - (cond - ((vc-backend buffer-file-name) - (vc-mode-line buffer-file-name) - (cond ((not vc-make-backup-files) - ;; Use this variable, not make-backup-files, - ;; because this is for things that depend on the file name. - (make-local-variable 'backup-inhibited) - (setq backup-inhibited t)))))))) - -(add-hook 'find-file-hooks 'vc-find-file-hook) - -;;; more hooks, this time for file-not-found -(defun vc-file-not-found-hook () - "When file is not found, try to check it out from RCS or SCCS. -Returns t if checkout was successful, nil otherwise." - (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) - -;; Discard info about a file when we kill its buffer. -(defun vc-kill-buffer-hook () - (if (stringp (buffer-file-name)) - (progn - (vc-file-clearprops (buffer-file-name)) - (kill-local-variable 'vc-buffer-backend)))) - -;;;(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook) - -;;; Now arrange for bindings and autoloading of the main package. -;;; Bindings for this have to go in the global map, as we'll often -;;; want to call them from random buffers. - -(setq vc-prefix-map (lookup-key global-map "\C-xv")) -(if (not (keymapp vc-prefix-map)) - (progn - (setq vc-prefix-map (make-sparse-keymap)) - (define-key global-map "\C-xv" vc-prefix-map) - (define-key vc-prefix-map "a" 'vc-update-change-log) - (define-key vc-prefix-map "c" 'vc-cancel-version) - (define-key vc-prefix-map "d" 'vc-directory) - (define-key vc-prefix-map "h" 'vc-insert-headers) - (define-key vc-prefix-map "i" 'vc-register) - (define-key vc-prefix-map "l" 'vc-print-log) - (define-key vc-prefix-map "r" 'vc-retrieve-snapshot) - (define-key vc-prefix-map "s" 'vc-create-snapshot) - (define-key vc-prefix-map "u" 'vc-revert-buffer) - (define-key vc-prefix-map "v" 'vc-next-action) - (define-key vc-prefix-map "=" 'vc-diff) - (define-key vc-prefix-map "~" 'vc-version-other-window))) - -(if (not (boundp 'vc-menu-map)) - ;; Don't do the menu bindings if menu-bar.el wasn't loaded to defvar - ;; vc-menu-map. - () - ;;(define-key vc-menu-map [show-files] - ;; '("Show Files under VC" . (vc-directory t))) - (define-key vc-menu-map [vc-directory] '("Show Locked Files" . vc-directory)) - (define-key vc-menu-map [separator1] '("----")) - (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file)) - (define-key vc-menu-map [vc-version-other-window] - '("Show Other Version" . vc-version-other-window)) - (define-key vc-menu-map [vc-diff] '("Compare with Last Version" . vc-diff)) - (define-key vc-menu-map [vc-update-change-log] - '("Update ChangeLog" . vc-update-change-log)) - (define-key vc-menu-map [vc-print-log] '("Show History" . vc-print-log)) - (define-key vc-menu-map [separator2] '("----")) - (define-key vc-menu-map [undo] '("Undo Last Check-In" . vc-cancel-version)) - (define-key vc-menu-map [vc-revert-buffer] - '("Revert to Last Version" . vc-revert-buffer)) - (define-key vc-menu-map [vc-insert-header] - '("Insert Header" . vc-insert-headers)) - (define-key vc-menu-map [vc-menu-check-in] '("Check In" . vc-next-action)) - (define-key vc-menu-map [vc-check-out] '("Check Out" . vc-toggle-read-only)) - (define-key vc-menu-map [vc-register] '("Register" . vc-register)) - (put 'vc-rename-file 'menu-enable 'vc-mode) - (put 'vc-version-other-window 'menu-enable 'vc-mode) - (put 'vc-diff 'menu-enable 'vc-mode) - (put 'vc-update-change-log 'menu-enable - '(eq (vc-buffer-backend) 'RCS)) - (put 'vc-print-log 'menu-enable 'vc-mode) - (put 'vc-cancel-version 'menu-enable 'vc-mode) - (put 'vc-revert-buffer 'menu-enable 'vc-mode) - (put 'vc-insert-headers 'menu-enable 'vc-mode) - (put 'vc-next-action 'menu-enable '(and vc-mode (not buffer-read-only))) - (put 'vc-toggle-read-only 'menu-enable '(and vc-mode buffer-read-only)) - (put 'vc-register 'menu-enable '(and buffer-file-name (not vc-mode))) - ) - -(provide 'vc-hooks) - -;;; vc-hooks.el ends here +;;; vc-hooks.el --- resident support for version-control + +;; Copyright (C) 1992,93,94,95,96,98,99,2000 Free Software Foundation, Inc. + +;; Author: FSF (see vc.el for full credits) +;; Maintainer: Andre Spiegel + +;; $Id: vc-hooks.el,v 1.144 2002/09/04 20:45:34 spiegel Exp $ + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; This is the always-loaded portion of VC. It takes care of +;; VC-related activities that are done when you visit a file, so that +;; vc.el itself is loaded only when you use a VC command. See the +;; commentary of vc.el. + +;;; Code: + +(eval-when-compile + (require 'cl)) + +;; Customization Variables (the rest is in vc.el) + +(defvar vc-ignore-vc-files nil "Obsolete -- use `vc-handled-backends'.") +(defvar vc-master-templates () "Obsolete -- use vc-BACKEND-master-templates.") +(defvar vc-header-alist () "Obsolete -- use vc-BACKEND-header.") + +(defcustom vc-handled-backends '(RCS CVS SCCS) + "*List of version control backends for which VC will be used. +Entries in this list will be tried in order to determine whether a +file is under that sort of version control. +Removing an entry from the list prevents VC from being activated +when visiting a file managed by that backend. +An empty list disables VC altogether." + :type '(repeat symbol) + :version "21.1" + :group 'vc) + +(defcustom vc-path + (if (file-directory-p "/usr/sccs") + '("/usr/sccs") + nil) + "*List of extra directories to search for version control commands." + :type '(repeat directory) + :group 'vc) + +(defcustom vc-make-backup-files nil + "*If non-nil, backups of registered files are made as with other files. +If nil (the default), files covered by version control don't get backups." + :type 'boolean + :group 'vc) + +(defcustom vc-follow-symlinks 'ask + "*What to do if visiting a symbolic link to a file under version control. +Editing such a file through the link bypasses the version control system, +which is dangerous and probably not what you want. + +If this variable is t, VC follows the link and visits the real file, +telling you about it in the echo area. If it is `ask', VC asks for +confirmation whether it should follow the link. If nil, the link is +visited and a warning displayed." + :type '(choice (const :tag "Ask for confirmation" ask) + (const :tag "Visit link and warn" nil) + (const :tag "Follow link" t)) + :group 'vc) + +(defcustom vc-display-status t + "*If non-nil, display revision number and lock status in modeline. +Otherwise, not displayed." + :type 'boolean + :group 'vc) + + +(defcustom vc-consult-headers t + "*If non-nil, identify work files by searching for version headers." + :type 'boolean + :group 'vc) + +(defcustom vc-keep-workfiles t + "*If non-nil, don't delete working files after registering changes. +If the back-end is CVS, workfiles are always kept, regardless of the +value of this flag." + :type 'boolean + :group 'vc) + +(defcustom vc-mistrust-permissions nil + "*If non-nil, don't assume permissions/ownership track version-control status. +If nil, do rely on the permissions. +See also variable `vc-consult-headers'." + :type 'boolean + :group 'vc) + +(defun vc-mistrust-permissions (file) + "Internal access function to variable `vc-mistrust-permissions' for FILE." + (or (eq vc-mistrust-permissions 't) + (and vc-mistrust-permissions + (funcall vc-mistrust-permissions + (vc-backend-subdirectory-name file))))) + +;;; This is handled specially now. +;; Tell Emacs about this new kind of minor mode +;; (add-to-list 'minor-mode-alist '(vc-mode vc-mode)) + +(make-variable-buffer-local 'vc-mode) +(put 'vc-mode 'permanent-local t) + +(defun vc-mode (&optional arg) + ;; Dummy function for C-h m + "Version Control minor mode. +This minor mode is automatically activated whenever you visit a file under +control of one of the revision control systems in `vc-handled-backends'. +VC commands are globally reachable under the prefix `\\[vc-prefix-map]': +\\{vc-prefix-map}") + +(defmacro vc-error-occurred (&rest body) + `(condition-case nil (progn ,@body nil) (error t))) + +;; 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 +;; during any subsequent VC operations, and forget them when +;; the buffer is killed. + +(defvar vc-file-prop-obarray (make-vector 17 0) + "Obarray for per-file properties.") + +(defvar vc-touched-properties nil) + +(defun vc-file-setprop (file property value) + "Set per-file VC PROPERTY for FILE to VALUE." + (if (and vc-touched-properties + (not (memq property vc-touched-properties))) + (setq vc-touched-properties (append (list property) + vc-touched-properties))) + (put (intern file vc-file-prop-obarray) property value)) + +(defun vc-file-getprop (file property) + "Get per-file VC PROPERTY for FILE." + (get (intern file vc-file-prop-obarray) property)) + +(defun vc-file-clearprops (file) + "Clear all VC properties of FILE." + (setplist (intern file vc-file-prop-obarray) nil)) + + +;; We keep properties on each symbol naming a backend as follows: +;; * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION. + +(defun vc-make-backend-sym (backend sym) + "Return BACKEND-specific version of VC symbol SYM." + (intern (concat "vc-" (downcase (symbol-name backend)) + "-" (symbol-name sym)))) + +(defun vc-find-backend-function (backend fun) + "Return BACKEND-specific implementation of FUN. +If there is no such implementation, return the default implementation; +if that doesn't exist either, return nil." + (let ((f (vc-make-backend-sym backend fun))) + (if (fboundp f) f + ;; Load vc-BACKEND.el if needed. + (require (intern (concat "vc-" (downcase (symbol-name backend))))) + (if (fboundp f) f + (let ((def (vc-make-backend-sym 'default fun))) + (if (fboundp def) (cons def backend) nil)))))) + +(defun vc-call-backend (backend function-name &rest args) + "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS. +Calls + + (apply 'vc-BACKEND-FUN ARGS) + +if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el) +and else calls + + (apply 'vc-default-FUN BACKEND ARGS) + +It is usually called via the `vc-call' macro." + (let ((f (cdr (assoc function-name (get backend 'vc-functions))))) + (unless f + (setq f (vc-find-backend-function backend function-name)) + (put backend 'vc-functions (cons (cons function-name f) + (get backend 'vc-functions)))) + (if (consp f) + (apply (car f) (cdr f) args) + (apply f args)))) + +(defmacro vc-call (fun file &rest args) + ;; BEWARE!! `file' is evaluated twice!! + `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args)) + + +(defsubst vc-parse-buffer (pattern i) + "Find PATTERN in the current buffer and return its Ith submatch." + (goto-char (point-min)) + (if (re-search-forward pattern nil t) + (match-string i))) + +(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 +occurrence of LIMIT is found. Anything from the start of that occurence +to the end of the buffer is then deleted. The function returns +non-nil if FILE exists and its contents were successfully inserted." + (erase-buffer) + (when (file-exists-p file) + (if (not limit) + (insert-file-contents file) + (if (not blocksize) (setq blocksize 8192)) + (let ((filepos 0)) + (while + (and (< 0 (cadr (insert-file-contents + file nil filepos (incf filepos blocksize)))) + (progn (beginning-of-line) + (let ((pos (re-search-forward limit nil 'move))) + (if pos (delete-region (match-beginning 0) + (point-max))) + (not pos))))))) + (set-buffer-modified-p nil) + t)) + +;; 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-registered (file) + "Return non-nil if FILE is registered in a version control system. + +This function performs the check each time it is called. To rely +on the result of a previous call, use `vc-backend' instead. If the +file was previously registered under a certain backend, then that +backend is tried first." + (let (handler) + (if (boundp 'file-name-handler-alist) + (setq handler (find-file-name-handler file 'vc-registered))) + (if handler + ;; handler should set vc-backend and return t if registered + (funcall handler 'vc-registered file) + ;; There is no file name handler. + ;; Try vc-BACKEND-registered for each handled BACKEND. + (catch 'found + (let ((backend (vc-file-getprop file 'vc-backend))) + (mapcar + (lambda (b) + (and (vc-call-backend b 'registered file) + (vc-file-setprop file 'vc-backend b) + (throw 'found t))) + (if (or (not backend) (eq backend 'none)) + vc-handled-backends + (cons backend vc-handled-backends)))) + ;; File is not registered. + (vc-file-setprop file 'vc-backend 'none) + nil)))) + +(defun vc-backend (file) + "Return the version control type of FILE, nil if it is not registered." + ;; `file' can be nil in several places (typically due to the use of + ;; code like (vc-backend (buffer-file-name))). + (when (stringp file) + (let ((property (vc-file-getprop file 'vc-backend))) + ;; Note that internally, Emacs remembers unregistered + ;; files by setting the property to `none'. + (cond ((eq property 'none) nil) + (property) + ;; vc-registered sets the vc-backend property + (t (if (vc-registered file) + (vc-file-getprop file 'vc-backend) + nil)))))) + +(defun vc-backend-subdirectory-name (file) + "Return where the master and lock FILEs for the current directory are kept." + (symbol-name (vc-backend file))) + +(defun vc-name (file) + "Return the master name of FILE. +If the file is not registered, or the master name is not known, return nil." + ;; TODO: This should ultimately become obsolete, at least up here + ;; in vc-hooks. + (or (vc-file-getprop file 'vc-name) + ;; force computation of the property by calling + ;; vc-BACKEND-registered explicitly + (if (and (vc-backend file) + (vc-call-backend (vc-backend file) 'registered file)) + (vc-file-getprop file 'vc-name)))) + +(defun vc-checkout-model (file) + "Indicate how FILE is checked out. + +If FILE is not registered, this function always returns nil. +For registered files, the possible values are: + + 'implicit FILE is always writeable, and checked out `implicitly' + when the user saves the first changes to the file. + + 'locking FILE is read-only if up-to-date; user must type + \\[vc-next-action] before editing. Strict locking + is assumed. + + 'announce FILE is read-only if up-to-date; user must type + \\[vc-next-action] before editing. But other users + may be editing at the same time." + (or (vc-file-getprop file 'vc-checkout-model) + (if (vc-backend file) + (vc-file-setprop file 'vc-checkout-model + (vc-call checkout-model file))))) + +(defun vc-user-login-name (&optional uid) + "Return the name under which the user is logged in, as a string. +\(With optional argument UID, return the name of that user.) +This function does the same as function `user-login-name', but unlike +that, it never returns nil. If a UID cannot be resolved, that +UID is returned as a string." + (or (user-login-name uid) + (number-to-string (or uid (user-uid))))) + +(defun vc-state (file) + "Return the version control state of FILE. + +If FILE is not registered, this function always returns nil. +For registered files, the value returned is one of: + + 'up-to-date The working file is unmodified with respect to the + latest version on the current branch, and not locked. + + 'edited The working file has been edited by the user. If + locking is used for the file, this state means that + the current version is locked by the calling user. + + USER The current version of the working file is locked by + some other USER (a string). + + 'needs-patch The file has not been edited by the user, but there is + a more recent version on the current branch stored + in the master file. + + 'needs-merge The file has been edited by the user, and there is also + a more recent version on the current branch stored in + the master file. This state can only occur if locking + is not used for the file. + + 'unlocked-changes The current version of the working file is not locked, + but the working file has been changed with respect + to that version. This state can only occur for files + with locking; it represents an erroneous condition that + should be resolved by the user (vc-next-action will + prompt the user to do it)." + (or (vc-file-getprop file 'vc-state) + (if (vc-backend file) + (vc-file-setprop file 'vc-state + (vc-call state-heuristic file))))) + +(defsubst vc-up-to-date-p (file) + "Convenience function that checks whether `vc-state' of FILE is `up-to-date'." + (eq (vc-state file) 'up-to-date)) + +(defun vc-default-state-heuristic (backend file) + "Default implementation of vc-state-heuristic. +It simply calls the real state computation function `vc-BACKEND-state' +and does not employ any heuristic at all." + (vc-call-backend backend 'state file)) + +(defun vc-workfile-unchanged-p (file) + "Return non-nil if FILE has not changed since the last checkout." + (let ((checkout-time (vc-file-getprop file 'vc-checkout-time)) + (lastmod (nth 5 (file-attributes file)))) + (if checkout-time + (equal checkout-time lastmod) + (let ((unchanged (vc-call workfile-unchanged-p file))) + (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0)) + unchanged)))) + +(defun vc-default-workfile-unchanged-p (backend file) + "Check if FILE is unchanged by diffing against the master version. +Return non-nil if FILE is unchanged." + (zerop (vc-call diff file (vc-workfile-version file)))) + +(defun vc-workfile-version (file) + "Return the version level of the current workfile FILE. +If FILE is not registered, this function always returns nil." + (or (vc-file-getprop file 'vc-workfile-version) + (if (vc-backend file) + (vc-file-setprop file 'vc-workfile-version + (vc-call workfile-version file))))) + +(defun vc-default-registered (backend file) + "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates." + (let ((sym (vc-make-backend-sym backend 'master-templates))) + (unless (get backend 'vc-templates-grabbed) + (put backend 'vc-templates-grabbed t) + (set sym (append (delq nil + (mapcar + (lambda (template) + (and (consp template) + (eq (cdr template) backend) + (car template))) + vc-master-templates)) + (symbol-value sym)))) + (let ((result (vc-check-master-templates file (symbol-value sym)))) + (if (stringp result) + (vc-file-setprop file 'vc-name result) + nil)))) ; Not registered + +(defun vc-possible-master (s dirname basename) + (cond + ((stringp s) (format s dirname basename)) + ((functionp s) + ;; The template is a function to invoke. If the + ;; function returns non-nil, that means it has found a + ;; master. For backward compatibility, we also handle + ;; the case that the function throws a 'found atom + ;; and a pair (cons MASTER-FILE BACKEND). + (let ((result (catch 'found (funcall s dirname basename)))) + (if (consp result) (car result) result))))) + +(defun vc-check-master-templates (file templates) + "Return non-nil if there is a master corresponding to FILE. + +TEMPLATES is a list of strings or functions. If an element is a +string, it must be a control string as required by `format', with two +string placeholders, such as \"%sRCS/%s,v\". The directory part of +FILE is substituted for the first placeholder, the basename of FILE +for the second. If a file with the resulting name exists, it is taken +as the master of FILE, and returned. + +If an element of TEMPLATES is a function, it is called with the +directory part and the basename of FILE as arguments. It should +return non-nil if it finds a master; that value is then returned by +this function." + (let ((dirname (or (file-name-directory file) "")) + (basename (file-name-nondirectory file))) + (catch 'found + (mapcar + (lambda (s) + (let ((trial (vc-possible-master s dirname basename))) + (if (and trial (file-exists-p trial) + ;; Make sure the file we found with name + ;; TRIAL is not the source file itself. + ;; That can happen with RCS-style names if + ;; the file name is truncated (e.g. to 14 + ;; chars). See if either directory or + ;; attributes differ. + (or (not (string= dirname + (file-name-directory trial))) + (not (equal (file-attributes file) + (file-attributes trial))))) + (throw 'found trial)))) + templates)))) + +(defun vc-toggle-read-only (&optional verbose) + "Change read-only status of current buffer, perhaps via version control. + +If the buffer is visiting a file registered with version control, +then check the file in or out. Otherwise, just change the read-only flag +of the buffer. +With prefix argument, ask for version number to check in or check out. +Check-out of a specified version number does not lock the file; +to do that, use this command a second time with no argument. + +If you bind this function to \\[toggle-read-only], then Emacs checks files +in or out whenever you toggle the read-only flag." + (interactive "P") + (if (or (and (boundp 'vc-dired-mode) vc-dired-mode) + ;; use boundp because vc.el might not be loaded + (vc-backend (buffer-file-name))) + (vc-next-action verbose) + (toggle-read-only))) + +(defun vc-default-make-version-backups-p (backend file) + "Return non-nil if unmodified versions should be backed up locally. +The default is to switch off this feature." + nil) + +(defun vc-version-backup-file-name (file &optional rev manual regexp) + "Return a backup file name for REV or the current version of FILE. +If MANUAL is non-nil it means that a name for backups created by +the user should be returned; if REGEXP is non-nil that means to return +a regexp for matching all such backup files, regardless of the version." + (if regexp + (concat (regexp-quote (file-name-nondirectory file)) + "\\.~[0-9.]+" (unless manual "\\.") "~") + (expand-file-name (concat (file-name-nondirectory file) + ".~" (or rev (vc-workfile-version file)) + (unless manual ".") "~") + (file-name-directory file)))) + +(defun vc-delete-automatic-version-backups (file) + "Delete all existing automatic version backups for FILE." + (condition-case nil + (mapcar + 'delete-file + (directory-files (or (file-name-directory file) default-directory) t + (vc-version-backup-file-name file nil nil t))) + ;; Don't fail when the directory doesn't exist. + (file-error nil))) + +(defun vc-make-version-backup (file) + "Make a backup copy of FILE, which is assumed in sync with the repository. +Before doing that, check if there are any old backups and get rid of them." + (unless (and (fboundp 'msdos-long-file-names) + (not (msdos-long-file-names))) + (vc-delete-automatic-version-backups file) + (copy-file file (vc-version-backup-file-name file) + nil 'keep-date))) + +(defun vc-before-save () + "Function to be called by `basic-save-buffer' (in files.el)." + ;; If the file on disk is still in sync with the repository, + ;; and version backups should be made, copy the file to + ;; another name. This enables local diffs and local reverting. + (let ((file (buffer-file-name))) + (and (vc-backend file) + (vc-up-to-date-p file) + (eq (vc-checkout-model file) 'implicit) + (vc-call make-version-backups-p file) + (vc-make-version-backup file)))) + +(defun vc-after-save () + "Function to be called by `basic-save-buffer' (in files.el)." + ;; If the file in the current buffer is under version control, + ;; up-to-date, and locking is not used for the file, set + ;; the state to 'edited and redisplay the mode line. + (let ((file (buffer-file-name))) + (and (vc-backend file) + (or (and (equal (vc-file-getprop file 'vc-checkout-time) + (nth 5 (file-attributes file))) + ;; File has been saved in the same second in which + ;; it was checked out. Clear the checkout-time + ;; to avoid confusion. + (vc-file-setprop file 'vc-checkout-time nil)) + t) + (vc-up-to-date-p file) + (eq (vc-checkout-model file) 'implicit) + (vc-file-setprop file 'vc-state 'edited) + (vc-mode-line file) + (if (featurep 'vc) + ;; If VC is not loaded, then there can't be + ;; any VC Dired buffer to synchronize. + (vc-dired-resynch-file file))))) + +(defun vc-mode-line (file) + "Set `vc-mode' to display type of version control for FILE. +The value is set in the current buffer, which should be the buffer +visiting FILE." + (interactive (list buffer-file-name)) + (if (not (vc-backend file)) + (setq vc-mode nil) + (setq vc-mode (concat " " (if vc-display-status + (vc-call mode-line-string file) + (symbol-name (vc-backend file))))) + ;; If the file is locked by some other user, make + ;; the buffer read-only. Like this, even root + ;; cannot modify a file that someone else has locked. + (and (equal file (buffer-file-name)) + (stringp (vc-state file)) + (setq buffer-read-only t)) + ;; If the user is root, and the file is not owner-writable, + ;; then pretend that we can't write it + ;; even though we can (because root can write anything). + ;; This way, even root cannot modify a file that isn't locked. + (and (equal file (buffer-file-name)) + (not buffer-read-only) + (zerop (user-real-uid)) + (zerop (logand (file-modes (buffer-file-name)) 128)) + (setq buffer-read-only t))) + (force-mode-line-update) + (vc-backend file)) + +(defun vc-default-mode-line-string (backend file) + "Return string for placement in modeline by `vc-mode-line' for FILE. +Format: + + \"BACKEND-REV\" if the file is up-to-date + \"BACKEND:REV\" if the file is edited (or locked by the calling user) + \"BACKEND:LOCKER:REV\" if the file is locked by somebody else + +This function assumes that the file is registered." + (setq backend (symbol-name backend)) + (let ((state (vc-state file)) + (rev (vc-workfile-version file))) + (cond ((or (eq state 'up-to-date) + (eq state 'needs-patch)) + (concat backend "-" rev)) + ((stringp state) + (concat backend ":" state ":" rev)) + (t + ;; Not just for the 'edited state, but also a fallback + ;; for all other states. Think about different symbols + ;; for 'needs-patch and 'needs-merge. + (concat backend ":" rev))))) + +(defun vc-follow-link () + "If current buffer visits a symbolic link, visit the real file. +If the real file is already visited in another buffer, make that buffer +current, and kill the buffer that visits the link." + (let* ((truename (abbreviate-file-name (file-chase-links buffer-file-name))) + (true-buffer (find-buffer-visiting truename)) + (this-buffer (current-buffer))) + (if (eq true-buffer this-buffer) + (progn + (kill-buffer this-buffer) + ;; In principle, we could do something like set-visited-file-name. + ;; However, it can't be exactly the same as set-visited-file-name. + ;; I'm not going to work out the details right now. -- rms. + (set-buffer (find-file-noselect truename))) + (set-buffer true-buffer) + (kill-buffer this-buffer)))) + +(defun vc-find-file-hook () + "Function for `find-file-hooks' activating VC mode if appropriate." + ;; Recompute whether file is version controlled, + ;; if user has killed the buffer and revisited. + (if vc-mode + (setq vc-mode nil)) + (when buffer-file-name + (vc-file-clearprops buffer-file-name) + (cond + ((vc-backend buffer-file-name) + (vc-mode-line buffer-file-name) + (cond ((not vc-make-backup-files) + ;; Use this variable, not make-backup-files, + ;; because this is for things that depend on the file name. + (make-local-variable 'backup-inhibited) + (setq backup-inhibited t)))) + ((let* ((link (file-symlink-p buffer-file-name)) + (link-type (and link (vc-backend (file-chase-links link))))) + (if link-type + (cond ((eq vc-follow-symlinks nil) + (message + "Warning: symbolic link to %s-controlled source file" link-type)) + ((or (not (eq vc-follow-symlinks 'ask)) + ;; If we already visited this file by following + ;; the link, don't ask again if we try to visit + ;; it again. GUD does that, and repeated questions + ;; are painful. + (get-file-buffer + (abbreviate-file-name + (file-chase-links buffer-file-name)))) + + (vc-follow-link) + (message "Followed link to %s" buffer-file-name) + (vc-find-file-hook)) + (t + (if (yes-or-no-p (format + "Symbolic link to %s-controlled source file; follow link? " link-type)) + (progn (vc-follow-link) + (message "Followed link to %s" buffer-file-name) + (vc-find-file-hook)) + (message + "Warning: editing through the link bypasses version control") + ))))))))) + +(add-hook 'find-file-hooks 'vc-find-file-hook) + +;; more hooks, this time for file-not-found +(defun vc-file-not-found-hook () + "When file is not found, try to check it out from version control. +Returns t if checkout was successful, nil otherwise. +Used in `find-file-not-found-hooks'." + ;; When a file does not exist, ignore cached info about it + ;; from a previous visit. + (vc-file-clearprops buffer-file-name) + (if (and (vc-backend buffer-file-name) + (yes-or-no-p + (format "File %s was lost; check out from version control? " + (file-name-nondirectory 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) + +(defun vc-kill-buffer-hook () + "Discard VC info about a file when we kill its buffer." + (if (buffer-file-name) + (vc-file-clearprops (buffer-file-name)))) + +(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook) + +;; Now arrange for (autoloaded) bindings of the main package. +;; Bindings for this have to go in the global map, as we'll often +;; want to call them from random buffers. + +;; Autoloading works fine, but it prevents shortcuts from appearing +;; in the menu because they don't exist yet when the menu is built. +;; (autoload 'vc-prefix-map "vc" nil nil 'keymap) +(defvar vc-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "a" 'vc-update-change-log) + (define-key map "b" 'vc-switch-backend) + (define-key map "c" 'vc-cancel-version) + (define-key map "d" 'vc-directory) + (define-key map "g" 'vc-annotate) + (define-key map "h" 'vc-insert-headers) + (define-key map "i" 'vc-register) + (define-key map "l" 'vc-print-log) + (define-key map "m" 'vc-merge) + (define-key map "r" 'vc-retrieve-snapshot) + (define-key map "s" 'vc-create-snapshot) + (define-key map "u" 'vc-revert-buffer) + (define-key map "v" 'vc-next-action) + (define-key map "=" 'vc-diff) + (define-key map "~" 'vc-version-other-window) + map)) +(fset 'vc-prefix-map vc-prefix-map) +(define-key global-map "\C-xv" 'vc-prefix-map) + +(if (not (boundp 'vc-menu-map)) + ;; Don't do the menu bindings if menu-bar.el wasn't loaded to defvar + ;; vc-menu-map. + () + ;;(define-key vc-menu-map [show-files] + ;; '("Show Files under VC" . (vc-directory t))) + (define-key vc-menu-map [vc-retrieve-snapshot] + '("Retrieve Snapshot" . vc-retrieve-snapshot)) + (define-key vc-menu-map [vc-create-snapshot] + '("Create Snapshot" . vc-create-snapshot)) + (define-key vc-menu-map [vc-directory] '("VC Directory Listing" . vc-directory)) + (define-key vc-menu-map [separator1] '("----")) + (define-key vc-menu-map [vc-annotate] '("Annotate" . vc-annotate)) + (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file)) + (define-key vc-menu-map [vc-version-other-window] + '("Show Other Version" . vc-version-other-window)) + (define-key vc-menu-map [vc-diff] '("Compare with Base Version" . vc-diff)) + (define-key vc-menu-map [vc-update-change-log] + '("Update ChangeLog" . vc-update-change-log)) + (define-key vc-menu-map [vc-print-log] '("Show History" . vc-print-log)) + (define-key vc-menu-map [separator2] '("----")) + (define-key vc-menu-map [vc-insert-header] + '("Insert Header" . vc-insert-headers)) + (define-key vc-menu-map [undo] '("Undo Last Check-In" . vc-cancel-version)) + (define-key vc-menu-map [vc-revert-buffer] + '("Revert to Base Version" . vc-revert-buffer)) + (define-key vc-menu-map [vc-update] + '("Update to Latest Version" . vc-update)) + (define-key vc-menu-map [vc-next-action] '("Check In/Out" . vc-next-action)) + (define-key vc-menu-map [vc-register] '("Register" . vc-register))) + +;; These are not correct and it's not currently clear how doing it +;; better (with more complicated expressions) might slow things down +;; on older systems. + +;;(put 'vc-rename-file 'menu-enable 'vc-mode) +;;(put 'vc-annotate 'menu-enable '(eq (vc-buffer-backend) 'CVS)) +;;(put 'vc-version-other-window 'menu-enable 'vc-mode) +;;(put 'vc-diff 'menu-enable 'vc-mode) +;;(put 'vc-update-change-log 'menu-enable +;; '(member (vc-buffer-backend) '(RCS CVS))) +;;(put 'vc-print-log 'menu-enable 'vc-mode) +;;(put 'vc-cancel-version 'menu-enable 'vc-mode) +;;(put 'vc-revert-buffer 'menu-enable 'vc-mode) +;;(put 'vc-insert-headers 'menu-enable 'vc-mode) +;;(put 'vc-next-action 'menu-enable 'vc-mode) +;;(put 'vc-register 'menu-enable '(and buffer-file-name (not vc-mode))) + +(provide 'vc-hooks) + +;;; vc-hooks.el ends here