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