;;; vc-hooks.el --- resident support for version-control
;; Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,
-;; 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+;; 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: FSF (see vc.el for full credits)
;; Maintainer: Andre Spiegel <spiegel@gnu.org>
;; This file is part of GNU Emacs.
-;; GNU Emacs is free software; you can redistribute it and/or modify
+;; 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 3, or (at your option)
-;; any later version.
+;; the Free Software Foundation, either version 3 of the License, 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
;; 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., 51 Franklin Street, Fifth Floor,
-;; Boston, MA 02110-1301, USA.
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
(defcustom vc-ignore-dir-regexp
;; Stop SMB, automounter, AFS, and DFS host lookups.
- "\\`\\(?:[\\/][\\/]\\|/\\(?:net\\|afs\\|\\.\\\.\\.\\)/\\)\\'"
+ locate-dominating-stop-dir-regexp
"Regexp matching directory names that are not under VC's control.
The default regexp prevents fruitless and time-consuming attempts
to determine the VC status in directories in which filenames are
:type 'regexp
:group 'vc)
-(defcustom vc-handled-backends '(RCS CVS SVN SCCS Bzr Git Hg Mtn Arch MCVS)
+(defcustom vc-handled-backends '(RCS CVS SVN SCCS Bzr Git Hg Mtn Arch)
;; RCS, CVS, SVN and SCCS come first because they are per-dir
;; rather than per-tree. RCS comes first because of the multibackend
;; support intended to use RCS for local commits (with a remote CVS server).
:group 'vc)
;; Note: we don't actually have a darcs back end yet.
+;; Also, Meta-CVS (corresponsding to MCVS) is unsupported.
(defcustom vc-directory-exclusion-list '("SCCS" "RCS" "CVS" "MCVS"
".svn" ".git" ".hg" ".bzr"
"_MTN" "_darcs" "{arch}")
(funcall vc-mistrust-permissions
(vc-backend-subdirectory-name file)))))
-(defcustom vc-stay-local t
+(defcustom vc-stay-local 'only-file
"Non-nil means use local operations when possible for remote repositories.
This avoids slow queries over the network and instead uses heuristics
and past information to determine the current status of a file.
+If value is the symbol `only-file' `vc-dir' will connect to the
+server, but heuristics will be used to determine the status for
+all other VC operations.
+
The value can also be a regular expression or list of regular
expressions to match against the host name of a repository; then VC
only stays local for hosts that match it. Alternatively, the value
can be a list of regular expressions where the first element is the
symbol `except'; then VC always stays local except for hosts matched
by these regular expressions."
- :type '(choice (const :tag "Always stay local" t)
+ :type '(choice
+ (const :tag "Always stay local" t)
+ (const :tag "Only for file operations" only-file)
(const :tag "Don't stay local" nil)
(list :format "\nExamine hostname and %v" :tag "Examine hostname ..."
(set :format "%v" :inline t (const :format "%t" :tag "don't" except))
(regexp :format " stay local,\n%t: %v" :tag "if it matches")
(repeat :format "%v%i\n" :inline t (regexp :tag "or"))))
- :version "22.1"
+ :version "23.1"
:group 'vc)
(defun vc-stay-local-p (file)
(delq nil (mapcar 'vc-stay-local-p file))
(let* ((backend (vc-backend file))
(sym (vc-make-backend-sym backend 'stay-local))
- (stay-local (if (boundp sym) (symbol-value sym) t)))
- (if (eq stay-local t) (setq stay-local vc-stay-local))
+ (stay-local (if (boundp sym) (symbol-value sym) vc-stay-local)))
(if (symbolp stay-local) stay-local
(let ((dirname (if (file-directory-p file)
(directory-file-name file)
(defmacro vc-call (fun file &rest args)
"A convenience macro for calling VC backend functions.
Functions called by this macro must accept FILE as the first argument.
-ARGS specifies any additional arguments. FUN should be unquoted.
-BEWARE!! `file' is evaluated twice!!"
+ARGS specifies any additional arguments. FUN should be unquoted.
+BEWARE!! FILE is evaluated twice!!"
`(vc-call-backend (vc-backend ,file) ',fun ,file ,@args))
\f
(defsubst vc-parse-buffer (pattern i)
(set-buffer-modified-p nil)
t))
-(defun vc-find-root (file witness &optional invert)
+(defun vc-find-root (file witness)
"Find the root of a checked out project.
The function walks up the directory tree from FILE looking for WITNESS.
-If WITNESS if not found, return nil, otherwise return the root.
-Optional arg INVERT non-nil reverses the sense of the check;
-the root is the last directory for which WITNESS *is* found."
- ;; Represent /home/luser/foo as ~/foo so that we don't try to look for
- ;; witnesses in /home or in /.
- (setq file (abbreviate-file-name file))
- (let ((root nil)
- (prev-file file)
- ;; `user' is not initialized outside the loop because
- ;; `file' may not exist, so we may have to walk up part of the
- ;; hierarchy before we find the "initial UID".
- (user nil)
- try)
- (while (not (or root
- (null file)
- ;; As a heuristic, we stop looking up the hierarchy of
- ;; directories as soon as we find a directory belonging
- ;; to another user. This should save us from looking in
- ;; things like /net and /afs. This assumes that all the
- ;; files inside a project belong to the same user.
- (let ((prev-user user))
- (setq user (nth 2 (file-attributes file)))
- (and prev-user (not (equal user prev-user))))
- (string-match vc-ignore-dir-regexp file)))
- (setq try (file-exists-p (expand-file-name witness file)))
- (cond ((and invert (not try)) (setq root prev-file))
- ((and (not invert) try) (setq root file))
- ((equal file (setq prev-file file
- file (file-name-directory
- (directory-file-name file))))
- (setq file nil))))
- ;; Handle the case where ~/WITNESS exists and the original FILE is "~".
- ;; (This occurs, for example, when placing dotfiles under RCS.)
- (when (and (not root) invert prev-file)
- (setq root prev-file))
- root))
+If WITNESS if not found, return nil, otherwise return the root."
+ (let ((locate-dominating-stop-dir-regexp
+ (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)))
+ (locate-dominating-file file witness)))
;; 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
+;; if the property is already known or not. A property should
;; only be retrieved by vc-file-getprop if there is no
;; access function.)
backend is tried first."
(let (handler)
(cond
- ((and (file-name-directory file) (string-match vc-ignore-dir-regexp (file-name-directory file)))
+ ((and (file-name-directory file)
+ (string-match vc-ignore-dir-regexp (file-name-directory file)))
nil)
((and (boundp 'file-name-handler-alist)
(setq handler (find-file-name-handler file 'vc-registered)))
If FILES are not registered, this function always returns nil.
For registered files, the possible values are:
- 'implicit FILES are always writeable, and checked out `implicitly'
+ 'implicit FILES are always writable, and checked out `implicitly'
when the user saves the first changes to the file.
'locking FILES are read-only if up-to-date; user must type
'missing The file is not present in the file system, but the VC
system still tracks it.
- 'ignored The file showed up in a dir-state listing with a flag
+ 'ignored The file showed up in a dir-status listing with a flag
indicating the version-control system is ignoring it,
Note: This property is not set reliably (some VCSes
don't have useful directory-status commands) so assume
'unregistered The file is not under version control.
A return of nil from this function means we have no information on the
-status of this file.
-"
- ;; Note: in Emacs 22 and older, return of nil meant the file was unregistered.
- ;; This is potentially a source of backward-compatibility bugs.
+status of this file."
+ ;; Note: in Emacs 22 and older, return of nil meant the file was
+ ;; unregistered. This is potentially a source of
+ ;; backward-compatibility bugs.
;; FIXME: New (sub)states needed (?):
- ;; - `conflict' (i.e. `edited' with conflict markers)
- ;; - `removed'
;; - `copied' and `moved' (might be handled by `removed' and `added')
(or (vc-file-getprop file 'vc-state)
- (when (and (> (length file) 0) (vc-backend file))
- (vc-file-setprop file 'vc-state
- (vc-call state-heuristic file)))))
-
-(defun vc-recompute-state (file)
- "Recompute the version control state of FILE, and return it.
-This calls the possibly expensive function vc-BACKEND-state,
-rather than the heuristic."
- (vc-file-setprop file 'vc-state (vc-call state file)))
+ (when (> (length file) 0)
+ (let ((backend (vc-backend file)))
+ (when backend
+ (vc-file-setprop
+ file 'vc-state
+ (vc-call-backend backend '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.
+ "Default implementation of vc-BACKEND-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))
"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))))
+ ;; This is a shortcut for determining when the workfile is
+ ;; unchanged. It can fail under some circumstances; see the
+ ;; discussion in bug#694.
(if (and checkout-time
- ;; Tramp and Ange-FTP return this when they don't know the time.
- (not (equal lastmod '(0 0))))
- (equal checkout-time lastmod)
+ ;; Tramp and Ange-FTP return this when they don't know the time.
+ (not (equal lastmod '(0 0))))
+ (equal checkout-time lastmod)
(let ((unchanged (vc-call workfile-unchanged-p file)))
- (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
- unchanged))))
+ (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.
(zerop (condition-case err
;; If the implementation supports it, let the output
;; go to *vc*, not *vc-diff*, since this is an internal call.
- (vc-call diff (list file) nil nil "*vc*")
+ (vc-call-backend backend 'diff (list file) nil nil "*vc*")
(wrong-number-of-arguments
;; If this error came from the above call to vc-BACKEND-diff,
;; try again without the optional buffer argument (for
;; backward compatibility). Otherwise, resignal.
(if (or (not (eq (cadr err)
(indirect-function
- (vc-find-backend-function (vc-backend file)
- 'diff))))
+ (vc-find-backend-function backend 'diff))))
(not (eq (caddr err) 4)))
(signal (car err) (cdr err))
- (vc-call diff (list file)))))))
+ (vc-call-backend backend 'diff (list file)))))))
(defun vc-working-revision (file)
"Return the repository version from which FILE was checked out.
If FILE is not registered, this function always returns nil."
(or (vc-file-getprop file 'vc-working-revision)
- (when (vc-backend file)
- (vc-file-setprop file 'vc-working-revision
- (vc-call working-revision file)))))
+ (let ((backend (vc-backend file)))
+ (when backend
+ (vc-file-setprop file 'vc-working-revision
+ (vc-call-backend backend 'working-revision file))))))
;; Backward compatibility.
(define-obsolete-function-alias
'vc-workfile-version 'vc-working-revision "23.1")
-(define-obsolete-function-alias
- 'vc-previous-version 'vc-previous-revision "23.1")
(defun vc-default-working-revision (backend file)
(message
"`working-revision' not found: using the old `workfile-version' instead")
"Change read-only status of current buffer, perhaps via version control.
If the buffer is visiting a file registered with version control,
-throw an error, because this is not a safe or really meaningful operation
-on any version-control system newer than RCS.
+throw an error, because this is not a safe or really meaningful operation
+on any version-control system newer than RCS.
Otherwise, just change the read-only flag of the buffer.
(ignore-errors ;Be careful not to prevent saving the file.
(and (setq backend (vc-backend file))
(vc-up-to-date-p file)
- (eq (vc-checkout-model backend file) 'implicit)
- (vc-call make-version-backups-p file)
+ (eq (vc-checkout-model backend (list file)) 'implicit)
+ (vc-call-backend backend 'make-version-backups-p file)
(vc-make-version-backup file)))))
-(declare-function vc-directory-resynch-file "vc" (file))
+(declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
(defun vc-after-save ()
"Function to be called by `basic-save-buffer' (in files.el)."
(vc-file-setprop file 'vc-checkout-time nil))
t)
(vc-up-to-date-p file)
- (eq (vc-checkout-model backend file) 'implicit)
+ (eq (vc-checkout-model backend (list file)) 'implicit)
(vc-file-setprop file 'vc-state 'edited)
(vc-mode-line file)
- (when (featurep 'vc)
- ;; If VC is not loaded, then there can't be
- ;; any VC Dired buffer to synchronize.
- (vc-directory-resynch-file file)))))
+ ;; Try to avoid unnecessary work, a *vc-dir* buffer is only
+ ;; present if this is true.
+ (when (memq 'vc-dir-resynch-file after-save-hook)
+ (vc-dir-resynch-file file)))))
(defvar vc-menu-entry
'(menu-item "Version Control" vc-menu-map
(let ((backend (vc-backend file)))
(if (not backend)
(setq vc-mode nil)
- (let* ((ml-string (vc-call mode-line-string file))
+ (let* ((ml-string (vc-call-backend backend 'mode-line-string file))
(ml-echo (get-text-property 0 'help-echo ml-string)))
(setq vc-mode
(concat
;; 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)
+ ;; 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)))
"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))
+ (let* ((true-buffer (find-buffer-visiting buffer-file-truename))
(this-buffer (current-buffer)))
(if (eq true-buffer this-buffer)
- (progn
+ (let ((truename buffer-file-truename))
(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.
(setq vc-mode nil))
(when buffer-file-name
(vc-file-clearprops buffer-file-name)
+ (add-hook 'mode-line-hook 'vc-mode-line nil t)
(cond
((with-demoted-errors (vc-backend buffer-file-name))
;; Compute the state and put it in the modeline.
(set (make-local-variable 'backup-inhibited) t))
;; Let the backend setup any buffer-local things he needs.
(vc-call-backend (vc-backend buffer-file-name) 'find-file-hook))
- ((let ((link-type (and (file-symlink-p buffer-file-name)
- (vc-backend (file-chase-links buffer-file-name)))))
+ ((let ((link-type (and (not (equal buffer-file-name buffer-file-truename))
+ (vc-backend buffer-file-truename))))
(cond ((not link-type) nil) ;Nothing to do.
((eq vc-follow-symlinks nil)
(message
Used in `find-file-not-found-functions'."
;; When a file does not exist, ignore cached info about it
;; from a previous visit.
- (vc-file-clearprops buffer-file-name)
- (let ((backend (vc-backend buffer-file-name)))
- (when backend (vc-call-backend backend 'find-file-not-found-hook))))
+ ;; We check that `buffer-file-name' is non-nil. It should be always
+ ;; the case, but in conjunction with Tramp, it might be nil. M. Albinus.
+ (when buffer-file-name
+ (vc-file-clearprops buffer-file-name)
+ (let ((backend (vc-backend buffer-file-name)))
+ (when backend (vc-call-backend backend 'find-file-not-found-hook)))))
(defun vc-default-find-file-not-found-hook (backend)
;; This used to do what vc-rcs-find-file-not-found-hook does, but it only
(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 "r" 'vc-retrieve-tag)
+ (define-key map "s" 'vc-create-tag)
(define-key map "u" 'vc-revert)
(define-key map "v" 'vc-next-action)
(define-key map "+" 'vc-update)
(define-key map "=" 'vc-diff)
(define-key map "~" 'vc-revision-other-window)
- ;; `vc-dir' is a not-quite-ready replacement for `vc-directory'
- ;; (define-key map "?" 'vc-dir)
map))
(fset 'vc-prefix-map vc-prefix-map)
(define-key global-map "\C-xv" 'vc-prefix-map)
(let ((map (make-sparse-keymap "Version Control")))
;;(define-key map [show-files]
;; '("Show Files under VC" . (vc-directory t)))
- (define-key map [vc-retrieve-snapshot]
- '(menu-item "Retrieve Snapshot" vc-retrieve-snapshot
- :help "Retrieve snapshot"))
- (define-key map [vc-create-snapshot]
- '(menu-item "Create Snapshot" vc-create-snapshot
- :help "Create Snapshot"))
+ (define-key map [vc-retrieve-tag]
+ '(menu-item "Retrieve Tag" vc-retrieve-tag
+ :help "Retrieve tagged version or branch"))
+ (define-key map [vc-create-tag]
+ '(menu-item "Create Tag" vc-create-tag
+ :help "Create version tag"))
(define-key map [separator1] '("----"))
(define-key map [vc-annotate]
'(menu-item "Annotate" vc-annotate
(defun vc-default-extra-menu (backend)
nil)
-;; 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-revision-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-rollback 'menu-enable 'vc-mode)
-;;(put 'vc-revert '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)
;; arch-tag: 2e5a6fa7-1d30-48e2-8bd0-e3d335f04f32