lisp/vc-hooks.el

   1 ;;; vc-hooks.el --- resident support for version-control
   2
   3 ;; Copyright (C) 1992,93,94,95,96,98,99,2000  Free Software Foundation, Inc.
   4
   5 ;; Author:     FSF (see vc.el for full credits)
   6 ;; Maintainer: Andre Spiegel <spiegel@gnu.org>
   7
   8 ;; $Id: vc-hooks.el,v 1.146 2002/10/17 15:46:06 lektu Exp $
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; This is the always-loaded portion of VC.  It takes care of
  30 ;; VC-related activities that are done when you visit a file, so that
  31 ;; vc.el itself is loaded only when you use a VC command.  See the
  32 ;; commentary of vc.el.
  33
  34 ;;; Code:
  35
  36 (eval-when-compile
  37   (require 'cl))
  38
  39 ;; Customization Variables (the rest is in vc.el)
  40
  41 (defvar vc-ignore-vc-files nil)
  42 (make-obsolete-variable 'vc-ignore-vc-files 'vc-handled-backends)
  43 (defvar vc-master-templates ())
  44 (make-obsolete-variable 'vc-master-templates 'vc-BACKEND-master-templates)
  45 (defvar vc-header-alist ())
  46 (make-obsolete-variable 'vc-header-alist 'vc-BACKEND-header)
  47
  48 (defcustom vc-handled-backends '(RCS CVS SCCS)
  49   "*List of version control backends for which VC will be used.
  50 Entries in this list will be tried in order to determine whether a
  51 file is under that sort of version control.
  52 Removing an entry from the list prevents VC from being activated
  53 when visiting a file managed by that backend.
  54 An empty list disables VC altogether."
  55   :type '(repeat symbol)
  56   :version "21.1"
  57   :group 'vc)
  58
  59 (defcustom vc-path
  60   (if (file-directory-p "/usr/sccs")
  61       '("/usr/sccs")
  62     nil)
  63   "*List of extra directories to search for version control commands."
  64   :type '(repeat directory)
  65   :group 'vc)
  66
  67 (defcustom vc-make-backup-files nil
  68   "*If non-nil, backups of registered files are made as with other files.
  69 If nil (the default), files covered by version control don't get backups."
  70   :type 'boolean
  71   :group 'vc)
  72
  73 (defcustom vc-follow-symlinks 'ask
  74   "*What to do if visiting a symbolic link to a file under version control.
  75 Editing such a file through the link bypasses the version control system,
  76 which is dangerous and probably not what you want.
  77
  78 If this variable is t, VC follows the link and visits the real file,
  79 telling you about it in the echo area.  If it is `ask', VC asks for
  80 confirmation whether it should follow the link.  If nil, the link is
  81 visited and a warning displayed."
  82   :type '(choice (const :tag "Ask for confirmation" ask)
  83                  (const :tag "Visit link and warn" nil)
  84                  (const :tag "Follow link" t))
  85   :group 'vc)
  86
  87 (defcustom vc-display-status t
  88   "*If non-nil, display revision number and lock status in modeline.
  89 Otherwise, not displayed."
  90   :type 'boolean
  91   :group 'vc)
  92
  93
  94 (defcustom vc-consult-headers t
  95   "*If non-nil, identify work files by searching for version headers."
  96   :type 'boolean
  97   :group 'vc)
  98
  99 (defcustom vc-keep-workfiles t
 100   "*If non-nil, don't delete working files after registering changes.
 101 If the back-end is CVS, workfiles are always kept, regardless of the
 102 value of this flag."
 103   :type 'boolean
 104   :group 'vc)
 105
 106 (defcustom vc-mistrust-permissions nil
 107   "*If non-nil, don't assume permissions/ownership track version-control status.
 108 If nil, do rely on the permissions.
 109 See also variable `vc-consult-headers'."
 110   :type 'boolean
 111   :group 'vc)
 112
 113 (defun vc-mistrust-permissions (file)
 114   "Internal access function to variable `vc-mistrust-permissions' for FILE."
 115   (or (eq vc-mistrust-permissions 't)
 116       (and vc-mistrust-permissions
 117            (funcall vc-mistrust-permissions
 118                     (vc-backend-subdirectory-name file)))))
 119
 120 ;;; This is handled specially now.
 121 ;; Tell Emacs about this new kind of minor mode
 122 ;; (add-to-list 'minor-mode-alist '(vc-mode vc-mode))
 123
 124 (make-variable-buffer-local 'vc-mode)
 125 (put 'vc-mode 'permanent-local t)
 126
 127 (defun vc-mode (&optional arg)
 128   ;; Dummy function for C-h m
 129   "Version Control minor mode.
 130 This minor mode is automatically activated whenever you visit a file under
 131 control of one of the revision control systems in `vc-handled-backends'.
 132 VC commands are globally reachable under the prefix `\\[vc-prefix-map]':
 133 \\{vc-prefix-map}")
 134
 135 (defmacro vc-error-occurred (&rest body)
 136   `(condition-case nil (progn ,@body nil) (error t)))
 137
 138 ;; We need a notion of per-file properties because the version
 139 ;; control state of a file is expensive to derive --- we compute
 140 ;; them when the file is initially found, keep them up to date
 141 ;; during any subsequent VC operations, and forget them when
 142 ;; the buffer is killed.
 143
 144 (defvar vc-file-prop-obarray (make-vector 17 0)
 145   "Obarray for per-file properties.")
 146
 147 (defvar vc-touched-properties nil)
 148
 149 (defun vc-file-setprop (file property value)
 150   "Set per-file VC PROPERTY for FILE to VALUE."
 151   (if (and vc-touched-properties
 152            (not (memq property vc-touched-properties)))
 153       (setq vc-touched-properties (append (list property)
 154                                           vc-touched-properties)))
 155   (put (intern file vc-file-prop-obarray) property value))
 156
 157 (defun vc-file-getprop (file property)
 158   "Get per-file VC PROPERTY for FILE."
 159   (get (intern file vc-file-prop-obarray) property))
 160
 161 (defun vc-file-clearprops (file)
 162   "Clear all VC properties of FILE."
 163   (setplist (intern file vc-file-prop-obarray) nil))
 164
 165 \f
 166 ;; We keep properties on each symbol naming a backend as follows:
 167 ;;  * `vc-functions': an alist mapping vc-FUNCTION to vc-BACKEND-FUNCTION.
 168
 169 (defun vc-make-backend-sym (backend sym)
 170   "Return BACKEND-specific version of VC symbol SYM."
 171   (intern (concat "vc-" (downcase (symbol-name backend))
 172                   "-" (symbol-name sym))))
 173
 174 (defun vc-find-backend-function (backend fun)
 175   "Return BACKEND-specific implementation of FUN.
 176 If there is no such implementation, return the default implementation;
 177 if that doesn't exist either, return nil."
 178   (let ((f (vc-make-backend-sym backend fun)))
 179     (if (fboundp f) f
 180       ;; Load vc-BACKEND.el if needed.
 181       (require (intern (concat "vc-" (downcase (symbol-name backend)))))
 182       (if (fboundp f) f
 183         (let ((def (vc-make-backend-sym 'default fun)))
 184           (if (fboundp def) (cons def backend) nil))))))
 185
 186 (defun vc-call-backend (backend function-name &rest args)
 187   "Call for BACKEND the implementation of FUNCTION-NAME with the given ARGS.
 188 Calls
 189
 190     (apply 'vc-BACKEND-FUN ARGS)
 191
 192 if vc-BACKEND-FUN exists (after trying to find it in vc-BACKEND.el)
 193 and else calls
 194
 195     (apply 'vc-default-FUN BACKEND ARGS)
 196
 197 It is usually called via the `vc-call' macro."
 198   (let ((f (cdr (assoc function-name (get backend 'vc-functions)))))
 199     (unless f
 200       (setq f (vc-find-backend-function backend function-name))
 201       (put backend 'vc-functions (cons (cons function-name f)
 202                                        (get backend 'vc-functions))))
 203     (if (consp f)
 204         (apply (car f) (cdr f) args)
 205       (apply f args))))
 206
 207 (defmacro vc-call (fun file &rest args)
 208   ;; BEWARE!! `file' is evaluated twice!!
 209   `(vc-call-backend (vc-backend ,file) ',fun ,file ,@args))
 210
 211 \f
 212 (defsubst vc-parse-buffer (pattern i)
 213   "Find PATTERN in the current buffer and return its Ith submatch."
 214   (goto-char (point-min))
 215   (if (re-search-forward pattern nil t)
 216       (match-string i)))
 217
 218 (defun vc-insert-file (file &optional limit blocksize)
 219   "Insert the contents of FILE into the current buffer.
 220
 221 Optional argument LIMIT is a regexp.  If present, the file is inserted
 222 in chunks of size BLOCKSIZE (default 8 kByte), until the first
 223 occurrence of LIMIT is found.  Anything from the start of that occurrence
 224 to the end of the buffer is then deleted.  The function returns
 225 non-nil if FILE exists and its contents were successfully inserted."
 226   (erase-buffer)
 227   (when (file-exists-p file)
 228     (if (not limit)
 229         (insert-file-contents file)
 230       (if (not blocksize) (setq blocksize 8192))
 231       (let ((filepos 0))
 232         (while
 233             (and (< 0 (cadr (insert-file-contents
 234                              file nil filepos (incf filepos blocksize))))
 235                  (progn (beginning-of-line)
 236                         (let ((pos (re-search-forward limit nil 'move)))
 237                           (if pos (delete-region (match-beginning 0)
 238                                                  (point-max)))
 239                           (not pos)))))))
 240     (set-buffer-modified-p nil)
 241     t))
 242
 243 ;; Access functions to file properties
 244 ;; (Properties should be _set_ using vc-file-setprop, but
 245 ;; _retrieved_ only through these functions, which decide
 246 ;; if the property is already known or not. A property should
 247 ;; only be retrieved by vc-file-getprop if there is no
 248 ;; access function.)
 249
 250 ;; properties indicating the backend being used for FILE
 251
 252 (defun vc-registered (file)
 253   "Return non-nil if FILE is registered in a version control system.
 254
 255 This function performs the check each time it is called.  To rely
 256 on the result of a previous call, use `vc-backend' instead.  If the
 257 file was previously registered under a certain backend, then that
 258 backend is tried first."
 259   (let (handler)
 260     (if (boundp 'file-name-handler-alist)
 261         (setq handler (find-file-name-handler file 'vc-registered)))
 262     (if handler
 263         ;; handler should set vc-backend and return t if registered
 264         (funcall handler 'vc-registered file)
 265       ;; There is no file name handler.
 266       ;; Try vc-BACKEND-registered for each handled BACKEND.
 267       (catch 'found
 268         (let ((backend (vc-file-getprop file 'vc-backend)))
 269           (mapcar
 270            (lambda (b)
 271              (and (vc-call-backend b 'registered file)
 272                   (vc-file-setprop file 'vc-backend b)
 273                   (throw 'found t)))
 274            (if (or (not backend) (eq backend 'none))
 275                vc-handled-backends
 276              (cons backend vc-handled-backends))))
 277         ;; File is not registered.
 278         (vc-file-setprop file 'vc-backend 'none)
 279         nil))))
 280
 281 (defun vc-backend (file)
 282   "Return the version control type of FILE, nil if it is not registered."
 283   ;; `file' can be nil in several places (typically due to the use of
 284   ;; code like (vc-backend (buffer-file-name))).
 285   (when (stringp file)
 286     (let ((property (vc-file-getprop file 'vc-backend)))
 287       ;; Note that internally, Emacs remembers unregistered
 288       ;; files by setting the property to `none'.
 289       (cond ((eq property 'none) nil)
 290             (property)
 291             ;; vc-registered sets the vc-backend property
 292             (t (if (vc-registered file)
 293                    (vc-file-getprop file 'vc-backend)
 294                  nil))))))
 295
 296 (defun vc-backend-subdirectory-name (file)
 297   "Return where the master and lock FILEs for the current directory are kept."
 298   (symbol-name (vc-backend file)))
 299
 300 (defun vc-name (file)
 301   "Return the master name of FILE.
 302 If the file is not registered, or the master name is not known, return nil."
 303   ;; TODO: This should ultimately become obsolete, at least up here
 304   ;; in vc-hooks.
 305   (or (vc-file-getprop file 'vc-name)
 306       ;; force computation of the property by calling
 307       ;; vc-BACKEND-registered explicitly
 308       (if (and (vc-backend file)
 309                (vc-call-backend (vc-backend file) 'registered file))
 310           (vc-file-getprop file 'vc-name))))
 311
 312 (defun vc-checkout-model (file)
 313   "Indicate how FILE is checked out.
 314
 315 If FILE is not registered, this function always returns nil.
 316 For registered files, the possible values are:
 317
 318   'implicit   FILE is always writeable, and checked out `implicitly'
 319               when the user saves the first changes to the file.
 320
 321   'locking    FILE is read-only if up-to-date; user must type
 322               \\[vc-next-action] before editing.  Strict locking
 323               is assumed.
 324
 325   'announce   FILE is read-only if up-to-date; user must type
 326               \\[vc-next-action] before editing.  But other users
 327               may be editing at the same time."
 328   (or (vc-file-getprop file 'vc-checkout-model)
 329       (if (vc-backend file)
 330           (vc-file-setprop file 'vc-checkout-model
 331                            (vc-call checkout-model file)))))
 332
 333 (defun vc-user-login-name (&optional uid)
 334   "Return the name under which the user is logged in, as a string.
 335 \(With optional argument UID, return the name of that user.)
 336 This function does the same as function `user-login-name', but unlike
 337 that, it never returns nil.  If a UID cannot be resolved, that
 338 UID is returned as a string."
 339   (or (user-login-name uid)
 340       (number-to-string (or uid (user-uid)))))
 341
 342 (defun vc-state (file)
 343   "Return the version control state of FILE.
 344
 345 If FILE is not registered, this function always returns nil.
 346 For registered files, the value returned is one of:
 347
 348   'up-to-date        The working file is unmodified with respect to the
 349                      latest version on the current branch, and not locked.
 350
 351   'edited            The working file has been edited by the user.  If
 352                      locking is used for the file, this state means that
 353                      the current version is locked by the calling user.
 354
 355   USER               The current version of the working file is locked by
 356                      some other USER (a string).
 357
 358   'needs-patch       The file has not been edited by the user, but there is
 359                      a more recent version on the current branch stored
 360                      in the master file.
 361
 362   'needs-merge       The file has been edited by the user, and there is also
 363                      a more recent version on the current branch stored in
 364                      the master file.  This state can only occur if locking
 365                      is not used for the file.
 366
 367   'unlocked-changes  The current version of the working file is not locked,
 368                      but the working file has been changed with respect
 369                      to that version.  This state can only occur for files
 370                      with locking; it represents an erroneous condition that
 371                      should be resolved by the user (vc-next-action will
 372                      prompt the user to do it)."
 373   (or (vc-file-getprop file 'vc-state)
 374       (if (vc-backend file)
 375           (vc-file-setprop file 'vc-state
 376                            (vc-call state-heuristic file)))))
 377
 378 (defsubst vc-up-to-date-p (file)
 379   "Convenience function that checks whether `vc-state' of FILE is `up-to-date'."
 380   (eq (vc-state file) 'up-to-date))
 381
 382 (defun vc-default-state-heuristic (backend file)
 383   "Default implementation of vc-state-heuristic.
 384 It simply calls the real state computation function `vc-BACKEND-state'
 385 and does not employ any heuristic at all."
 386    (vc-call-backend backend 'state file))
 387
 388 (defun vc-workfile-unchanged-p (file)
 389   "Return non-nil if FILE has not changed since the last checkout."
 390   (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
 391         (lastmod (nth 5 (file-attributes file))))
 392     (if checkout-time
 393         (equal checkout-time lastmod)
 394       (let ((unchanged (vc-call workfile-unchanged-p file)))
 395         (vc-file-setprop file 'vc-checkout-time (if unchanged lastmod 0))
 396         unchanged))))
 397
 398 (defun vc-default-workfile-unchanged-p (backend file)
 399   "Check if FILE is unchanged by diffing against the master version.
 400 Return non-nil if FILE is unchanged."
 401   (zerop (vc-call diff file (vc-workfile-version file))))
 402
 403 (defun vc-workfile-version (file)
 404   "Return the version level of the current workfile FILE.
 405 If FILE is not registered, this function always returns nil."
 406   (or (vc-file-getprop file 'vc-workfile-version)
 407       (if (vc-backend file)
 408           (vc-file-setprop file 'vc-workfile-version
 409                            (vc-call workfile-version file)))))
 410
 411 (defun vc-default-registered (backend file)
 412   "Check if FILE is registered in BACKEND using vc-BACKEND-master-templates."
 413   (let ((sym (vc-make-backend-sym backend 'master-templates)))
 414     (unless (get backend 'vc-templates-grabbed)
 415       (put backend 'vc-templates-grabbed t)
 416       (set sym (append (delq nil
 417                              (mapcar
 418                               (lambda (template)
 419                                 (and (consp template)
 420                                      (eq (cdr template) backend)
 421                                      (car template)))
 422                               vc-master-templates))
 423                        (symbol-value sym))))
 424     (let ((result (vc-check-master-templates file (symbol-value sym))))
 425       (if (stringp result)
 426           (vc-file-setprop file 'vc-name result)
 427         nil))))                         ; Not registered
 428
 429 (defun vc-possible-master (s dirname basename)
 430   (cond
 431    ((stringp s) (format s dirname basename))
 432    ((functionp s)
 433     ;; The template is a function to invoke.  If the
 434     ;; function returns non-nil, that means it has found a
 435     ;; master.  For backward compatibility, we also handle
 436     ;; the case that the function throws a 'found atom
 437     ;; and a pair (cons MASTER-FILE BACKEND).
 438     (let ((result (catch 'found (funcall s dirname basename))))
 439       (if (consp result) (car result) result)))))
 440
 441 (defun vc-check-master-templates (file templates)
 442   "Return non-nil if there is a master corresponding to FILE.
 443
 444 TEMPLATES is a list of strings or functions.  If an element is a
 445 string, it must be a control string as required by `format', with two
 446 string placeholders, such as \"%sRCS/%s,v\".  The directory part of
 447 FILE is substituted for the first placeholder, the basename of FILE
 448 for the second.  If a file with the resulting name exists, it is taken
 449 as the master of FILE, and returned.
 450
 451 If an element of TEMPLATES is a function, it is called with the
 452 directory part and the basename of FILE as arguments.  It should
 453 return non-nil if it finds a master; that value is then returned by
 454 this function."
 455   (let ((dirname (or (file-name-directory file) ""))
 456         (basename (file-name-nondirectory file)))
 457     (catch 'found
 458       (mapcar
 459        (lambda (s)
 460          (let ((trial (vc-possible-master s dirname basename)))
 461            (if (and trial (file-exists-p trial)
 462                     ;; Make sure the file we found with name
 463                     ;; TRIAL is not the source file itself.
 464                     ;; That can happen with RCS-style names if
 465                     ;; the file name is truncated (e.g. to 14
 466                     ;; chars).  See if either directory or
 467                     ;; attributes differ.
 468                     (or (not (string= dirname
 469                                       (file-name-directory trial)))
 470                         (not (equal (file-attributes file)
 471                                     (file-attributes trial)))))
 472                (throw 'found trial))))
 473        templates))))
 474
 475 (defun vc-toggle-read-only (&optional verbose)
 476   "Change read-only status of current buffer, perhaps via version control.
 477
 478 If the buffer is visiting a file registered with version control,
 479 then check the file in or out.  Otherwise, just change the read-only flag
 480 of the buffer.
 481 With prefix argument, ask for version number to check in or check out.
 482 Check-out of a specified version number does not lock the file;
 483 to do that, use this command a second time with no argument.
 484
 485 If you bind this function to \\[toggle-read-only], then Emacs checks files
 486 in or out whenever you toggle the read-only flag."
 487   (interactive "P")
 488   (if (or (and (boundp 'vc-dired-mode) vc-dired-mode)
 489           ;; use boundp because vc.el might not be loaded
 490           (vc-backend (buffer-file-name)))
 491       (vc-next-action verbose)
 492     (toggle-read-only)))
 493
 494 (defun vc-default-make-version-backups-p (backend file)
 495   "Return non-nil if unmodified versions should be backed up locally.
 496 The default is to switch off this feature."
 497   nil)
 498
 499 (defun vc-version-backup-file-name (file &optional rev manual regexp)
 500   "Return a backup file name for REV or the current version of FILE.
 501 If MANUAL is non-nil it means that a name for backups created by
 502 the user should be returned; if REGEXP is non-nil that means to return
 503 a regexp for matching all such backup files, regardless of the version."
 504   (if regexp
 505       (concat (regexp-quote (file-name-nondirectory file))
 506               "\\.~[0-9.]+" (unless manual "\\.") "~")
 507     (expand-file-name (concat (file-name-nondirectory file)
 508                               ".~" (or rev (vc-workfile-version file))
 509                               (unless manual ".") "~")
 510                       (file-name-directory file))))
 511
 512 (defun vc-delete-automatic-version-backups (file)
 513   "Delete all existing automatic version backups for FILE."
 514   (condition-case nil
 515       (mapcar
 516        'delete-file
 517        (directory-files (or (file-name-directory file) default-directory) t
 518                         (vc-version-backup-file-name file nil nil t)))
 519     ;; Don't fail when the directory doesn't exist.
 520     (file-error nil)))
 521
 522 (defun vc-make-version-backup (file)
 523   "Make a backup copy of FILE, which is assumed in sync with the repository.
 524 Before doing that, check if there are any old backups and get rid of them."
 525   (unless (and (fboundp 'msdos-long-file-names)
 526                (not (msdos-long-file-names)))
 527     (vc-delete-automatic-version-backups file)
 528     (copy-file file (vc-version-backup-file-name file)
 529                nil 'keep-date)))
 530
 531 (defun vc-before-save ()
 532   "Function to be called by `basic-save-buffer' (in files.el)."
 533   ;; If the file on disk is still in sync with the repository,
 534   ;; and version backups should be made, copy the file to
 535   ;; another name.  This enables local diffs and local reverting.
 536   (let ((file (buffer-file-name)))
 537     (and (vc-backend file)
 538          (vc-up-to-date-p file)
 539          (eq (vc-checkout-model file) 'implicit)
 540          (vc-call make-version-backups-p file)
 541          (vc-make-version-backup file))))
 542
 543 (defun vc-after-save ()
 544   "Function to be called by `basic-save-buffer' (in files.el)."
 545   ;; If the file in the current buffer is under version control,
 546   ;; up-to-date, and locking is not used for the file, set
 547   ;; the state to 'edited and redisplay the mode line.
 548   (let ((file (buffer-file-name)))
 549     (and (vc-backend file)
 550          (or (and (equal (vc-file-getprop file 'vc-checkout-time)
 551                          (nth 5 (file-attributes file)))
 552                   ;; File has been saved in the same second in which
 553                   ;; it was checked out.  Clear the checkout-time
 554                   ;; to avoid confusion.
 555                   (vc-file-setprop file 'vc-checkout-time nil))
 556              t)
 557          (vc-up-to-date-p file)
 558          (eq (vc-checkout-model file) 'implicit)
 559          (vc-file-setprop file 'vc-state 'edited)
 560          (vc-mode-line file)
 561          (if (featurep 'vc)
 562              ;; If VC is not loaded, then there can't be
 563              ;; any VC Dired buffer to synchronize.
 564              (vc-dired-resynch-file file)))))
 565
 566 (defun vc-mode-line (file)
 567   "Set `vc-mode' to display type of version control for FILE.
 568 The value is set in the current buffer, which should be the buffer
 569 visiting FILE."
 570   (interactive (list buffer-file-name))
 571   (if (not (vc-backend file))
 572       (setq vc-mode nil)
 573     (setq vc-mode (concat " " (if vc-display-status
 574                                   (vc-call mode-line-string file)
 575                                 (symbol-name (vc-backend file)))))
 576     ;; If the file is locked by some other user, make
 577     ;; the buffer read-only.  Like this, even root
 578     ;; cannot modify a file that someone else has locked.
 579     (and (equal file (buffer-file-name))
 580          (stringp (vc-state file))
 581          (setq buffer-read-only t))
 582     ;; If the user is root, and the file is not owner-writable,
 583     ;; then pretend that we can't write it
 584     ;; even though we can (because root can write anything).
 585     ;; This way, even root cannot modify a file that isn't locked.
 586     (and (equal file (buffer-file-name))
 587          (not buffer-read-only)
 588          (zerop (user-real-uid))
 589          (zerop (logand (file-modes (buffer-file-name)) 128))
 590          (setq buffer-read-only t)))
 591   (force-mode-line-update)
 592   (vc-backend file))
 593
 594 (defun vc-default-mode-line-string (backend file)
 595   "Return string for placement in modeline by `vc-mode-line' for FILE.
 596 Format:
 597
 598   \"BACKEND-REV\"        if the file is up-to-date
 599   \"BACKEND:REV\"        if the file is edited (or locked by the calling user)
 600   \"BACKEND:LOCKER:REV\" if the file is locked by somebody else
 601
 602 This function assumes that the file is registered."
 603   (setq backend (symbol-name backend))
 604   (let ((state   (vc-state file))
 605         (rev     (vc-workfile-version file)))
 606     (cond ((or (eq state 'up-to-date)
 607                (eq state 'needs-patch))
 608            (concat backend "-" rev))
 609           ((stringp state)
 610            (concat backend ":" state ":" rev))
 611           (t
 612            ;; Not just for the 'edited state, but also a fallback
 613            ;; for all other states.  Think about different symbols
 614            ;; for 'needs-patch and 'needs-merge.
 615            (concat backend ":" rev)))))
 616
 617 (defun vc-follow-link ()
 618   "If current buffer visits a symbolic link, visit the real file.
 619 If the real file is already visited in another buffer, make that buffer
 620 current, and kill the buffer that visits the link."
 621   (let* ((truename (abbreviate-file-name (file-chase-links buffer-file-name)))
 622          (true-buffer (find-buffer-visiting truename))
 623          (this-buffer (current-buffer)))
 624     (if (eq true-buffer this-buffer)
 625         (progn
 626           (kill-buffer this-buffer)
 627           ;; In principle, we could do something like set-visited-file-name.
 628           ;; However, it can't be exactly the same as set-visited-file-name.
 629           ;; I'm not going to work out the details right now. -- rms.
 630           (set-buffer (find-file-noselect truename)))
 631       (set-buffer true-buffer)
 632       (kill-buffer this-buffer))))
 633
 634 (defun vc-find-file-hook ()
 635   "Function for `find-file-hooks' activating VC mode if appropriate."
 636   ;; Recompute whether file is version controlled,
 637   ;; if user has killed the buffer and revisited.
 638   (if vc-mode
 639       (setq vc-mode nil))
 640   (when buffer-file-name
 641     (vc-file-clearprops buffer-file-name)
 642     (cond
 643      ((vc-backend buffer-file-name)
 644       (vc-mode-line buffer-file-name)
 645       (cond ((not vc-make-backup-files)
 646              ;; Use this variable, not make-backup-files,
 647              ;; because this is for things that depend on the file name.
 648              (make-local-variable 'backup-inhibited)
 649              (setq backup-inhibited t))))
 650      ((let* ((link (file-symlink-p buffer-file-name))
 651              (link-type (and link (vc-backend (file-chase-links link)))))
 652         (if link-type
 653             (cond ((eq vc-follow-symlinks nil)
 654                    (message
 655         "Warning: symbolic link to %s-controlled source file" link-type))
 656                   ((or (not (eq vc-follow-symlinks 'ask))
 657                        ;; If we already visited this file by following
 658                        ;; the link, don't ask again if we try to visit
 659                        ;; it again.  GUD does that, and repeated questions
 660                        ;; are painful.
 661                        (get-file-buffer
 662                         (abbreviate-file-name
 663                          (file-chase-links buffer-file-name))))
 664
 665                    (vc-follow-link)
 666                    (message "Followed link to %s" buffer-file-name)
 667                    (vc-find-file-hook))
 668                   (t
 669                    (if (yes-or-no-p (format
 670         "Symbolic link to %s-controlled source file; follow link? " link-type))
 671                        (progn (vc-follow-link)
 672                               (message "Followed link to %s" buffer-file-name)
 673                               (vc-find-file-hook))
 674                      (message
 675         "Warning: editing through the link bypasses version control")
 676                      )))))))))
 677
 678 (add-hook 'find-file-hooks 'vc-find-file-hook)
 679
 680 ;; more hooks, this time for file-not-found
 681 (defun vc-file-not-found-hook ()
 682   "When file is not found, try to check it out from version control.
 683 Returns t if checkout was successful, nil otherwise.
 684 Used in `find-file-not-found-hooks'."
 685   ;; When a file does not exist, ignore cached info about it
 686   ;; from a previous visit.
 687   (vc-file-clearprops buffer-file-name)
 688   (if (and (vc-backend buffer-file-name)
 689            (yes-or-no-p
 690             (format "File %s was lost; check out from version control? "
 691                     (file-name-nondirectory buffer-file-name))))
 692     (save-excursion
 693       (require 'vc)
 694       (setq default-directory (file-name-directory buffer-file-name))
 695       (not (vc-error-occurred (vc-checkout buffer-file-name))))))
 696
 697 (add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook)
 698
 699 (defun vc-kill-buffer-hook ()
 700   "Discard VC info about a file when we kill its buffer."
 701   (if (buffer-file-name)
 702       (vc-file-clearprops (buffer-file-name))))
 703
 704 (add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
 705
 706 ;; Now arrange for (autoloaded) bindings of the main package.
 707 ;; Bindings for this have to go in the global map, as we'll often
 708 ;; want to call them from random buffers.
 709
 710 ;; Autoloading works fine, but it prevents shortcuts from appearing
 711 ;; in the menu because they don't exist yet when the menu is built.
 712 ;; (autoload 'vc-prefix-map "vc" nil nil 'keymap)
 713 (defvar vc-prefix-map
 714   (let ((map (make-sparse-keymap)))
 715     (define-key map "a" 'vc-update-change-log)
 716     (define-key map "b" 'vc-switch-backend)
 717     (define-key map "c" 'vc-cancel-version)
 718     (define-key map "d" 'vc-directory)
 719     (define-key map "g" 'vc-annotate)
 720     (define-key map "h" 'vc-insert-headers)
 721     (define-key map "i" 'vc-register)
 722     (define-key map "l" 'vc-print-log)
 723     (define-key map "m" 'vc-merge)
 724     (define-key map "r" 'vc-retrieve-snapshot)
 725     (define-key map "s" 'vc-create-snapshot)
 726     (define-key map "u" 'vc-revert-buffer)
 727     (define-key map "v" 'vc-next-action)
 728     (define-key map "=" 'vc-diff)
 729     (define-key map "~" 'vc-version-other-window)
 730     map))
 731 (fset 'vc-prefix-map vc-prefix-map)
 732 (define-key global-map "\C-xv" 'vc-prefix-map)
 733
 734 (if (not (boundp 'vc-menu-map))
 735     ;; Don't do the menu bindings if menu-bar.el wasn't loaded to defvar
 736     ;; vc-menu-map.
 737     ()
 738   ;;(define-key vc-menu-map [show-files]
 739   ;;  '("Show Files under VC" . (vc-directory t)))
 740   (define-key vc-menu-map [vc-retrieve-snapshot]
 741     '("Retrieve Snapshot" . vc-retrieve-snapshot))
 742   (define-key vc-menu-map [vc-create-snapshot]
 743     '("Create Snapshot" . vc-create-snapshot))
 744   (define-key vc-menu-map [vc-directory] '("VC Directory Listing" . vc-directory))
 745   (define-key vc-menu-map [separator1] '("----"))
 746   (define-key vc-menu-map [vc-annotate] '("Annotate" . vc-annotate))
 747   (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file))
 748   (define-key vc-menu-map [vc-version-other-window]
 749     '("Show Other Version" . vc-version-other-window))
 750   (define-key vc-menu-map [vc-diff] '("Compare with Base Version" . vc-diff))
 751   (define-key vc-menu-map [vc-update-change-log]
 752     '("Update ChangeLog" . vc-update-change-log))
 753   (define-key vc-menu-map [vc-print-log] '("Show History" . vc-print-log))
 754   (define-key vc-menu-map [separator2] '("----"))
 755   (define-key vc-menu-map [vc-insert-header]
 756     '("Insert Header" . vc-insert-headers))
 757   (define-key vc-menu-map [undo] '("Undo Last Check-In" . vc-cancel-version))
 758   (define-key vc-menu-map [vc-revert-buffer]
 759     '("Revert to Base Version" . vc-revert-buffer))
 760   (define-key vc-menu-map [vc-update]
 761     '("Update to Latest Version" . vc-update))
 762   (define-key vc-menu-map [vc-next-action] '("Check In/Out" . vc-next-action))
 763   (define-key vc-menu-map [vc-register] '("Register" . vc-register)))
 764
 765 ;; These are not correct and it's not currently clear how doing it
 766 ;; better (with more complicated expressions) might slow things down
 767 ;; on older systems.
 768
 769 ;;(put 'vc-rename-file 'menu-enable 'vc-mode)
 770 ;;(put 'vc-annotate 'menu-enable '(eq (vc-buffer-backend) 'CVS))
 771 ;;(put 'vc-version-other-window 'menu-enable 'vc-mode)
 772 ;;(put 'vc-diff 'menu-enable 'vc-mode)
 773 ;;(put 'vc-update-change-log 'menu-enable
 774 ;;     '(member (vc-buffer-backend) '(RCS CVS)))
 775 ;;(put 'vc-print-log 'menu-enable 'vc-mode)
 776 ;;(put 'vc-cancel-version 'menu-enable 'vc-mode)
 777 ;;(put 'vc-revert-buffer 'menu-enable 'vc-mode)
 778 ;;(put 'vc-insert-headers 'menu-enable 'vc-mode)
 779 ;;(put 'vc-next-action 'menu-enable 'vc-mode)
 780 ;;(put 'vc-register 'menu-enable '(and buffer-file-name (not vc-mode)))
 781
 782 (provide 'vc-hooks)
 783
 784 ;;; vc-hooks.el ends here