* configure.ac: Fix minimum Jansson version requirement.
[emacs.git] / lisp / vc / vc-hooks.el
blob99c8211ad5ff8ca41fea476c89a983eb94cddc26
1 ;;; vc-hooks.el --- resident support for version-control
3 ;; Copyright (C) 1992-1996, 1998-2017 Free Software Foundation, Inc.
5 ;; Author: FSF (see vc.el for full credits)
6 ;; Maintainer: emacs-devel@gnu.org
7 ;; Package: vc
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>.
24 ;;; Commentary:
26 ;; This is the always-loaded portion of VC. It takes care of
27 ;; VC-related activities that are done when you visit a file, so that
28 ;; vc.el itself is loaded only when you use a VC command. See the
29 ;; commentary of vc.el.
31 ;;; Code:
33 (eval-when-compile (require 'cl-lib))
35 ;; Faces
37 (defgroup vc-state-faces nil
38 "Faces used in the mode line by the VC state indicator."
39 :group 'vc-faces
40 :group 'mode-line
41 :version "25.1")
43 (defface vc-state-base
44 '((default))
45 "Base face for VC state indicator."
46 :group 'vc-faces
47 :group 'mode-line
48 :version "25.1")
50 (defface vc-up-to-date-state
51 '((default :inherit vc-state-base))
52 "Face for VC modeline state when the file is up to date."
53 :version "25.1"
54 :group 'vc-faces)
56 (defface vc-needs-update-state
57 '((default :inherit vc-state-base))
58 "Face for VC modeline state when the file needs update."
59 :version "25.1"
60 :group 'vc-faces)
62 (defface vc-locked-state
63 '((default :inherit vc-state-base))
64 "Face for VC modeline state when the file locked."
65 :version "25.1"
66 :group 'vc-faces)
68 (defface vc-locally-added-state
69 '((default :inherit vc-state-base))
70 "Face for VC modeline state when the file is locally added."
71 :version "25.1"
72 :group 'vc-faces)
74 (defface vc-conflict-state
75 '((default :inherit vc-state-base))
76 "Face for VC modeline state when the file contains merge conflicts."
77 :version "25.1"
78 :group 'vc-faces)
80 (defface vc-removed-state
81 '((default :inherit vc-state-base))
82 "Face for VC modeline state when the file was removed from the VC system."
83 :version "25.1"
84 :group 'vc-faces)
86 (defface vc-missing-state
87 '((default :inherit vc-state-base))
88 "Face for VC modeline state when the file is missing from the file system."
89 :version "25.1"
90 :group 'vc-faces)
92 (defface vc-edited-state
93 '((default :inherit vc-state-base))
94 "Face for VC modeline state when the file is edited."
95 :version "25.1"
96 :group 'vc-faces)
98 ;; Customization Variables (the rest is in vc.el)
100 (defcustom vc-ignore-dir-regexp
101 ;; Stop SMB, automounter, AFS, and DFS host lookups.
102 locate-dominating-stop-dir-regexp
103 "Regexp matching directory names that are not under VC's control.
104 The default regexp prevents fruitless and time-consuming attempts
105 to determine the VC status in directories in which filenames are
106 interpreted as hostnames."
107 :type 'regexp
108 :group 'vc)
110 (defcustom vc-handled-backends '(RCS CVS SVN SCCS SRC Bzr Git Hg Mtn)
111 ;; RCS, CVS, SVN, SCCS, and SRC come first because they are per-dir
112 ;; rather than per-tree. RCS comes first because of the multibackend
113 ;; support intended to use RCS for local commits (with a remote CVS server).
114 "List of version control backends for which VC will be used.
115 Entries in this list will be tried in order to determine whether a
116 file is under that sort of version control.
117 Removing an entry from the list prevents VC from being activated
118 when visiting a file managed by that backend.
119 An empty list disables VC altogether."
120 :type '(repeat symbol)
121 :version "25.1"
122 :group 'vc)
124 ;; Note: we don't actually have a darcs back end yet.
125 ;; Also, Arch is unsupported, and the Meta-CVS back end has been removed.
126 ;; The Arch back end will be retrieved and fixed if it is ever required.
127 (defcustom vc-directory-exclusion-list (purecopy '("SCCS" "RCS" "CVS" "MCVS"
128 ".src" ".svn" ".git" ".hg" ".bzr"
129 "_MTN" "_darcs" "{arch}"))
130 "List of directory names to be ignored when walking directory trees."
131 :type '(repeat string)
132 :group 'vc)
134 (defcustom vc-make-backup-files nil
135 "If non-nil, backups of registered files are made as with other files.
136 If nil (the default), files covered by version control don't get backups."
137 :type 'boolean
138 :group 'vc
139 :group 'backup)
141 (defcustom vc-follow-symlinks 'ask
142 "What to do if visiting a symbolic link to a file under version control.
143 Editing such a file through the link bypasses the version control system,
144 which is dangerous and probably not what you want.
146 If this variable is t, VC follows the link and visits the real file,
147 telling you about it in the echo area. If it is `ask', VC asks for
148 confirmation whether it should follow the link. If nil, the link is
149 visited and a warning displayed."
150 :type '(choice (const :tag "Ask for confirmation" ask)
151 (const :tag "Visit link and warn" nil)
152 (const :tag "Follow link" t))
153 :group 'vc)
155 (defcustom vc-display-status t
156 "If non-nil, display revision number and lock status in mode line.
157 Otherwise, not displayed."
158 :type 'boolean
159 :group 'vc)
162 (defcustom vc-consult-headers t
163 "If non-nil, identify work files by searching for version headers."
164 :type 'boolean
165 :group 'vc)
167 ;;; This is handled specially now.
168 ;; Tell Emacs about this new kind of minor mode
169 ;; (add-to-list 'minor-mode-alist '(vc-mode vc-mode))
171 ;;;###autoload
172 (put 'vc-mode 'risky-local-variable t)
173 (make-variable-buffer-local 'vc-mode)
174 (put 'vc-mode 'permanent-local t)
176 ;;; We signal this error when we try to do something a VC backend
177 ;;; doesn't support. Two arguments: the method that's not supported
178 ;;; and the backend
179 (define-error 'vc-not-supported "VC method not implemented for backend")
181 (defun vc-mode (&optional _arg)
182 ;; Dummy function for C-h m
183 "Version Control minor mode.
184 This minor mode is automatically activated whenever you visit a file under
185 control of one of the revision control systems in `vc-handled-backends'.
186 VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
187 \\{vc-prefix-map}")
189 (defmacro vc-error-occurred (&rest body)
190 `(condition-case nil (progn ,@body nil) (error t)))
192 ;; We need a notion of per-file properties because the version
193 ;; control state of a file is expensive to derive --- we compute
194 ;; them when the file is initially found, keep them up to date
195 ;; during any subsequent VC operations, and forget them when
196 ;; the buffer is killed.
198 (defvar vc-file-prop-obarray (make-vector 17 0)
199 "Obarray for per-file properties.")
201 (defvar vc-touched-properties nil)
203 (defun vc-file-setprop (file property value)
204 "Set per-file VC PROPERTY for FILE to VALUE."
205 (if (and vc-touched-properties
206 (not (memq property vc-touched-properties)))
207 (setq vc-touched-properties (append (list property)
208 vc-touched-properties)))
209 (put (intern (expand-file-name file) vc-file-prop-obarray) property value))
211 (defun vc-file-getprop (file property)
212 "Get per-file VC PROPERTY for FILE."
213 (get (intern (expand-file-name file) vc-file-prop-obarray) property))
215 (defun vc-file-clearprops (file)
216 "Clear all VC properties of FILE."
217 (if (boundp 'vc-parent-buffer)
218 (kill-local-variable 'vc-parent-buffer))
219 (setplist (intern (expand-file-name file) vc-file-prop-obarray) nil))
222 ;; We keep properties on each symbol naming a backend as follows:
223 ;; * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION.
225 (defun vc-make-backend-sym (backend sym)
226 "Return BACKEND-specific version of VC symbol SYM."
227 (intern (concat "vc-" (downcase (symbol-name backend))
228 "-" (symbol-name sym))))
230 (defun vc-find-backend-function (backend fun)
231 "Return BACKEND-specific implementation of FUN.
232 If there is no such implementation, return the default implementation;
233 if that doesn't exist either, return nil."
234 (let ((f (vc-make-backend-sym backend fun)))
235 (if (fboundp f) f
236 ;; Load vc-BACKEND.el if needed.
237 (require (intern (concat "vc-" (downcase (symbol-name backend)))))
238 (if (fboundp f) f
239 (let ((def (vc-make-backend-sym 'default fun)))
240 (if (fboundp def) (cons def backend) nil))))))
242 (defun vc-call-backend (backend function-name &rest args)
243 "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS.
244 Calls
246 (apply \\='vc-BACKEND-FUN ARGS)
248 if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el)
249 and else calls
251 (apply \\='vc-default-FUN BACKEND ARGS)
253 It is usually called via the `vc-call' macro."
254 (let ((f (assoc function-name (get backend 'vc-functions))))
255 (if f (setq f (cdr f))
256 (setq f (vc-find-backend-function backend function-name))
257 (push (cons function-name f) (get backend 'vc-functions)))
258 (cond
259 ((null f)
260 (signal 'vc-not-supported (list function-name backend)))
261 ((consp f) (apply (car f) (cdr f) args))
262 (t (apply f args)))))
264 (defmacro vc-call (fun file &rest args)
265 "A convenience macro for calling VC backend functions.
266 Functions called by this macro must accept FILE as the first argument.
267 ARGS specifies any additional arguments. FUN should be unquoted.
268 BEWARE!! FILE is evaluated twice!!"
269 `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args))
271 (defsubst vc-parse-buffer (pattern i)
272 "Find PATTERN in the current buffer and return its Ith submatch."
273 (goto-char (point-min))
274 (if (re-search-forward pattern nil t)
275 (match-string i)))
277 (defun vc-insert-file (file &optional limit blocksize)
278 "Insert the contents of FILE into the current buffer.
280 Optional argument LIMIT is a regexp. If present, the file is inserted
281 in chunks of size BLOCKSIZE (default 8 kByte), until the first
282 occurrence of LIMIT is found. Anything from the start of that occurrence
283 to the end of the buffer is then deleted. The function returns
284 non-nil if FILE exists and its contents were successfully inserted."
285 (erase-buffer)
286 (when (file-exists-p file)
287 (if (not limit)
288 (insert-file-contents file)
289 (unless blocksize (setq blocksize 8192))
290 (let ((filepos 0))
291 (while
292 (and (< 0 (cadr (insert-file-contents
293 file nil filepos (cl-incf filepos blocksize))))
294 (progn (beginning-of-line)
295 (let ((pos (re-search-forward limit nil 'move)))
296 (when pos (delete-region (match-beginning 0)
297 (point-max)))
298 (not pos)))))))
299 (set-buffer-modified-p nil)
302 (defun vc-find-root (file witness)
303 "Find the root of a checked out project.
304 The function walks up the directory tree from FILE looking for WITNESS.
305 If WITNESS if not found, return nil, otherwise return the root."
306 (let ((locate-dominating-stop-dir-regexp
307 (or vc-ignore-dir-regexp locate-dominating-stop-dir-regexp)))
308 (locate-dominating-file file witness)))
310 ;; Access functions to file properties
311 ;; (Properties should be _set_ using vc-file-setprop, but
312 ;; _retrieved_ only through these functions, which decide
313 ;; if the property is already known or not. A property should
314 ;; only be retrieved by vc-file-getprop if there is no
315 ;; access function.)
317 ;; properties indicating the backend being used for FILE
319 (defun vc-registered (file)
320 "Return non-nil if FILE is registered in a version control system.
322 This function performs the check each time it is called. To rely
323 on the result of a previous call, use `vc-backend' instead. If the
324 file was previously registered under a certain backend, then that
325 backend is tried first."
326 (let (handler)
327 (cond
328 ((and (file-name-directory file)
329 (string-match vc-ignore-dir-regexp (file-name-directory file)))
330 nil)
331 ((and (boundp 'file-name-handler-alist)
332 (setq handler (find-file-name-handler file 'vc-registered)))
333 ;; handler should set vc-backend and return t if registered
334 (funcall handler 'vc-registered file))
336 ;; There is no file name handler.
337 ;; Try vc-BACKEND-registered for each handled BACKEND.
338 (catch 'found
339 (let ((backend (vc-file-getprop file 'vc-backend)))
340 (mapc
341 (lambda (b)
342 (and (vc-call-backend b 'registered file)
343 (vc-file-setprop file 'vc-backend b)
344 (throw 'found t)))
345 (if (or (not backend) (eq backend 'none))
346 vc-handled-backends
347 (cons backend vc-handled-backends))))
348 ;; File is not registered.
349 (vc-file-setprop file 'vc-backend 'none)
350 nil)))))
352 (defun vc-backend (file-or-list)
353 "Return the version control type of FILE-OR-LIST, nil if it's not registered.
354 If the argument is a list, the files must all have the same back end."
355 ;; `file' can be nil in several places (typically due to the use of
356 ;; code like (vc-backend buffer-file-name)).
357 (cond ((stringp file-or-list)
358 (let ((property (vc-file-getprop file-or-list 'vc-backend)))
359 ;; Note that internally, Emacs remembers unregistered
360 ;; files by setting the property to `none'.
361 (cond ((eq property 'none) nil)
362 (property)
363 ;; vc-registered sets the vc-backend property
364 (t (if (vc-registered file-or-list)
365 (vc-file-getprop file-or-list 'vc-backend)
366 nil)))))
367 ((and file-or-list (listp file-or-list))
368 (vc-backend (car file-or-list)))
370 nil)))
373 (defun vc-backend-subdirectory-name (file)
374 "Return where the repository for the current directory is kept."
375 (symbol-name (vc-backend file)))
377 (defun vc-checkout-model (backend files)
378 "Indicate how FILES are checked out.
380 If FILES are not registered, this function always returns nil.
381 For registered files, the possible values are:
383 `implicit' FILES are always writable, and checked out `implicitly'
384 when the user saves the first changes to the file.
386 `locking' FILES are read-only if up-to-date; user must type
387 \\[vc-next-action] before editing. Strict locking
388 is assumed.
390 `announce' FILES are read-only if up-to-date; user must type
391 \\[vc-next-action] before editing. But other users
392 may be editing at the same time."
393 (vc-call-backend backend 'checkout-model files))
395 (defun vc-user-login-name (file)
396 "Return the name under which the user accesses the given FILE."
397 (or (and (file-remote-p file)
398 ;; tramp case: execute "whoami" via tramp
399 (let ((default-directory (file-name-directory file))
400 process-file-side-effects)
401 (with-temp-buffer
402 (if (not (zerop (process-file "whoami" nil t)))
403 ;; fall through if "whoami" didn't work
405 ;; remove trailing newline
406 (delete-region (1- (point-max)) (point-max))
407 (buffer-string)))))
408 ;; normal case
409 (user-login-name)
410 ;; if user-login-name is nil, return the UID as a string
411 (number-to-string (user-uid))))
413 (defun vc-state (file &optional backend)
414 "Return the version control state of FILE.
416 A return of nil from this function means we have no information on the
417 status of this file. Otherwise, the value returned is one of:
419 `up-to-date' The working file is unmodified with respect to the
420 latest version on the current branch, and not locked.
422 `edited' The working file has been edited by the user. If
423 locking is used for the file, this state means that
424 the current version is locked by the calling user.
425 This status should *not* be reported for files
426 which have a changed mtime but the same content
427 as the repo copy.
429 USER The current version of the working file is locked by
430 some other USER (a string).
432 `needs-update' The file has not been edited by the user, but there is
433 a more recent version on the current branch stored
434 in the repository.
436 `needs-merge' The file has been edited by the user, and there is also
437 a more recent version on the current branch stored in
438 the repository. This state can only occur if locking
439 is not used for the file.
441 `unlocked-changes' The working version of the file is not locked,
442 but the working file has been changed with respect
443 to that version. This state can only occur for files
444 with locking; it represents an erroneous condition that
445 should be resolved by the user (vc-next-action will
446 prompt the user to do it).
448 `added' Scheduled to go into the repository on the next commit.
449 Often represented by vc-working-revision = \"0\" in VCSes
450 with monotonic IDs like Subversion and Mercurial.
452 `removed' Scheduled to be deleted from the repository on next commit.
454 `conflict' The file contains conflicts as the result of a merge.
455 For now the conflicts are text conflicts. In the
456 future this might be extended to deal with metadata
457 conflicts too.
459 `missing' The file is not present in the file system, but the VC
460 system still tracks it.
462 `ignored' The file showed up in a dir-status listing with a flag
463 indicating the version-control system is ignoring it,
464 Note: This property is not set reliably (some VCSes
465 don't have useful directory-status commands) so assume
466 that any file with vc-state nil might be ignorable
467 without VC knowing it.
469 `unregistered' The file is not under version control."
471 ;; Note: we usually return nil here for unregistered files anyway
472 ;; when called with only one argument. This doesn't seem to cause
473 ;; any problems. But if we wanted to change that, we should
474 ;; probably opt for redefining the `registered' command to return
475 ;; non-nil even for unregistered files (maybe also rename it), and
476 ;; then make sure that all `state' implementations handle
477 ;; unregistered file appropriately.
479 ;; FIXME: New (sub)states needed (?):
480 ;; - `copied' and `moved' (might be handled by `removed' and `added')
481 (or (vc-file-getprop file 'vc-state)
482 (when (> (length file) 0) ;Why?? --Stef
483 (setq backend (or backend (vc-backend file)))
484 (when backend
485 (vc-state-refresh file backend)))))
487 (defun vc-state-refresh (file backend)
488 "Quickly recompute the `state' of FILE."
489 (vc-file-setprop
490 file 'vc-state
491 (vc-call-backend backend 'state file)))
493 (defsubst vc-up-to-date-p (file)
494 "Convenience function that checks whether `vc-state' of FILE is `up-to-date'."
495 (eq (vc-state file) 'up-to-date))
497 (defun vc-working-revision (file &optional backend)
498 "Return the repository version from which FILE was checked out.
499 If FILE is not registered, this function always returns nil."
500 (or (vc-file-getprop file 'vc-working-revision)
501 (progn
502 (setq backend (or backend (vc-backend file)))
503 (when backend
504 (vc-file-setprop file 'vc-working-revision
505 (vc-call-backend
506 backend 'working-revision file))))))
508 ;; Backward compatibility.
509 (define-obsolete-function-alias
510 'vc-workfile-version 'vc-working-revision "23.1")
511 (defun vc-default-working-revision (backend file)
512 (message
513 "`working-revision' not found: using the old `workfile-version' instead")
514 (vc-call-backend backend 'workfile-version file))
516 (defun vc-default-registered (backend file)
517 "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
518 (let ((sym (vc-make-backend-sym backend 'master-templates)))
519 (unless (get backend 'vc-templates-grabbed)
520 (put backend 'vc-templates-grabbed t))
521 (let ((result (vc-check-master-templates file (symbol-value sym))))
522 (if (stringp result)
523 (vc-file-setprop file 'vc-master-name result)
524 nil)))) ; Not registered
526 ;;;###autoload
527 (defun vc-possible-master (s dirname basename)
528 (cond
529 ((stringp s) (format s dirname basename))
530 ((functionp s)
531 ;; The template is a function to invoke. If the
532 ;; function returns non-nil, that means it has found a
533 ;; master. For backward compatibility, we also handle
534 ;; the case that the function throws a 'found atom
535 ;; and a pair (cons MASTER-FILE BACKEND).
536 (let ((result (catch 'found (funcall s dirname basename))))
537 (if (consp result) (car result) result)))))
539 (defun vc-check-master-templates (file templates)
540 "Return non-nil if there is a master corresponding to FILE.
542 TEMPLATES is a list of strings or functions. If an element is a
543 string, it must be a control string as required by `format', with two
544 string placeholders, such as \"%sRCS/%s,v\". The directory part of
545 FILE is substituted for the first placeholder, the basename of FILE
546 for the second. If a file with the resulting name exists, it is taken
547 as the master of FILE, and returned.
549 If an element of TEMPLATES is a function, it is called with the
550 directory part and the basename of FILE as arguments. It should
551 return non-nil if it finds a master; that value is then returned by
552 this function."
553 (let ((dirname (or (file-name-directory file) ""))
554 (basename (file-name-nondirectory file)))
555 (catch 'found
556 (mapcar
557 (lambda (s)
558 (let ((trial (vc-possible-master s dirname basename)))
559 (when (and trial (file-exists-p trial)
560 ;; Make sure the file we found with name
561 ;; TRIAL is not the source file itself.
562 ;; That can happen with RCS-style names if
563 ;; the file name is truncated (e.g. to 14
564 ;; chars). See if either directory or
565 ;; attributes differ.
566 (or (not (string= dirname
567 (file-name-directory trial)))
568 (not (equal (file-attributes file)
569 (file-attributes trial)))))
570 (throw 'found trial))))
571 templates))))
574 ;; toggle-read-only is obsolete since 24.3, but since vc-t-r-o was made
575 ;; obsolete earlier, it is ok for the latter to be an alias to the former,
576 ;; since the latter will be removed first. We can't just make it
577 ;; an alias for read-only-mode, since that is not 100% the same.
578 (defalias 'vc-toggle-read-only 'toggle-read-only)
579 (make-obsolete 'vc-toggle-read-only
580 "use `read-only-mode' instead (or `toggle-read-only' in older versions of Emacs)."
581 "24.1")
583 (defun vc-default-make-version-backups-p (_backend _file)
584 "Return non-nil if unmodified versions should be backed up locally.
585 The default is to switch off this feature."
586 nil)
588 (defun vc-version-backup-file-name (file &optional rev manual regexp)
589 "Return a backup file name for REV or the current version of FILE.
590 If MANUAL is non-nil it means that a name for backups created by
591 the user should be returned; if REGEXP is non-nil that means to return
592 a regexp for matching all such backup files, regardless of the version."
593 (if regexp
594 (concat (regexp-quote (file-name-nondirectory file))
595 "\\.~.+" (unless manual "\\.") "~")
596 (expand-file-name (concat (file-name-nondirectory file)
597 ".~" (subst-char-in-string
598 ?/ ?_ (or rev (vc-working-revision file)))
599 (unless manual ".") "~")
600 (file-name-directory file))))
602 (defun vc-delete-automatic-version-backups (file)
603 "Delete all existing automatic version backups for FILE."
604 (condition-case nil
605 (mapc
606 'delete-file
607 (directory-files (or (file-name-directory file) default-directory) t
608 (vc-version-backup-file-name file nil nil t)))
609 ;; Don't fail when the directory doesn't exist.
610 (file-error nil)))
612 (defun vc-make-version-backup (file)
613 "Make a backup copy of FILE, which is assumed in sync with the repository.
614 Before doing that, check if there are any old backups and get rid of them."
615 (unless (and (fboundp 'msdos-long-file-names)
616 (not (with-no-warnings (msdos-long-file-names))))
617 (vc-delete-automatic-version-backups file)
618 (condition-case nil
619 (copy-file file (vc-version-backup-file-name file)
620 nil 'keep-date)
621 ;; It's ok if it doesn't work (e.g. directory not writable),
622 ;; since this is just for efficiency.
623 (file-error
624 (message
625 (concat "Warning: Cannot make version backup; "
626 "diff/revert therefore not local"))))))
628 (defun vc-before-save ()
629 "Function to be called by `basic-save-buffer' (in files.el)."
630 ;; If the file on disk is still in sync with the repository,
631 ;; and version backups should be made, copy the file to
632 ;; another name. This enables local diffs and local reverting.
633 (let ((file buffer-file-name)
634 backend)
635 (ignore-errors ;Be careful not to prevent saving the file.
636 (unless (file-exists-p file)
637 (vc-file-clearprops file))
638 (and (setq backend (vc-backend file))
639 (vc-up-to-date-p file)
640 (eq (vc-checkout-model backend (list file)) 'implicit)
641 (vc-call-backend backend 'make-version-backups-p file)
642 (vc-make-version-backup file)))))
644 (declare-function vc-dir-resynch-file "vc-dir" (&optional fname))
646 (defvar vc-dir-buffers nil "List of vc-dir buffers.")
648 (defun vc-after-save ()
649 "Function to be called by `basic-save-buffer' (in files.el)."
650 ;; If the file in the current buffer is under version control,
651 ;; up-to-date, and locking is not used for the file, set
652 ;; the state to 'edited and redisplay the mode line.
653 (let* ((file buffer-file-name)
654 (backend (vc-backend file)))
655 (cond
656 ((null backend))
657 ((eq (vc-checkout-model backend (list file)) 'implicit)
658 ;; If the file was saved in the same second in which it was
659 ;; checked out, clear the checkout-time to avoid confusion.
660 (if (equal (vc-file-getprop file 'vc-checkout-time)
661 (nth 5 (file-attributes file)))
662 (vc-file-setprop file 'vc-checkout-time nil))
663 (if (vc-state-refresh file backend)
664 (vc-mode-line file backend)))
665 ;; If we saved an unlocked file on a locking based VCS, that
666 ;; file is not longer up-to-date.
667 ((eq (vc-file-getprop file 'vc-state) 'up-to-date)
668 (vc-file-setprop file 'vc-state nil)))
669 ;; Resynch *vc-dir* buffers, if any are present.
670 (when vc-dir-buffers
671 (vc-dir-resynch-file file))))
673 (defvar vc-menu-entry
674 `(menu-item ,(purecopy "Version Control") vc-menu-map
675 :filter vc-menu-map-filter))
677 (when (boundp 'menu-bar-tools-menu)
678 ;; We do not need to worry here about the placement of this entry
679 ;; because menu-bar.el has already created the proper spot for us
680 ;; and this will simply use it.
681 (define-key menu-bar-tools-menu [vc] vc-menu-entry))
683 (defconst vc-mode-line-map
684 (let ((map (make-sparse-keymap)))
685 (define-key map [mode-line down-mouse-1] vc-menu-entry)
686 map))
688 (defun vc-mode-line (file &optional backend)
689 "Set `vc-mode' to display type of version control for FILE.
690 The value is set in the current buffer, which should be the buffer
691 visiting FILE.
692 If BACKEND is passed use it as the VC backend when computing the result."
693 (interactive (list buffer-file-name))
694 (setq backend (or backend (vc-backend file)))
695 (if (not backend)
696 (setq vc-mode nil)
697 (let* ((ml-string (vc-call-backend backend 'mode-line-string file))
698 (ml-echo (get-text-property 0 'help-echo ml-string)))
699 (setq vc-mode
700 (concat
702 (if (null vc-display-status)
703 (symbol-name backend)
704 (propertize
705 ml-string
706 'mouse-face 'mode-line-highlight
707 'help-echo
708 (concat (or ml-echo
709 (format "File under the %s version control system"
710 backend))
711 "\nmouse-1: Version Control menu")
712 'local-map vc-mode-line-map)))))
713 ;; If the user is root, and the file is not owner-writable,
714 ;; then pretend that we can't write it
715 ;; even though we can (because root can write anything).
716 ;; This way, even root cannot modify a file that isn't locked.
717 (and (equal file buffer-file-name)
718 (not buffer-read-only)
719 (zerop (user-real-uid))
720 (zerop (logand (file-modes buffer-file-name) 128))
721 (setq buffer-read-only t)))
722 (force-mode-line-update)
723 backend)
725 (defun vc-default-mode-line-string (backend file)
726 "Return a string for `vc-mode-line' to put in the mode line for FILE.
727 Format:
729 \"BACKEND-REV\" if the file is up-to-date
730 \"BACKEND:REV\" if the file is edited (or locked by the calling user)
731 \"BACKEND:LOCKER:REV\" if the file is locked by somebody else
732 \"BACKEND@REV\" if the file was locally added
733 \"BACKEND!REV\" if the file contains conflicts or was removed
734 \"BACKEND?REV\" if the file is under VC, but is missing
736 This function assumes that the file is registered."
737 (let* ((backend-name (symbol-name backend))
738 (state (vc-state file backend))
739 (state-echo nil)
740 (face nil)
741 (rev (vc-working-revision file backend)))
742 (propertize
743 (cond ((or (eq state 'up-to-date)
744 (eq state 'needs-update))
745 (setq state-echo "Up to date file")
746 (setq face 'vc-up-to-date-state)
747 (concat backend-name "-" rev))
748 ((stringp state)
749 (setq state-echo (concat "File locked by" state))
750 (setq face 'vc-locked-state)
751 (concat backend-name ":" state ":" rev))
752 ((eq state 'added)
753 (setq state-echo "Locally added file")
754 (setq face 'vc-locally-added-state)
755 (concat backend-name "@" rev))
756 ((eq state 'conflict)
757 (setq state-echo "File contains conflicts after the last merge")
758 (setq face 'vc-conflict-state)
759 (concat backend-name "!" rev))
760 ((eq state 'removed)
761 (setq state-echo "File removed from the VC system")
762 (setq face 'vc-removed-state)
763 (concat backend-name "!" rev))
764 ((eq state 'missing)
765 (setq state-echo "File tracked by the VC system, but missing from the file system")
766 (setq face 'vc-missing-state)
767 (concat backend-name "?" rev))
769 ;; Not just for the 'edited state, but also a fallback
770 ;; for all other states. Think about different symbols
771 ;; for 'needs-update and 'needs-merge.
772 (setq state-echo "Locally modified file")
773 (setq face 'vc-edited-state)
774 (concat backend-name ":" rev)))
775 'face face
776 'help-echo (concat state-echo " under the " backend-name
777 " version control system"))))
779 (defun vc-follow-link ()
780 "If current buffer visits a symbolic link, visit the real file.
781 If the real file is already visited in another buffer, make that buffer
782 current, and kill the buffer that visits the link."
783 (let* ((true-buffer (find-buffer-visiting buffer-file-truename))
784 (this-buffer (current-buffer)))
785 (if (eq true-buffer this-buffer)
786 (let ((truename buffer-file-truename))
787 (kill-buffer this-buffer)
788 ;; In principle, we could do something like set-visited-file-name.
789 ;; However, it can't be exactly the same as set-visited-file-name.
790 ;; I'm not going to work out the details right now. -- rms.
791 (set-buffer (find-file-noselect truename)))
792 (set-buffer true-buffer)
793 (kill-buffer this-buffer))))
795 (defun vc-default-find-file-hook (_backend)
796 nil)
798 (defun vc-refresh-state ()
799 "Refresh the VC state of the current buffer's file.
801 This command is more thorough than `vc-state-refresh', in that it
802 also supports switching a back-end or removing the file from VC.
803 In the latter case, VC mode is deactivated for this buffer."
804 (interactive)
805 ;; Recompute whether file is version controlled,
806 ;; if user has killed the buffer and revisited.
807 (when vc-mode
808 (setq vc-mode nil))
809 (when buffer-file-name
810 (vc-file-clearprops buffer-file-name)
811 ;; FIXME: Why use a hook? Why pass it buffer-file-name?
812 (add-hook 'vc-mode-line-hook 'vc-mode-line nil t)
813 (let (backend)
814 (cond
815 ((setq backend (with-demoted-errors (vc-backend buffer-file-name)))
816 ;; Let the backend setup any buffer-local things he needs.
817 (vc-call-backend backend 'find-file-hook)
818 ;; Compute the state and put it in the mode line.
819 (vc-mode-line buffer-file-name backend)
820 (unless vc-make-backup-files
821 ;; Use this variable, not make-backup-files,
822 ;; because this is for things that depend on the file name.
823 (set (make-local-variable 'backup-inhibited) t)))
824 ((let* ((truename (and buffer-file-truename
825 (expand-file-name buffer-file-truename)))
826 (link-type (and truename
827 (not (equal buffer-file-name truename))
828 (vc-backend truename))))
829 (cond ((not link-type) nil) ;Nothing to do.
830 ((eq vc-follow-symlinks nil)
831 (message
832 "Warning: symbolic link to %s-controlled source file" link-type))
833 ((or (not (eq vc-follow-symlinks 'ask))
834 ;; Assume we cannot ask, default to yes.
835 noninteractive
836 ;; Copied from server-start. Seems like there should
837 ;; be a better way to ask "can we get user input?"...
838 (and (daemonp)
839 (null (cdr (frame-list)))
840 (eq (selected-frame) terminal-frame))
841 ;; If we already visited this file by following
842 ;; the link, don't ask again if we try to visit
843 ;; it again. GUD does that, and repeated questions
844 ;; are painful.
845 (get-file-buffer
846 (abbreviate-file-name
847 (file-chase-links buffer-file-name))))
849 (vc-follow-link)
850 (message "Followed link to %s" buffer-file-name)
851 (vc-refresh-state))
853 (if (yes-or-no-p (format
854 "Symbolic link to %s-controlled source file; follow link? " link-type))
855 (progn (vc-follow-link)
856 (message "Followed link to %s" buffer-file-name)
857 (vc-refresh-state))
858 (message
859 "Warning: editing through the link bypasses version control")
860 )))))))))
862 (add-hook 'find-file-hook #'vc-refresh-state)
863 (define-obsolete-function-alias 'vc-find-file-hook 'vc-refresh-state "25.1")
865 (defun vc-kill-buffer-hook ()
866 "Discard VC info about a file when we kill its buffer."
867 (when buffer-file-name (vc-file-clearprops buffer-file-name)))
869 (add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
871 ;; Now arrange for (autoloaded) bindings of the main package.
872 ;; Bindings for this have to go in the global map, as we'll often
873 ;; want to call them from random buffers.
875 ;; Autoloading works fine, but it prevents shortcuts from appearing
876 ;; in the menu because they don't exist yet when the menu is built.
877 ;; (autoload 'vc-prefix-map "vc" nil nil 'keymap)
878 (defvar vc-prefix-map
879 (let ((map (make-sparse-keymap)))
880 (define-key map "a" 'vc-update-change-log)
881 (define-key map "b" 'vc-switch-backend)
882 (define-key map "d" 'vc-dir)
883 (define-key map "g" 'vc-annotate)
884 (define-key map "G" 'vc-ignore)
885 (define-key map "h" 'vc-region-history)
886 (define-key map "i" 'vc-register)
887 (define-key map "l" 'vc-print-log)
888 (define-key map "L" 'vc-print-root-log)
889 (define-key map "I" 'vc-log-incoming)
890 (define-key map "O" 'vc-log-outgoing)
891 (define-key map "m" 'vc-merge)
892 (define-key map "r" 'vc-retrieve-tag)
893 (define-key map "s" 'vc-create-tag)
894 (define-key map "u" 'vc-revert)
895 (define-key map "v" 'vc-next-action)
896 (define-key map "+" 'vc-update)
897 ;; I'd prefer some kind of symmetry with vc-update:
898 (define-key map "P" 'vc-push)
899 (define-key map "=" 'vc-diff)
900 (define-key map "D" 'vc-root-diff)
901 (define-key map "~" 'vc-revision-other-window)
902 (define-key map "x" 'vc-delete-file)
903 map))
904 (fset 'vc-prefix-map vc-prefix-map)
905 (define-key ctl-x-map "v" 'vc-prefix-map)
907 (defvar vc-menu-map
908 (let ((map (make-sparse-keymap "Version Control")))
909 ;;(define-key map [show-files]
910 ;; '("Show Files under VC" . (vc-directory t)))
911 (bindings--define-key map [vc-retrieve-tag]
912 '(menu-item "Retrieve Tag" vc-retrieve-tag
913 :help "Retrieve tagged version or branch"))
914 (bindings--define-key map [vc-create-tag]
915 '(menu-item "Create Tag" vc-create-tag
916 :help "Create version tag"))
917 (bindings--define-key map [separator1] menu-bar-separator)
918 (bindings--define-key map [vc-annotate]
919 '(menu-item "Annotate" vc-annotate
920 :help "Display the edit history of the current file using colors"))
921 (bindings--define-key map [vc-rename-file]
922 '(menu-item "Rename File" vc-rename-file
923 :help "Rename file"))
924 (bindings--define-key map [vc-revision-other-window]
925 '(menu-item "Show Other Version" vc-revision-other-window
926 :help "Visit another version of the current file in another window"))
927 (bindings--define-key map [vc-diff]
928 '(menu-item "Compare with Base Version" vc-diff
929 :help "Compare file set with the base version"))
930 (bindings--define-key map [vc-root-diff]
931 '(menu-item "Compare Tree with Base Version" vc-root-diff
932 :help "Compare current tree with the base version"))
933 (bindings--define-key map [vc-update-change-log]
934 '(menu-item "Update ChangeLog" vc-update-change-log
935 :help "Find change log file and add entries from recent version control logs"))
936 (bindings--define-key map [vc-log-out]
937 '(menu-item "Show Outgoing Log" vc-log-outgoing
938 :help "Show a log of changes that will be sent with a push operation"))
939 (bindings--define-key map [vc-log-in]
940 '(menu-item "Show Incoming Log" vc-log-incoming
941 :help "Show a log of changes that will be received with a pull operation"))
942 (bindings--define-key map [vc-print-log]
943 '(menu-item "Show History" vc-print-log
944 :help "List the change log of the current file set in a window"))
945 (bindings--define-key map [vc-print-root-log]
946 '(menu-item "Show Top of the Tree History " vc-print-root-log
947 :help "List the change log for the current tree in a window"))
948 (bindings--define-key map [separator2] menu-bar-separator)
949 (bindings--define-key map [vc-insert-header]
950 '(menu-item "Insert Header" vc-insert-headers
951 :help "Insert headers into a file for use with a version control system.
953 (bindings--define-key map [vc-revert]
954 '(menu-item "Revert to Base Version" vc-revert
955 :help "Revert working copies of the selected file set to their repository contents"))
956 ;; TODO Only :enable if (vc-find-backend-function backend 'push)
957 (bindings--define-key map [vc-push]
958 '(menu-item "Push Changes" vc-push
959 :help "Push the current branch's changes"))
960 (bindings--define-key map [vc-update]
961 '(menu-item "Update to Latest Version" vc-update
962 :help "Update the current fileset's files to their tip revisions"))
963 (bindings--define-key map [vc-next-action]
964 '(menu-item "Check In/Out" vc-next-action
965 :help "Do the next logical version control operation on the current fileset"))
966 (bindings--define-key map [vc-register]
967 '(menu-item "Register" vc-register
968 :help "Register file set into a version control system"))
969 (bindings--define-key map [vc-ignore]
970 '(menu-item "Ignore File..." vc-ignore
971 :help "Ignore a file under current version control system"))
972 (bindings--define-key map [vc-dir]
973 '(menu-item "VC Dir" vc-dir
974 :help "Show the VC status of files in a directory"))
975 map))
977 (defalias 'vc-menu-map vc-menu-map)
979 (declare-function vc-responsible-backend "vc" (file))
981 (defun vc-menu-map-filter (orig-binding)
982 (if (and (symbolp orig-binding) (fboundp orig-binding))
983 (setq orig-binding (indirect-function orig-binding)))
984 (let ((ext-binding
985 (when vc-mode
986 (vc-call-backend
987 (if buffer-file-name
988 (vc-backend buffer-file-name)
989 (vc-responsible-backend default-directory))
990 'extra-menu))))
991 ;; Give the VC backend a chance to add menu entries
992 ;; specific for that backend.
993 (if (null ext-binding)
994 orig-binding
995 (append orig-binding
996 '((ext-menu-separator "--"))
997 ext-binding))))
999 (defun vc-default-extra-menu (_backend)
1000 nil)
1002 (provide 'vc-hooks)
1004 ;;; vc-hooks.el ends here