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, 1995 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                              path-separator
 241                              (mapconcat 'identity vc-path path-separator))
 242                      process-environment)))
 243           (apply 'call-process command nil "*vc*" nil
 244                  (append flags (list (file-name-nondirectory file)))))
 245         (set-buffer (get-buffer "*vc*"))
 246         (set-buffer-modified-p nil)
 247         ;; in the RCS case, insert branch version into
 248         ;; any patterns that contain \X
 249         (if (eq (vc-backend file) 'RCS)
 250             (let ((branch
 251                    (car (vc-parse-buffer
 252                          '(("^branch:[ \t]+\\([0-9.]+\\)$" 1))))))
 253               (setq patterns
 254                 (mapcar
 255                  (function
 256                   (lambda (p)
 257                     (if (string-match "\\\\X" (car p))
 258                         (if branch
 259                             (cond ((vc-branch-p branch)
 260                                    (cons
 261                                     (concat
 262                                      (substring (car p) 0 (match-beginning 0))
 263                                      (regexp-quote branch)
 264                                      "\\.[0-9]+"
 265                                      (substring (car p) (match-end 0)))
 266                                     (cdr p)))
 267                                   (t
 268                                    (cons
 269                                     (concat
 270                                      (substring (car p) 0 (match-beginning 0))
 271                                      (regexp-quote branch)
 272                                      (substring (car p) (match-end 0)))
 273                                     (cdr p))))
 274                           ;; if there is no current branch,
 275                           ;; return a completely different regexp,
 276                           ;; which searches for the *head*
 277                           '("^head:[ \t]+\\([0-9.]+\\)$" 1))
 278                       p)))
 279                  patterns))))
 280         (prog1
 281             (vc-parse-buffer patterns file properties)
 282           (kill-buffer (current-buffer))
 283           )
 284         )
 285     (if file
 286         (mapcar
 287          (function (lambda (p) (vc-file-setprop file p nil)))
 288          properties))
 289     )
 290   )
 291
 292 ;;; Functions that determine property values, by examining the
 293 ;;; working file, the master file, or log program output
 294
 295 (defun vc-consult-rcs-headers (file)
 296   ;; Search for RCS headers in FILE, and set properties
 297   ;; accordingly.  This function can be disabled by setting
 298   ;; vc-consult-headers to nil.
 299   ;; Returns: nil            if no headers were found
 300   ;;                         (or if the feature is disabled,
 301   ;;                         or if there is currently no buffer
 302   ;;                         visiting FILE)
 303   ;;          'rev           if a workfile revision was found
 304   ;;          'rev-and-lock  if revision and lock info was found
 305   (cond
 306    ((or (not vc-consult-headers)
 307         (not (get-file-buffer file)) nil))
 308    ((save-excursion
 309       (set-buffer (get-file-buffer file))
 310       (goto-char (point-min))
 311       (cond
 312        ;; search for $Id or $Header
 313        ;; -------------------------
 314        ((re-search-forward "\\$\\(Id\\|Header\\): [^ ]+ \\([0-9.]+\\) "
 315                            nil t)
 316         ;; if found, store the revision number ...
 317         (let ((rev (buffer-substring (match-beginning 2)
 318                                      (match-end 2))))
 319           ;; ... and check for the locking state
 320           (if (re-search-forward
 321                (concat "\\=[0-9]+/[0-9]+/[0-9]+ "    ; date
 322                           "[0-9]+:[0-9]+:[0-9]+ "    ; time
 323                           "[^ ]+ [^ ]+ ")            ; author & state
 324                nil t)
 325               (cond
 326                ;; unlocked revision
 327                ((looking-at "\\$")
 328                 (vc-file-setprop file 'vc-workfile-version rev)
 329                 (vc-file-setprop file 'vc-locking-user nil)
 330                 (vc-file-setprop file 'vc-locked-version nil)
 331                 'rev-and-lock)
 332                ;; revision is locked by some user
 333                ((looking-at "\\([^ ]+\\) \\$")
 334                 (vc-file-setprop file 'vc-workfile-version rev)
 335                 (vc-file-setprop file 'vc-locking-user
 336                                  (buffer-substring (match-beginning 1)
 337                                                    (match-end 1)))
 338                 (vc-file-setprop file 'vc-locked-version rev)
 339                 'rev-and-lock)
 340                ;; everything else: false
 341                (nil))
 342             ;; unexpected information in
 343             ;; keyword string --> quit
 344             nil)))
 345        ;; search for $Revision
 346        ;; --------------------
 347        ((re-search-forward (concat "\\$"
 348                                    "Revision: \\([0-9.]+\\) \\$")
 349                            nil t)
 350         ;; if found, store the revision number ...
 351         (let ((rev (buffer-substring (match-beginning 1)
 352                                      (match-end 1))))
 353           ;; and see if there's any lock information
 354           (goto-char (point-min))
 355           (if (re-search-forward (concat "\\$" "Locker:") nil t)
 356               (cond ((looking-at " \\([^ ]+\\) \\$")
 357                      (vc-file-setprop file 'vc-workfile-version rev)
 358                      (vc-file-setprop file 'vc-locking-user
 359                                       (buffer-substring (match-beginning 1)
 360                                                         (match-end 1)))
 361                      (vc-file-setprop file 'vc-locked-version rev)
 362                      'rev-and-lock)
 363                     ((looking-at " *\\$")
 364                      (vc-file-setprop file 'vc-workfile-version rev)
 365                      (vc-file-setprop file 'vc-locking-user nil)
 366                      (vc-file-setprop file 'vc-locked-version nil)
 367                      'rev-and-lock)
 368                     (t
 369                      (vc-file-setprop file 'vc-workfile-version rev)
 370                      'rev-and-lock))
 371             (vc-file-setprop file 'vc-workfile-version rev)
 372             'rev)))
 373        ;; else: nothing found
 374        ;; -------------------
 375        (t nil))))))
 376
 377 (defun vc-fetch-properties (file)
 378   ;; Re-fetch some properties associated with the given file.
 379   (cond
 380    ((eq (vc-backend file) 'SCCS)
 381     (progn
 382       (vc-master-info (vc-lock-file file)
 383                       (list
 384                        '("^[^ ]+ [^ ]+ \\([^ ]+\\)" 1)
 385                        '("^\\([^ ]+\\)" 1))
 386                       file
 387                       '(vc-locking-user vc-locked-version))
 388       (vc-master-info (vc-name file)
 389                       (list
 390                        '("^\001d D \\([^ ]+\\)" 1)
 391                        (list (concat "^\001d D \\([^ ]+\\) .* "
 392                                      (regexp-quote (user-login-name)) " ")
 393                              1)
 394                        )
 395                       file
 396                       '(vc-latest-version vc-your-latest-version))
 397       ))
 398    ((eq (vc-backend file) 'RCS)
 399     (vc-log-info "rlog" file nil
 400                  (list
 401                   '("^locks: strict\n\t\\([^:]+\\)" 1)
 402                   '("^locks: strict\n\t[^:]+: \\(.+\\)" 1)
 403                   '("^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3)
 404                   (list
 405                    (concat
 406                     "^revision[\t ]+\\([0-9.]+\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\); *author: "
 407                     (regexp-quote (user-login-name))
 408                     ";") 1 3)
 409                   ;; special regexp to search for branch revision:
 410                   ;; \X will be replaced by vc-log-info (see there)
 411                   '("^revision[\t ]+\\(\\X\\)\\(\n\\|[ \t].*\n\\)date: \\([ /0-9:]+\\);" 1 3))
 412
 413                  '(vc-locking-user
 414                    vc-locked-version
 415                    vc-latest-version
 416                    vc-your-latest-version
 417                    vc-branch-version)))
 418    ((eq (vc-backend file) 'CVS)
 419     (vc-log-info "cvs" file '("status")
 420     ;; CVS 1.3 says "RCS Version:", other releases "RCS Revision:",
 421     ;; and CVS 1.4a1 says "Repository revision:".
 422     '(("\\(RCS Version\\|RCS Revision\\|Repository revision\\):[\t ]+\\([0-9.]+\\)" 2)
 423       ("^File: [^ \t]+[ \t]+Status: \\(.*\\)" 1))
 424     '(vc-latest-version vc-cvs-status))
 425     ;; Translate those status values that are needed into symbols.
 426     ;; Any other value is converted to nil.
 427     (let ((status (vc-file-getprop file 'vc-cvs-status)))
 428       (cond ((string-match "Up-to-date" status)
 429              (vc-file-setprop file 'vc-cvs-status 'up-to-date)
 430              (vc-file-setprop file 'vc-checkout-time
 431                               (nth 5 (file-attributes file))))
 432             ((string-match "Locally Modified" status)
 433              (vc-file-setprop file 'vc-cvs-status 'locally-modified))
 434             ((string-match "Needs Merge" status)
 435              (vc-file-setprop file 'vc-cvs-status 'needs-merge))
 436             (t (vc-file-setprop file 'vc-cvs-status nil))))
 437    )))
 438
 439 (defun vc-backend-subdirectory-name (&optional file)
 440   ;; Where the master and lock files for the current directory are kept
 441   (symbol-name
 442    (or
 443     (and file (vc-backend file))
 444     vc-default-back-end
 445     (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))
 446
 447
 448 ;;; Access functions to file properties
 449 ;;; (Properties should be _set_ using vc-file-setprop, but
 450 ;;; _retrieved_ only through these functions, which decide
 451 ;;; if the property is already known or not. A property should
 452 ;;; only be retrieved by vc-file-getprop if there is no
 453 ;;; access function.)
 454
 455 ;; functions vc-name and vc-backend come earlier above,
 456 ;; because they are needed by vc-log-info etc.
 457
 458 (defun vc-cvs-status (file)
 459   ;; Return the cvs status of FILE
 460   ;; (Status field in output of "cvs status")
 461   (cond ((vc-file-getprop file 'vc-cvs-status))
 462         (t (vc-fetch-properties file)
 463            (vc-file-getprop file 'vc-cvs-status))))
 464
 465 (defun vc-locking-user (file)
 466   "Return the name of the person currently holding a lock on FILE.
 467 Return nil if there is no such person.
 468 Under CVS, a file is considered locked if it has been modified since it
 469 was checked out.  Under CVS, this will sometimes return the uid of
 470 the owner of the file (as a number) instead of a string."
 471   ;; The property is cached. If it is non-nil, it is simply returned.
 472   ;; The other routines clear it when the locking state changes.
 473   (setq file (expand-file-name file));; ??? Work around bug in 19.0.4
 474   (cond
 475    ((vc-file-getprop file 'vc-locking-user))
 476    ((eq (vc-backend file) 'CVS)
 477     (if (eq (vc-cvs-status file) 'up-to-date)
 478         nil
 479       ;; The expression below should return the username of the owner
 480       ;; of the file.  It doesn't.  It returns the username if it is
 481       ;; you, or otherwise the UID of the owner of the file.  The
 482       ;; return value from this function is only used by
 483       ;; vc-dired-reformat-line, and it does the proper thing if a UID
 484       ;; is returned.
 485       ;;
 486       ;; The *proper* way to fix this would be to implement a built-in
 487       ;; function in Emacs, say, (username UID), that returns the
 488       ;; username of a given UID.
 489       ;;
 490       ;; The result of this hack is that vc-directory will print the
 491       ;; name of the owner of the file for any files that are
 492       ;; modified.
 493       (let ((uid (nth 2 (file-attributes file))))
 494         (if (= uid (user-uid))
 495             (vc-file-setprop file 'vc-locking-user (user-login-name))
 496           (vc-file-setprop file 'vc-locking-user uid)))))
 497    (t
 498     (if (and (eq (vc-backend file) 'RCS)
 499              (eq (vc-consult-rcs-headers file) 'rev-and-lock))
 500         (vc-file-getprop file 'vc-locking-user)
 501       (if (or (not vc-keep-workfiles)
 502               (eq vc-mistrust-permissions 't)
 503               (and vc-mistrust-permissions
 504                    (funcall vc-mistrust-permissions
 505                             (vc-backend-subdirectory-name file))))
 506           (vc-file-setprop file 'vc-locking-user (vc-true-locking-user file))
 507         ;; This implementation assumes that any file which is under version
 508         ;; control and has -rw-r--r-- is locked by its owner.  This is true
 509         ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
 510         ;; We have to be careful not to exclude files with execute bits on;
 511         ;; scripts can be under version control too.  Also, we must ignore
 512         ;; the group-read and other-read bits, since paranoid users turn them off.
 513         ;; This hack wins because calls to the very expensive vc-fetch-properties
 514         ;; function only have to be made if (a) the file is locked by someone
 515         ;; other than the current user, or (b) some untoward manipulation
 516         ;; behind vc's back has changed the owner or the `group' or `other'
 517         ;; write bits.
 518         (let ((attributes (file-attributes file)))
 519           (cond ((string-match ".r-..-..-." (nth 8 attributes))
 520                  nil)
 521                 ((and (= (nth 2 attributes) (user-uid))
 522                       (string-match ".rw..-..-." (nth 8 attributes)))
 523                  (vc-file-setprop file 'vc-locking-user (user-login-name)))
 524                 (t
 525                  (vc-file-setprop file 'vc-locking-user
 526                                   (vc-true-locking-user file))))))))))
 527
 528 (defun vc-true-locking-user (file)
 529   ;; The slow but reliable version
 530   (vc-fetch-properties file)
 531   (vc-file-getprop file 'vc-locking-user))
 532
 533 (defun vc-latest-version (file)
 534   ;; Return version level of the latest version of FILE
 535   (vc-fetch-properties file)
 536   (vc-file-getprop file 'vc-latest-version))
 537
 538 (defun vc-your-latest-version (file)
 539   ;; Return version level of the latest version of FILE checked in by you
 540   (vc-fetch-properties file)
 541   (vc-file-getprop file 'vc-your-latest-version))
 542
 543 (defun vc-branch-version (file)
 544   ;; Return version level of the highest revision on the default branch
 545   ;; If there is no default branch, return the highest version number
 546   ;; on the trunk.
 547   ;; This property is defined for RCS only.
 548   (vc-fetch-properties file)
 549   (vc-file-getprop file 'vc-branch-version))
 550
 551 (defun vc-workfile-version (file)
 552   ;; Return version level of the current workfile FILE
 553   ;; This is attempted by first looking at the RCS keywords.
 554   ;; If there are no keywords in the working file,
 555   ;; vc-branch-version is taken.
 556   ;; Note that this property is cached, that is, it is only
 557   ;; looked up if it is nil.
 558   ;; For SCCS, this property is equivalent to vc-latest-version.
 559   (cond ((vc-file-getprop file 'vc-workfile-version))
 560         ((eq (vc-backend file) 'SCCS) (vc-latest-version file))
 561         ((eq (vc-backend file) 'RCS)
 562          (if (vc-consult-rcs-headers file)
 563              (vc-file-getprop file 'vc-workfile-version)
 564            (let ((rev (cond ((vc-branch-version file))
 565                             ((vc-latest-version file)))))
 566              (vc-file-setprop file 'vc-workfile-version rev)
 567              rev)))
 568         ((eq (vc-backend file) 'CVS)
 569          (if (vc-consult-rcs-headers file)   ;; CVS
 570              (vc-file-getprop file 'vc-workfile-version)
 571            (vc-find-cvs-master (file-name-directory file)
 572                                (file-name-nondirectory file))
 573            (vc-file-getprop file 'vc-workfile-version)))))
 574
 575 ;;; actual version-control code starts here
 576
 577 (defun vc-registered (file)
 578   (let (handler handlers)
 579     (if (boundp 'file-name-handler-alist)
 580         (setq handler (find-file-name-handler file 'vc-registered)))
 581     (if handler
 582         (funcall handler 'vc-registered file)
 583       ;; Search for a master corresponding to the given file
 584       (let ((dirname (or (file-name-directory file) ""))
 585             (basename (file-name-nondirectory file)))
 586         (catch 'found
 587           (mapcar
 588            (function (lambda (s)
 589               (if (atom s)
 590                   (funcall s dirname basename)
 591                 (let ((trial (format (car s) dirname basename)))
 592                   (if (and (file-exists-p trial)
 593                            ;; Make sure the file we found with name
 594                            ;; TRIAL is not the source file itself.
 595                            ;; That can happen with RCS-style names
 596                            ;; if the file name is truncated
 597                            ;; (e.g. to 14 chars).  See if either
 598                            ;; directory or attributes differ.
 599                            (or (not (string= dirname
 600                                              (file-name-directory trial)))
 601                                (not (equal
 602                                      (file-attributes file)
 603                                      (file-attributes trial)))))
 604                       (throw 'found (cons trial (cdr s))))))))
 605            vc-master-templates)
 606           nil)))))
 607
 608 (defun vc-find-cvs-master (dirname basename)
 609   ;; Check if DIRNAME/BASENAME is handled by CVS.
 610   ;; If it is, do a (throw 'found (cons MASTER 'CVS)).
 611   ;; Note: If the file is ``cvs add''ed but not yet ``cvs commit''ed
 612   ;; the MASTER will not actually exist yet.  The other parts of VC
 613   ;; checks for this condition.  This function returns nil if
 614   ;; DIRNAME/BASENAME is not handled by CVS.
 615   (if (and (file-directory-p (concat dirname "CVS/"))
 616            (file-readable-p (concat dirname "CVS/Entries")))
 617       (let ((bufs nil) (fold case-fold-search))
 618         (unwind-protect
 619             (save-excursion
 620               (setq bufs (list
 621                           (find-file-noselect (concat dirname "CVS/Entries"))))
 622               (set-buffer (car bufs))
 623               (goto-char (point-min))
 624               ;; make sure the file name is searched
 625               ;; case-sensitively
 626               (setq case-fold-search nil)
 627               (cond
 628                ((re-search-forward
 629                  (concat "^/" (regexp-quote basename) "/\\([^/]*\\)/")
 630                  nil t)
 631                 (setq case-fold-search fold)  ;; restore the old value
 632                 ;; We found it.  Store away version number, now
 633                 ;; that we are anyhow so close to finding it.
 634                 (vc-file-setprop (concat dirname basename)
 635                                  'vc-workfile-version
 636                                  (buffer-substring (match-beginning 1)
 637                                                    (match-end 1)))
 638                 (setq bufs (cons (find-file-noselect
 639                                   (concat dirname "CVS/Repository"))
 640                                  bufs))
 641                 (set-buffer (car bufs))
 642                 (let ((master
 643                        (concat (file-name-as-directory
 644                                 (buffer-substring (point-min)
 645                                                   (1- (point-max))))
 646                                basename
 647                                ",v")))
 648                   (throw 'found (cons master 'CVS))))
 649                (t (setq case-fold-search fold)  ;; restore the old value
 650                   nil)))
 651           (mapcar (function kill-buffer) bufs)))))
 652
 653 (defun vc-buffer-backend ()
 654   "Return the version-control type of the visited file, or nil if none."
 655   (if (eq vc-buffer-backend t)
 656       (setq vc-buffer-backend (vc-backend (buffer-file-name)))
 657     vc-buffer-backend))
 658
 659 (defun vc-toggle-read-only (&optional verbose)
 660   "Change read-only status of current buffer, perhaps via version control.
 661 If the buffer is visiting a file registered with version control,
 662 then check the file in or out.  Otherwise, just change the read-only flag
 663 of the buffer.  With prefix argument, ask for version number."
 664   (interactive "P")
 665   (if (vc-backend (buffer-file-name))
 666       (vc-next-action verbose)
 667     (toggle-read-only)))
 668 (define-key global-map "\C-x\C-q" 'vc-toggle-read-only)
 669
 670 (defun vc-mode-line (file &optional label)
 671   "Set `vc-mode' to display type of version control for FILE.
 672 The value is set in the current buffer, which should be the buffer
 673 visiting FILE.  Second optional arg LABEL is put in place of version
 674 control system name."
 675   (interactive (list buffer-file-name nil))
 676   (let ((vc-type (vc-backend file))
 677         (vc-status-string (and vc-display-status (vc-status file))))
 678     (setq vc-mode
 679           (concat " " (or label (symbol-name vc-type)) vc-status-string))
 680     ;; Make the buffer read-only if the file is not locked
 681     ;; (or unchanged, in the CVS case).
 682     ;; Determine this by looking at the mode string,
 683     ;; so that no further external status query is necessary
 684     (if vc-status-string
 685         (if (eq (elt vc-status-string 0) ?-)
 686             (setq buffer-read-only t))
 687       (if (not (vc-locking-user file))
 688           (setq buffer-read-only t)))
 689     ;; Even root shouldn't modify a registered file without
 690     ;; locking it first.
 691     (and vc-type
 692          (not buffer-read-only)
 693          (zerop (user-uid))
 694          (require 'vc)
 695          (not (equal (user-login-name) (vc-locking-user file)))
 696          (setq buffer-read-only t))
 697     (and (null vc-type)
 698          (file-symlink-p file)
 699          (let ((link-type (vc-backend (file-symlink-p file))))
 700            (if link-type
 701                (message
 702                 "Warning: symbolic link to %s-controlled source file"
 703                 link-type))))
 704     (force-mode-line-update)
 705     ;;(set-buffer-modified-p (buffer-modified-p)) ;;use this if Emacs 18
 706     vc-type))
 707
 708 (defun vc-status (file)
 709   ;; Return string for placement in modeline by `vc-mode-line'.
 710   ;; Format:
 711   ;;
 712   ;;   "-REV"        if the revision is not locked
 713   ;;   ":REV"        if the revision is locked by the user
 714   ;;   ":LOCKER:REV" if the revision is locked by somebody else
 715   ;;   " @@"         for a CVS file that is added, but not yet committed
 716   ;;
 717   ;; In the CVS case, a "locked" working file is a
 718   ;; working file that is modified with respect to the master.
 719   ;; The file is "locked" from the moment when the user makes
 720   ;; the buffer writable.
 721   ;;
 722   ;; This function assumes that the file is registered.
 723
 724   (let ((locker (vc-locking-user file))
 725         (rev (vc-workfile-version file)))
 726     (cond ((string= "0" rev)
 727            " @@")
 728           ((not locker)
 729            (concat "-" rev))
 730           ((if (stringp locker)
 731                (string= locker (user-login-name))
 732              (= locker (user-uid)))
 733            (concat ":" rev))
 734           (t
 735            (concat ":" locker ":" rev)))))
 736
 737 ;;; install a call to the above as a find-file hook
 738 (defun vc-find-file-hook ()
 739   ;; Recompute whether file is version controlled,
 740   ;; if user has killed the buffer and revisited.
 741   (cond
 742    (buffer-file-name
 743     (vc-file-clearprops buffer-file-name)
 744     (cond
 745      ((vc-backend buffer-file-name)
 746       (vc-mode-line buffer-file-name)
 747       (cond ((not vc-make-backup-files)
 748              ;; Use this variable, not make-backup-files,
 749              ;; because this is for things that depend on the file name.
 750              (make-local-variable 'backup-inhibited)
 751              (setq backup-inhibited t))))))))
 752
 753 (add-hook 'find-file-hooks 'vc-find-file-hook)
 754
 755 ;;; more hooks, this time for file-not-found
 756 (defun vc-file-not-found-hook ()
 757   "When file is not found, try to check it out from RCS or SCCS.
 758 Returns t if checkout was successful, nil otherwise."
 759   (if (vc-backend buffer-file-name)
 760       (save-excursion
 761         (require 'vc)
 762         (not (vc-error-occurred (vc-checkout buffer-file-name))))))
 763
 764 (add-hook 'find-file-not-found-hooks 'vc-file-not-found-hook)
 765
 766 ;; Discard info about a file when we kill its buffer.
 767 (defun vc-kill-buffer-hook ()
 768   (if (stringp (buffer-file-name))
 769       (progn
 770         (vc-file-clearprops (buffer-file-name))
 771         (kill-local-variable 'vc-buffer-backend))))
 772
 773 ;;;(add-hook 'kill-buffer-hook 'vc-kill-buffer-hook)
 774
 775 ;;; Now arrange for bindings and autoloading of the main package.
 776 ;;; Bindings for this have to go in the global map, as we'll often
 777 ;;; want to call them from random buffers.
 778
 779 (setq vc-prefix-map (lookup-key global-map "\C-xv"))
 780 (if (not (keymapp vc-prefix-map))
 781     (progn
 782       (setq vc-prefix-map (make-sparse-keymap))
 783       (define-key global-map "\C-xv" vc-prefix-map)
 784       (define-key vc-prefix-map "a" 'vc-update-change-log)
 785       (define-key vc-prefix-map "c" 'vc-cancel-version)
 786       (define-key vc-prefix-map "d" 'vc-directory)
 787       (define-key vc-prefix-map "h" 'vc-insert-headers)
 788       (define-key vc-prefix-map "i" 'vc-register)
 789       (define-key vc-prefix-map "l" 'vc-print-log)
 790       (define-key vc-prefix-map "r" 'vc-retrieve-snapshot)
 791       (define-key vc-prefix-map "s" 'vc-create-snapshot)
 792       (define-key vc-prefix-map "u" 'vc-revert-buffer)
 793       (define-key vc-prefix-map "v" 'vc-next-action)
 794       (define-key vc-prefix-map "=" 'vc-diff)
 795       (define-key vc-prefix-map "~" 'vc-version-other-window)))
 796
 797 (if (not (boundp 'vc-menu-map))
 798     ;; Don't do the menu bindings if menu-bar.el wasn't loaded to defvar
 799     ;; vc-menu-map.
 800     ()
 801   ;;(define-key vc-menu-map [show-files]
 802   ;;  '("Show Files under VC" . (vc-directory t)))
 803   (define-key vc-menu-map [vc-directory] '("Show Locked Files" . vc-directory))
 804   (define-key vc-menu-map [separator1] '("----"))
 805   (define-key vc-menu-map [vc-rename-file] '("Rename File" . vc-rename-file))
 806   (define-key vc-menu-map [vc-version-other-window]
 807     '("Show Other Version" . vc-version-other-window))
 808   (define-key vc-menu-map [vc-diff] '("Compare with Last Version" . vc-diff))
 809   (define-key vc-menu-map [vc-update-change-log]
 810     '("Update ChangeLog" . vc-update-change-log))
 811   (define-key vc-menu-map [vc-print-log] '("Show History" . vc-print-log))
 812   (define-key vc-menu-map [separator2] '("----"))
 813   (define-key vc-menu-map [undo] '("Undo Last Check-In" . vc-cancel-version))
 814   (define-key vc-menu-map [vc-revert-buffer]
 815     '("Revert to Last Version" . vc-revert-buffer))
 816   (define-key vc-menu-map [vc-insert-header]
 817     '("Insert Header" . vc-insert-headers))
 818   (define-key vc-menu-map [vc-menu-check-in] '("Check In" . vc-next-action))
 819   (define-key vc-menu-map [vc-check-out] '("Check Out" . vc-toggle-read-only))
 820   (define-key vc-menu-map [vc-register] '("Register" . vc-register))
 821   (put 'vc-rename-file 'menu-enable 'vc-mode)
 822   (put 'vc-version-other-window 'menu-enable 'vc-mode)
 823   (put 'vc-diff 'menu-enable 'vc-mode)
 824   (put 'vc-update-change-log 'menu-enable
 825        '(eq (vc-buffer-backend) 'RCS))
 826   (put 'vc-print-log 'menu-enable 'vc-mode)
 827   (put 'vc-cancel-version 'menu-enable 'vc-mode)
 828   (put 'vc-revert-buffer 'menu-enable 'vc-mode)
 829   (put 'vc-insert-headers 'menu-enable 'vc-mode)
 830   (put 'vc-next-action 'menu-enable '(and vc-mode (not buffer-read-only)))
 831   (put 'vc-toggle-read-only 'menu-enable '(and vc-mode buffer-read-only))
 832   (put 'vc-register 'menu-enable '(not vc-mode))
 833   )
 834
 835 (provide 'vc-hooks)
 836
 837 ;;; vc-hooks.el ends here