code.delx.au - gnu-emacs/blob - lisp/vc-hooks.el

   1 ;;; vc-hooks.el --- resident support for version-control
   2
   3 ;; Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
   6 ;; Modified by:
   7 ;;   Per Cederqvist <ceder@lysator.liu.se>
   8 ;;   Andre Spiegel <spiegel@berlin.informatik.uni-stuttgart.de>
   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
  24 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25
  26 ;;; Commentary:
  27
  28 ;; This is the always-loaded portion of VC.
  29 ;; It takes care VC-related activities that are done when you visit a file,
  30 ;; so that vc.el itself is loaded only when you use a VC command.
  31 ;; See the commentary of vc.el.
  32
  33 ;;; Code:
  34
  35 ;; Customization Variables (the rest is in vc.el)
  36
  37 (defvar vc-default-back-end nil
  38   "*Back-end actually used by this interface; may be SCCS or RCS.
  39 The value is only computed when needed to avoid an expensive search.")
  40
  41 (defvar vc-path
  42   (if (file-directory-p "/usr/sccs")
  43       '("/usr/sccs")
  44     nil)
  45   "*List of extra directories to search for version control commands.")
  46
  47 (defvar vc-master-templates
  48   '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS)
  49     ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS)
  50     vc-find-cvs-master)
  51   "*Where to look for version-control master files.
  52 The first pair corresponding to a given back end is used as a template
  53 when creating new masters.")
  54
  55 (defvar vc-make-backup-files nil
  56   "*If non-nil, backups of registered files are made as with other files.
  57 If nil (the default), files covered by version control don't get backups.")
  58
  59 (defvar vc-display-status t
  60   "*If non-nil, display revision number and lock status in modeline.
  61 Otherwise, not displayed.")
  62
  63 (defvar vc-consult-headers t
  64   "*Identify work files by searching for version headers.")
  65
  66 (defvar vc-mistrust-permissions nil
  67   "*Don't assume that permissions and ownership track version-control status.")
  68
  69 (defvar vc-keep-workfiles t
  70   "*If non-nil, don't delete working files after registering changes.
  71 If the back-end is CVS, workfiles are always kept, regardless of the
  72 value of this flag.")
  73
  74 ;; Tell Emacs about this new kind of minor mode
  75 (if (not (assoc 'vc-mode minor-mode-alist))
  76     (setq minor-mode-alist (cons '(vc-mode vc-mode)
  77                                  minor-mode-alist)))
  78
  79 (make-variable-buffer-local 'vc-mode)
  80 (put 'vc-mode 'permanent-local t)
  81
  82
  83 ;; branch identification
  84
  85 (defun vc-occurrences (object sequence)
  86   ;; return the number of occurences of OBJECT in SEQUENCE
  87   ;; (is it really true that Emacs Lisp doesn't provide such a function?)
  88   (let ((len (length sequence)) (index 0) (occ 0))
  89     (while (< index len)
  90       (if (eq object (elt sequence index))
  91           (setq occ (1+ occ)))
  92       (setq index (1+ index)))
  93     occ))
  94
  95 (defun vc-branch-p (rev)
  96   ;; return t if REV is the branch part of a revision,
  97   ;; i.e. a revision without a minor number
  98   (eq 0 (% (vc-occurrences ?. rev) 2)))
  99
 100 ;; We need a notion of per-file properties because the version
 101 ;; control state of a file is expensive to derive --- we compute
 102 ;; them when the file is initially found, keep them up to date
 103 ;; during any subsequent VC operations, and forget them when
 104 ;; the buffer is killed.
 105
 106 (defmacro vc-error-occurred (&rest body)
 107   (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
 108
 109 (defvar vc-file-prop-obarray [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
 110   "Obarray for per-file properties.")
 111
 112 (defvar vc-buffer-backend t)
 113 (make-variable-buffer-local 'vc-buffer-backend)
 114
 115 (defun vc-file-setprop (file property value)
 116   ;; set per-file property
 117   (put (intern file vc-file-prop-obarray) property value))
 118
 119 (defun vc-file-getprop (file property)
 120   ;; get per-file property
 121   (get (intern file vc-file-prop-obarray) property))
 122
 123 (defun vc-file-clearprops (file)
 124   ;; clear all properties of a given file
 125   (setplist (intern file vc-file-prop-obarray) nil))
 126
 127 ;; basic properties
 128
 129 (defun vc-name (file)
 130   "Return the master name of a file, nil if it is not registered."
 131   (or (vc-file-getprop file 'vc-name)
 132       (let ((name-and-type (vc-registered file)))
 133         (if name-and-type
 134             (progn
 135               (vc-file-setprop file 'vc-backend (cdr name-and-type))
 136               (vc-file-setprop file 'vc-name (car name-and-type)))))))
 137
 138 (defun vc-backend (file)
 139   "Return the version-control type of a file, nil if it is not registered."
 140   (and file
 141        (or (vc-file-getprop file 'vc-backend)
 142            (let ((name-and-type (vc-registered file)))
 143              (if name-and-type
 144                  (progn
 145                    (vc-file-setprop file 'vc-name (car name-and-type))
 146                    (vc-file-setprop file 'vc-backend (cdr name-and-type))))))))
 147
 148 ;; Functions for querying the master and lock files.
 149
 150 (defun vc-match-substring (bn)
 151   (buffer-substring (match-beginning bn) (match-end bn)))
 152
 153 (defun vc-lock-file (file)
 154   ;; Generate lock file name corresponding to FILE
 155   (let ((master (vc-name file)))
 156     (and
 157      master
 158      (string-match "\\(.*/\\)s\\.\\(.*\\)" master)
 159      (concat
 160       (substring master (match-beginning 1) (match-end 1))
 161       "p."
 162       (substring master (match-beginning 2) (match-end 2))))))
 163
 164 (defun vc-parse-buffer (patterns &optional file properties)
 165   ;; Use PATTERNS to parse information out of the current buffer.
 166   ;; Each element of PATTERNS is a list of 2 to 3 elements. The first element
 167   ;; is the pattern to be matched, and the second (an integer) is the
 168   ;; number of the subexpression that should be returned. If there's
 169   ;; a third element (also the number of a subexpression), that
 170   ;; subexpression is assumed to be a date field and we want the most
 171   ;; recent entry matching the template.
 172   ;; If FILE and PROPERTIES are given, the latter must be a list of
 173   ;; properties of the same length as PATTERNS; each property is assigned
 174   ;; the corresponding value.
 175   (mapcar (function (lambda (p)
 176             (goto-char (point-min))
 177             (cond
 178              ((eq (length p) 2)  ;; search for first entry
 179               (let ((value nil))
 180                 (if (re-search-forward (car p) nil t)
 181                     (setq value (vc-match-substring (elt p 1))))
 182                 (if file
 183                     (progn (vc-file-setprop file (car properties) value)
 184                            (setq properties (cdr properties))))
 185                 value))
 186              ((eq (length p) 3)  ;; search for latest entry
 187               (let ((latest-date "") (latest-val))
 188                 (while (re-search-forward (car p) nil t)
 189                   (let ((date (vc-match-substring (elt p 2))))
 190                     (if (string< latest-date date)
 191                         (progn
 192                           (setq latest-date date)
 193                           (setq latest-val
 194                                 (vc-match-substring (elt p 1)))))))
 195                 (if file
 196                     (progn (vc-file-setprop file (car properties) latest-val)
 197                            (setq properties (cdr properties))))
 198                 latest-val)))))
 199           patterns)
 200   )
 201
 202 (defun vc-master-info (file fields &optional rfile properties)
 203   ;; Search for information in a master file.
 204   (if (and file (file-exists-p file))
 205       (save-excursion
 206         (let ((buf))
 207           (setq buf (create-file-buffer file))
 208           (set-buffer buf))
 209         (erase-buffer)
 210         (insert-file-contents file)
 211         (set-buffer-modified-p nil)
 212         (auto-save-mode nil)
 213         (prog1
 214             (vc-parse-buffer fields rfile properties)
 215           (kill-buffer (current-buffer)))
 216         )
 217     (if rfile
 218         (mapcar
 219          (function (lambda (p) (vc-file-setprop rfile p nil)))
 220          properties))
 221     )
 222   )
 223
 224 (defun vc-log-info (command file flags patterns &optional properties)
 225   ;; Search for information in log program output.
 226   ;; If there is a string `\X' in any of the PATTERNS, replace
 227   ;; it with a regexp to search for a branch revision.
 228   (if (and file (file-exists-p file))
 229       (save-excursion
 230         ;; Run the command (not using vc-do-command, as that is
 231         ;; only available within vc.el)
 232         ;; Don't switch to the *vc* buffer before running the command
 233         ;; because that would change its default-directory.
 234         (save-excursion (set-buffer (get-buffer-create "*vc*"))
 235                         (erase-buffer))
 236         (let ((exec-path (append vc-path exec-path))
 237               ;; Add vc-path to PATH for the execution of this command.
 238               (process-environment
 239                (cons (concat "PATH=" (getenv "PATH")
 240                              ":" (mapconcat 'identity vc-path ":"))
 241                      process-environment)))
 242           (apply 'call-process command nil "*vc*" nil
 243                  (append flags (list (file-name-nondirectory file)))))
 244         (set-buffer (get-buffer "*vc*"))
 245         (set-buffer-modified-p nil)
 246         ;; in the RCS case, insert branch version into
 247         ;; any patterns that contain \X
 248         (if (eq (vc-backend file) 'RCS)
 249             (let ((branch
 250                    (car (vc-parse-buffer
 251                          '(("^branch:[ \t]+\\([0-9.]+\\)$" 1))))))
 252               (setq patterns
 253                 (mapcar
 254                  (function
 255                   (lambda (p)
 256                     (if (string-match "\\\\X" (car p))
 257                         (if branch
 258                             (cond ((vc-branch-p branch)
 259                                    (cons
 260                                     (concat
 261                                      (substring (car p) 0 (match-beginning 0))
 262                                      (regexp-quote branch)
 263                                      "\\.[0-9]+"
 264                                      (substring (car p) (match-end 0)))
 265                                     (cdr p)))
 266                                   (t
 267                                    (cons
 268                                     (concat
 269                                      (substring (car p) 0 (match-beginning 0))
 270                                      (regexp-quote branch)
 271                                      (substring (car p) (match-end 0)))
 272                                     (cdr p))))
 273                           ;; if there is no current branch,
 274                           ;; return a completely different regexp,
 275                           ;; which searches for the *head*
 276                           '("^head:[ \t]+\\([0-9.]+\\)$" 1))
 277                       p)))
 278                  patterns))))
 279         (prog1
 280             (vc-parse-buffer patterns file properties)
 281           (kill-buffer (current-buffer))
 282           )
 283         )
 284     (if file
 285         (mapcar
 286          (function (lambda (p) (vc-file-setprop file p nil)))
 287          properties))
 288     )
 289   )
 290
 291 ;;; Functions that determine property values, by examining the
 292 ;;; working file, the master file, or log program output
 293
 294 (defun vc-consult-rcs-headers (file)
 295   ;; Search for RCS headers in FILE, and set properties
 296   ;; accordingly.  This function can be disabled by setting
 297   ;; vc-consult-headers to nil.
 298   ;; Returns: nil            if no headers were found
 299   ;;                         (or if the feature is disabled,
 300   ;;                         or if there is currently no buffer
 301   ;;                         visiting FILE)
 302   ;;          'rev           if a workfile revision was found
 303   ;;          'rev-and-lock  if revision and lock info was found
 304   (cond
 305    ((or (not vc-consult-headers)
 306         (not (get-file-buffer file)) nil))
 307    ((save-excursion
 308       (set-buffer (get-file-buffer file))
 309       (goto-char (point-min))
 310       (cond
 311        ;; search for $Id or $Header
 312        ;; -------------------------
 313        ((re-search-forward "\\$\\(Id\\|Header\\): [^ ]+ \\([0-9.]+\\) "
 314                            nil t)
 315         ;; if found, store the revision number ...
 316         (let ((rev (buffer-substring (match-beginning 2)
 317                                      (match-end 2))))
 318           ;; ... and check for the locking state
 319           (if (re-search-forward
 320                (concat "\\=[0-9]+/[0-9]+/[0-9]+ "    ; date
 321                           "[0-9]+:[0-9]+:[0-9]+ "    ; time
 322                           "[^ ]+ [^ ]+ ")            ; author & state
 323                nil t)
 324               (cond
 325                ;; unlocked revision
 326                ((looking-at "\\$")
 327                 (vc-file-setprop file 'vc-workfile-version rev)
 328                 (vc-file-setprop file 'vc-locking-user nil)
 329                 (vc-file-setprop file 'vc-locked-version nil)
 330                 'rev-and-lock)
 331                ;; revision is locked by some user
 332                ((looking-at "\\([^ ]+\\) \\$")
 333                 (vc-file-setprop file 'vc-workfile-version rev)
 334                 (vc-file-setprop file 'vc-locking-user
 335                                  (buffer-substring (match-beginning 1)
 336                                                    (match-end 1)))
 337                 (vc-file-setprop file 'vc-locked-version rev)
 338                 'rev-and-lock)
 339                ;; everything else: false
 340                (nil))
 341             ;; unexpected information in
 342             ;; keyword string --> quit
 343             nil)))
 344        ;; search for $Revision
 345        ;; --------------------
 346        ((re-search-forward (concat "\\$"
 347                                    "Revision: \\([0-9.]+\\) \\$")
 348                            nil t)
 349         ;; if found, store the revision number ...
 350         (let ((rev (buffer-substring (match-beginning 1)
 351                                      (match-end 1))))
 352           ;; and see if there's any lock information
 353           (goto-char (point-min))
 354           (if (re-search-forward (concat "\\$" "Locker:") nil t)
 355               (cond ((looking-at " \\([^ ]+\\) \\$")
 356                      (vc-file-setprop file 'vc-workfile-version rev)
 357                      (vc-file-setprop file 'vc-locking-user
 358                                       (buffer-substring (match-beginning 1)
 359                                                         (match-end 1)))
 360                      (vc-file-setprop file 'vc-locked-version rev)
 361                      'rev-and-lock)
 362                     ((looking-at " *\\$")
 363                      (vc-file-setprop file 'vc-workfile-version rev)
 364                      (vc-file-setprop file 'vc-locking-user nil)
 365                      (vc-file-setprop file 'vc-locked-version nil)
 366                      'rev-and-lock)
 367                     (t
 368                      (vc-file-setprop file 'vc-workfile-version rev)
 369                      'rev-and-lock))
 370             (vc-file-setprop file 'vc-workfile-version rev)
 371             'rev)))
 372        ;; else: nothing found
 373        ;; -------------------
 374        (t nil))))))
 375
 376 (defun vc-fetch-properties (file)
 377   ;; Re-fetch some properties associated with the given file.
 378   (cond
 379    ((eq (vc-backend file) 'SCCS)
 380     (progn
 381       (vc-master-info (vc-lock-file file)
 382                       (list
 383                        '("^[^ ]+ [^ ]+ \\([^ ]+\\)" 1)
 384                        '("^\\([^ ]+\\)" 1))
 385                       file
 386                       '(vc-locking-user vc-locked-version))
 387       (vc-master-info (vc-name file)
 388                       (list
 389                        '("^\001d D \\([^ ]+\\)" 1)
 390                        (list (concat "^\001d D \\([^ ]+\\) .* "
 391                                      (regexp-quote (user-login-name)) " ")
 392                              1)
 393                        )
 394                       file
 395                       '(vc-latest-version vc-your-latest-version))
 396       ))
 397    ((eq (vc-backend file) 'RCS)
 398     (vc-log-info "rlog" file nil
 399                  (list
 400                   '("^locks: strict\n\t\\([^:]+\\)" 1)
 401                   '("^locks: strict\n\t[^:]+: \\(.+\\)" 1)
 402                   '("^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3)
 403                   (list
 404                    (concat
 405                     "^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\); *author: "
 406                     (regexp-quote (user-login-name))
 407                     ";") 1 3)
 408                   ;; special regexp to search for branch revision:
 409                   ;; \X will be replaced by vc-log-info (see there)
 410                   '("^revision[\t ]+\\(\\X\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3))
 411
 412                  '(vc-locking-user
 413                    vc-locked-version
 414                    vc-latest-version
 415                    vc-your-latest-version
 416                    vc-branch-version)))
 417    ((eq (vc-backend file) 'CVS)
 418     (vc-log-info "cvs" file '("status")
 419     ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
 420     ;; and CVS 1.4a1 says "Repository revision:".
 421     '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
 422       ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
 423     '(vc-latest-version vc-cvs-status))
 424     ;; Translate those status values that are needed into symbols.
 425     ;; Any other value is converted to nil.
 426     (let ((status (vc-file-getprop file 'vc-cvs-status)))
 427       (cond ((string-match "Up-to-date" status)
 428              (vc-file-setprop file 'vc-cvs-status 'up-to-date)
 429              (vc-file-setprop file 'vc-checkout-time
 430                               (nth 5 (file-attributes file))))
 431             ((string-match "Locally Modified" status)
 432              (vc-file-setprop file 'vc-cvs-status 'locally-modified))
 433             ((string-match "Needs Merge" status)
 434              (vc-file-setprop file 'vc-cvs-status 'needs-merge))
 435             (t (vc-file-setprop file 'vc-cvs-status nil))))
 436    )))
 437
 438 (defun vc-backend-subdirectory-name (&optional file)
 439   ;; Where the master and lock files for the current directory are kept
 440   (symbol-name
 441    (or
 442     (and file (vc-backend file))
 443     vc-default-back-end
 444     (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))
 445
 446
 447 ;;; Access functions to file properties
 448 ;;; (Properties should be _set_ using vc-file-setprop, but
 449 ;;; _retrieved_ only through these functions, which decide
 450 ;;; if the property is already known or not. A property should
 451 ;;; only be retrieved by vc-file-getprop if there is no
 452 ;;; access function.)
 453
 454 ;; functions vc-name and vc-backend come earlier above,
 455 ;; because they are needed by vc-log-info etc.
 456
 457 (defun vc-cvs-status (file)
 458   ;; Return the cvs status of FILE
 459   ;; (Status field in output of "cvs status")
 460   (cond ((vc-file-getprop file 'vc-cvs-status))
 461         (t (vc-fetch-properties file)
 462            (vc-file-getprop file 'vc-cvs-status))))
 463
 464 (defun vc-locking-user (file)
 465   "Return the name of the person currently holding a lock on FILE.
 466 Return nil if there is no such person.
 467 Under CVS, a file is considered locked if it has been modified since it
 468 was checked out.  Under CVS, this will sometimes return the uid of
 469 the owner of the file (as a number) instead of a string."
 470   ;; The property is cached. If it is non-nil, it is simply returned.
 471   ;; The other routines clear it when the locking state changes.
 472   (setq file (expand-file-name file));; ??? Work around bug in 19.0.4
 473   (cond
 474    ((vc-file-getprop file 'vc-locking-user))
 475    ((eq (vc-backend file) 'CVS)
 476     (if (eq (vc-cvs-status file) 'up-to-date)
 477         nil
 478       ;; The expression below should return the username of the owner
 479       ;; of the file.  It doesn't.  It returns the username if it is
 480       ;; you, or otherwise the UID of the owner of the file.  The
 481       ;; return value from this function is only used by
 482       ;; vc-dired-reformat-line, and it does the proper thing if a UID
 483       ;; is returned.
 484       ;;
 485       ;; The *proper* way to fix this would be to implement a built-in
 486       ;; function in Emacs, say, (username UID), that returns the
 487       ;; username of a given UID.
 488       ;;
 489       ;; The result of this hack is that vc-directory will print the
 490       ;; name of the owner of the file for any files that are
 491       ;; modified.
 492       (let ((uid (nth 2 (file-attributes file))))
 493         (if (= uid (user-uid))
 494             (vc-file-setprop file 'vc-locking-user (user-login-name))
 495           (vc-file-setprop file 'vc-locking-user uid)))))
 496    (t
 497     (if (and (eq (vc-backend file) 'RCS)
 498              (eq (vc-consult-rcs-headers file) 'rev-and-lock))
 499         (vc-file-getprop file 'vc-locking-user)
 500       (if (or (not vc-keep-workfiles)
 501               (eq vc-mistrust-permissions 't)
 502               (and vc-mistrust-permissions
 503                    (funcall vc-mistrust-permissions
 504                             (vc-backend-subdirectory-name file))))
 505           (vc-file-setprop file 'vc-locking-user (vc-true-locking-user file))
 506         ;; This implementation assumes that any file which is under version
 507         ;; control and has -rw-r--r-- is locked by its owner.  This is true
 508         ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
 509         ;; We have to be careful not to exclude files with execute bits on;
 510         ;; scripts can be under version control too.  Also, we must ignore
 511         ;; the group-read and other-read bits, since paranoid users turn them off.
 512         ;; This hack wins because calls to the very expensive vc-fetch-properties
 513         ;; function only have to be made if (a) the file is locked by someone
 514         ;; other than the current user, or (b) some untoward manipulation
 515         ;; behind vc's back has changed the owner or the `group' or `other'
 516         ;; write bits.
 517         (let ((attributes (file-attributes file)))
 518           (cond ((string-match ".r-..-..-." (nth 8 attributes))
 519                  nil)
 520                 ((and (= (nth 2 attributes) (user-uid))
 521                       (string-match ".rw..-..-." (nth 8 attributes)))
 522                  (vc-file-setprop file 'vc-locking-user (user-login-name)))
 523                 (t
 524                  (vc-file-setprop file 'vc-locking-user
 525                                   (vc-true-locking-user file))))))))))
 526
 527 (defun vc-true-locking-user (file)
 528   ;; The slow but reliable version
 529   (vc-fetch-properties file)
 530   (vc-file-getprop file 'vc-locking-user))
 531
 532 (defun vc-latest-version (file)
 533   ;; Return version level of the latest version of FILE
 534   (vc-fetch-properties file)
 535   (vc-file-getprop file 'vc-latest-version))
 536
 537 (defun vc-your-latest-version (file)
 538   ;; Return version level of the latest version of FILE checked in by you
 539   (vc-fetch-properties file)
 540   (vc-file-getprop file 'vc-your-latest-version))
 541
 542 (defun vc-branch-version (file)
 543   ;; Return version level of the highest revision on the default branch
 544   ;; If there is no default branch, return the highest version number
 545   ;; on the trunk.
 546   ;; This property is defined for RCS only.
 547   (vc-fetch-properties file)
 548   (vc-file-getprop file 'vc-branch-version))
 549
 550 (defun vc-workfile-version (file)
 551   ;; Return version level of the current workfile FILE
 552   ;; This is attempted by first looking at the RCS keywords.
 553   ;; If there are no keywords in the working file,
 554   ;; vc-branch-version is taken.
 555   ;; Note that this property is cached, that is, it is only
 556   ;; looked up if it is nil.
 557   ;; For SCCS, this property is equivalent to vc-latest-version.
 558   (cond ((vc-file-getprop file 'vc-workfile-version))
 559         ((eq (vc-backend file) 'SCCS) (vc-latest-version file))
 560         ((eq (vc-backend file) 'RCS)
 561          (if (vc-consult-rcs-headers file)
 562              (vc-file-getprop file 'vc-workfile-version)
 563            (let ((rev (cond ((vc-branch-version file))
 564                             ((vc-latest-version file)))))
 565              (vc-file-setprop file 'vc-workfile-version rev)
 566              rev)))
 567         ((eq (vc-backend file) 'CVS)
 568          (if (vc-consult-rcs-headers file)   ;; CVS
 569              (vc-file-getprop file 'vc-workfile-version)
 570            (vc-find-cvs-master (file-name-directory file)
 571                                (file-name-nondirectory file))
 572            (vc-file-getprop file 'vc-workfile-version)))))
 573
 574 ;;; actual version-control code starts here
 575
 576 (defun vc-registered (file)
 577   (let (handler handlers)
 578     (if (boundp 'file-name-handler-alist)
 579         (setq handler (find-file-name-handler file 'vc-registered)))
 580     (if handler
 581         (funcall handler 'vc-registered file)
 582       ;; Search for a master corresponding to the given file
 583       (let ((dirname (or (file-name-directory file) ""))
 584             (basename (file-name-nondirectory file)))
 585         (catch 'found
 586           (mapcar
 587            (function (lambda (s)
 588               (if (atom s)
 589                   (funcall s dirname basename)
 590                 (let ((trial (format (car s) dirname basename)))
 591                   (if (and (file-exists-p trial)
 592                            ;; Make sure the file we found with name
 593                            ;; TRIAL is not the source file itself.
 594                            ;; That can happen with RCS-style names
 595                            ;; if the file name is truncated
 596                            ;; (e.g. to 14 chars).  See if either
 597                            ;; directory or attributes differ.
 598                            (or (not (string= dirname
 599                                              (file-name-directory trial)))
 600                                (not (equal
 601                                      (file-attributes file)
 602                                      (file-attributes trial)))))
 603                       (throw 'found (cons trial (cdr s))))))))
 604            vc-master-templates)
 605           nil)))))
 606
 607 (defun vc-find-cvs-master (dirname basename)
 608   ;; Check if DIRNAME/BASENAME is handled by CVS.
 609   ;; If it is, do a (throw 'found (cons MASTER 'CVS)).
 610   ;; Note: If the file is ``cvs add''ed but not yet ``cvs commit''ed
 611   ;; the MASTER will not actually exist yet.  The other parts of VC
 612   ;; checks for this condition.  This function returns nil if
 613   ;; DIRNAME/BASENAME is not handled by CVS.
 614   (if (and (file-directory-p (concat dirname "CVS/"))
 615            (file-readable-p (concat dirname "CVS/Entries")))
 616       (let ((bufs nil) (fold case-fold-search))
 617         (unwind-protect
 618             (save-excursion
 619               (setq bufs (list
 620                           (find-file-noselect (concat dirname "CVS/Entries"))))
 621               (set-buffer (car bufs))
 622               (goto-char (point-min))
 623               ;; make sure the file name is searched
 624               ;; case-sensitively
 625               (setq case-fold-search nil)
 626               (cond
 627                ((re-search-forward
 628                  (concat "^/" (regexp-quote basename) "/\\([^/]*\\)/")
 629                  nil t)
 630                 (setq case-fold-search fold)  ;; restore the old value
 631                 ;; We found it.  Store away version number, now
 632                 ;; that we are anyhow so close to finding it.
 633                 (vc-file-setprop (concat dirname basename)
 634                                  'vc-workfile-version
 635                                  (buffer-substring (match-beginning 1)
 636                                                    (match-end 1)))
 637                 (setq bufs (cons (find-file-noselect
 638                                   (concat dirname "CVS/Repository"))
 639                                  bufs))
 640                 (set-buffer (car bufs))
 641                 (let ((master
 642                        (concat (file-name-as-directory
 643                                 (buffer-substring (point-min)
 644                                                   (1- (point-max))))
 645                                basename
 646                                ",v")))
 647                   (throw 'found (cons master 'CVS))))
 648                (t (setq case-fold-search fold)  ;; restore the old value
 649                   nil)))
 650           (mapcar (function kill-buffer) bufs)))))
 651
 652 (defun vc-buffer-backend ()
 653   "Return the version-control type of the visited file, or nil if none."
 654   (if (eq vc-buffer-backend t)
 655       (setq vc-buffer-backend (vc-backend (buffer-file-name)))
 656     vc-buffer-backend))
 657
 658 (defun vc-toggle-read-only (&optional verbose)
 659   "Change read-only status of current buffer, perhaps via version control.
 660 If the buffer is visiting a file registered with version control,
 661 then check the file in or out.  Otherwise, just change the read-only flag
 662 of the buffer.  With prefix argument, ask for version number."
 663   (interactive "P")
 664   (if (vc-backend (buffer-file-name))
 665       (vc-next-action verbose)
 666     (toggle-read-only)))
 667 (define-key global-map "\C-x\C-q" 'vc-toggle-read-only)
 668
 669 (defun vc-mode-line (file &optional label)
 670   "Set `vc-mode' to display type of version control for FILE.
 671 The value is set in the current buffer, which should be the buffer
 672 visiting FILE.  Second optional arg LABEL is put in place of version
 673 control system name."
 674   (interactive (list buffer-file-name nil))
 675   (let ((vc-type (vc-backend file))
 676         (vc-status-string (and vc-display-status (vc-status file))))
 677     (setq vc-mode
 678           (concat " " (or label (symbol-name vc-type)) vc-status-string))
 679     ;; Make the buffer read-only if the file is not locked
 680     ;; (or unchanged, in the CVS case).
 681     ;; Determine this by looking at the mode string,
 682     ;; so that no further external status query is necessary
 683     (if vc-status-string
 684         (if (eq (elt vc-status-string 0) ?-)
 685             (setq buffer-read-only t))
 686       (if (not (vc-locking-user file))
 687           (setq buffer-read-only t)))
 688     ;; Even root shouldn't modify a registered file without
 689     ;; locking it first.
 690     (and vc-type
 691          (not buffer-read-only)
 692          (zerop (user-uid))
 693          (require 'vc)
 694          (not (equal (user-login-name) (vc-locking-user file)))
 695          (setq buffer-read-only t))
 696     (and (null vc-type)
 697          (file-symlink-p file)
 698          (let ((link-type (vc-backend (file-symlink-p file))))
 699            (if link-type
 700                (message
 701                 "Warning: symbolic link to %s-controlled source file"
 702                 link-type))))
 703     (force-mode-line-update)
 704     ;;(set-buffer-modified-p (buffer-modified-p)) ;;use this if Emacs 18
 705     vc-type))
 706
 707 (defun vc-status (file)
 708   ;; Return string for placement in modeline by `vc-mode-line'.
 709   ;; Format:
 710   ;;
 711   ;;   "-REV"        if the revision is not locked
 712   ;;   ":REV"        if the revision is locked by the user
 713   ;;   ":LOCKER:REV" if the revision is locked by somebody else
 714   ;;   " @@"         for a CVS file that is added, but not yet committed
 715   ;;
 716   ;; In the CVS case, a "locked" working file is a
 717   ;; working file that is modified with respect to the master.
 718   ;; The file is "locked" from the moment when the user makes
 719   ;; the buffer writable.
 720   ;;
 721   ;; This function assumes that the file is registered.
 722
 723   (let ((locker (vc-locking-user file))
 724         (rev (vc-workfile-version file)))
 725     (cond ((string= "0" rev)
 726            " @@")
 727            ((not locker)
 728             (concat "-" rev))
 729           ((string= locker (user-login-name))
 730            (concat ":" rev))
 731           (t
 732            (concat ":" locker ":" rev)))))
 733
 734 ;;; install a call to the above as a find-file hook
 735 (defun vc-find-file-hook ()
 736   ;; Recompute whether file is version controlled,
 737   ;; if user has killed the buffer and revisited.
 738   (cond
 739    (buffer-file-name
 740     (vc-file-clearprops buffer-file-name)
 741     (cond
 742      ((vc-backend buffer-file-name)
 743       (vc-mode-line buffer-file-name)
 744       (cond ((not vc-make-backup-files)
 745              ;; Use this variable, not make-backup-files,
 746              ;; because this is for things that depend on the file name.
 747              (make-local-variable 'backup-inhibited)
 748              (setq backup-inhibited t))))))))
 749
 750 (add-hook 'find-file-hooks 'vc-find-file-hook)
 751
 752 ;;; more hooks, this time for file-not-found
 753 (defun vc-file-not-found-hook ()
 754   "When file is not found, try to check it out from RCS or SCCS.
 755 Returns t if checkout was successful, nil otherwise."
 756   (if (vc-backend buffer-file-name)
 757       (save-excursion
 758         (require 'vc)
 759         (not (vc-error-occurred (vc-checkout buffer-file-name))))))
 760
 761 (add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook)
 762
 763 ;; Discard info about a file when we kill its buffer.
 764 (defun vc-kill-buffer-hook ()
 765   (if (stringp (buffer-file-name))
 766       (progn
 767         (vc-file-clearprops (buffer-file-name))
 768         (kill-local-variable 'vc-buffer-backend))))
 769
 770 ;;;(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
 771
 772 ;;; Now arrange for bindings and autoloading of the main package.
 773 ;;; Bindings for this have to go in the global map, as we'll often
 774 ;;; want to call them from random buffers.
 775
 776 (setq vc-prefix-map (lookup-key global-map "\C-xv"))
 777 (if (not (keymapp vc-prefix-map))
 778     (progn
 779       (setq vc-prefix-map (make-sparse-keymap))
 780       (define-key global-map "\C-xv" vc-prefix-map)
 781       (define-key vc-prefix-map "a" 'vc-update-change-log)
 782       (define-key vc-prefix-map "c" 'vc-cancel-version)
 783       (define-key vc-prefix-map "d" 'vc-directory)
 784       (define-key vc-prefix-map "h" 'vc-insert-headers)
 785       (define-key vc-prefix-map "i" 'vc-register)
 786       (define-key vc-prefix-map "l" 'vc-print-log)
 787       (define-key vc-prefix-map "r" 'vc-retrieve-snapshot)
 788       (define-key vc-prefix-map "s" 'vc-create-snapshot)
 789       (define-key vc-prefix-map "u" 'vc-revert-buffer)
 790       (define-key vc-prefix-map "v" 'vc-next-action)
 791       (define-key vc-prefix-map "=" 'vc-diff)
 792       (define-key vc-prefix-map "~" 'vc-version-other-window)))
 793
 794 (if (not (boundp 'vc-menu-map))
 795     ;; Don't do the menu bindings if menu-bar.el wasn't loaded to defvar
 796     ;; vc-menu-map.
 797     ()
 798   ;;(define-key vc-menu-map [show-files]
 799   ;;  '("Show Files under VC" . (vc-directory t)))
 800   (define-key vc-menu-map [vc-directory] '("Show Locked Files" . vc-directory))
 801   (define-key vc-menu-map [separator1] '("----"))
 802   (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file))
 803   (define-key vc-menu-map [vc-version-other-window]
 804     '("Show Other Version" . vc-version-other-window))
 805   (define-key vc-menu-map [vc-diff] '("Compare with Last Version" . vc-diff))
 806   (define-key vc-menu-map [vc-update-change-log]
 807     '("Update ChangeLog" . vc-update-change-log))
 808   (define-key vc-menu-map [vc-print-log] '("Show History" . vc-print-log))
 809   (define-key vc-menu-map [separator2] '("----"))
 810   (define-key vc-menu-map [undo] '("Undo Last Check-In" . vc-cancel-version))
 811   (define-key vc-menu-map [vc-revert-buffer]
 812     '("Revert to Last Version" . vc-revert-buffer))
 813   (define-key vc-menu-map [vc-insert-header]
 814     '("Insert Header" . vc-insert-headers))
 815   (define-key vc-menu-map [vc-menu-check-in] '("Check In" . vc-next-action))
 816   (define-key vc-menu-map [vc-check-out] '("Check Out" . vc-toggle-read-only))
 817   (define-key vc-menu-map [vc-register] '("Register" . vc-register))
 818   (put 'vc-rename-file 'menu-enable 'vc-mode)
 819   (put 'vc-version-other-window 'menu-enable 'vc-mode)
 820   (put 'vc-diff 'menu-enable 'vc-mode)
 821   (put 'vc-update-change-log 'menu-enable
 822        '(eq (vc-buffer-backend) 'RCS))
 823   (put 'vc-print-log 'menu-enable 'vc-mode)
 824   (put 'vc-cancel-version 'menu-enable 'vc-mode)
 825   (put 'vc-revert-buffer 'menu-enable 'vc-mode)
 826   (put 'vc-insert-headers 'menu-enable 'vc-mode)
 827   (put 'vc-next-action 'menu-enable '(and vc-mode (not buffer-read-only)))
 828   (put 'vc-toggle-read-only 'menu-enable '(and vc-mode buffer-read-only))
 829   (put 'vc-register 'menu-enable '(not vc-mode))
 830   )
 831
 832 (provide 'vc-hooks)
 833
 834 ;;; vc-hooks.el ends here