lisp/vc.el

   1 ;;; vc.el --- drive a version-control system from within Emacs
   2
   3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
   6 ;; Version: 5.3
   7
   8 ;;      $Id: vc.el,v 1.29 1993/03/28 06:40:46 eric Exp eric $
   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 mode is fully documented in the Emacs user's manual.
  29 ;;
  30 ;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>.
  31 ;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>,
  32 ;; and Richard Stallman contributed valuable criticism, support, and testing.
  33 ;;
  34 ;; Supported version-control systems presently include SCCS and RCS;
  35 ;; your RCS version should be 5.6.2 or later for proper operation of
  36 ;; the lock-breaking code.
  37 ;;
  38 ;; The RCS code assumes strict locking.  You can support the RCS -x option
  39 ;; by adding pairs to the vc-master-templates list.
  40 ;;
  41 ;; Proper function of the SCCS diff commands requires the shellscript vcdiff
  42 ;; to be installed somewhere on Emacs's path for executables.
  43 ;;
  44 ;; If your site uses the ChangeLog convention supported by Emacs, the
  45 ;; function vc-comment-to-changelog should prove a useful checkin hook.
  46 ;;
  47 ;; This code depends on call-process passing back the subprocess exit
  48 ;; status.  Thus, you need Emacs 18.58 or later to run it.
  49 ;;
  50 ;; The vc code maintains some internal state in order to reduce expensive
  51 ;; version-control operations to a minimum.  Some names are only computed
  52 ;; once. If you perform version control operations with RCS/SCCS/CVS while
  53 ;; vc's back is turned, or move/rename master files while vc is running,
  54 ;; vc may get seriously confused.  Don't do these things!
  55 ;;
  56 ;; Developer's notes on some concurrency issues are included at the end of
  57 ;; the file.
  58
  59 ;;; Code:
  60
  61 (require 'vc-hooks)
  62
  63 ;; General customization
  64
  65 (defvar vc-default-back-end nil
  66   "*Back-end actually used by this interface; may be SCCS or RCS.
  67 The value is only computed when needed to avoid an expensive search.")
  68 (defvar vc-diff-options '("-a" "-c1")
  69   "*The command/flags list to be used in constructing diff commands.")
  70 (defvar vc-suppress-confirm nil
  71   "*If non-nil, reat user as expert; suppress yes-no prompts on some things.")
  72 (defvar vc-keep-workfiles t
  73   "*If non-nil, don't delete working files after registering changes.")
  74 (defvar vc-initial-comment nil
  75   "*Prompt for initial comment when a file is registered.")
  76 (defvar vc-command-messages nil
  77   "*Display run messages from back-end commands.")
  78 (defvar vc-mistrust-permissions 'file-symlink-p
  79   "*Don't assume that permissions and ownership track version-control status.")
  80
  81 (defvar vc-checkin-switches nil
  82   "*Extra switches passed to the checkin program by \\[vc-checkin].")
  83
  84 ;;;###autoload
  85 (defvar vc-checkin-hook nil
  86   "*List of functions called after a vc-checkin is done.  See `run-hooks'.")
  87
  88 ;; Header-insertion hair
  89
  90 (defvar vc-header-alist
  91   '((SCCS "\%W\%") (RCS "\$Id\$"))
  92   "*Header keywords to be inserted when vc-insert-header is executed.")
  93 (defconst vc-static-header-alist
  94   '(("\\.c$" .
  95      "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
  96   "*Associate static header string templates with file types.  A \%s in the
  97 template is replaced with the first string associated with the file's
  98 verson-control type in vc-header-alist.")
  99
 100 (defvar vc-comment-alist
 101   '((nroff-mode ".\\\"" ""))
 102   "*Special comment delimiters to be used in generating vc headers only.
 103 Add an entry in this list if you need to override the normal comment-start
 104 and comment-end variables.  This will only be necessary if the mode language
 105 is sensitive to blank lines.")
 106
 107 ;; Variables the user doesn't need to know about.
 108 (defvar vc-log-entry-mode nil)
 109 (defvar vc-log-operation nil)
 110 (defvar vc-log-after-operation-hook nil)
 111 (defvar vc-checkout-writeable-buffer-hook 'vc-checkout-writeable-buffer)
 112 (defvar vc-parent-buffer nil)
 113
 114 (defvar vc-log-file)
 115 (defvar vc-log-version)
 116
 117 (defconst vc-name-assoc-file "VC-names")
 118
 119 ;; File property caching
 120
 121 (defun vc-file-clearprops (file)
 122   ;; clear all properties of a given file
 123   (setplist (intern file vc-file-prop-obarray) nil))
 124
 125 ;; Random helper functions
 126
 127 (defun vc-name (file)
 128   "Return the master name of a file, nil if it is not registered"
 129   (or (vc-file-getprop file 'vc-name)
 130       (vc-file-setprop file 'vc-name
 131                        (let ((name-and-type (vc-registered file)))
 132                          (and name-and-type (car name-and-type))))))
 133
 134 (defvar vc-binary-assoc nil)
 135
 136 (defun vc-find-binary (name)
 137   "Look for a command anywhere on the subprocess-command search path."
 138   (or (cdr (assoc name vc-binary-assoc))
 139       (let ((full nil))
 140         (catch 'found
 141           (mapcar
 142            (function (lambda (s)
 143               (if (and s (file-exists-p (setq full (concat s "/" name))))
 144                   (throw 'found nil))))
 145           exec-path))
 146         (if full
 147             (setq vc-binary-assoc (cons (cons name full) vc-binary-assoc)))
 148         full)))
 149
 150 (defun vc-do-command (okstatus command file &rest flags)
 151   "Execute a version-control command, notifying user and checking for errors.
 152 The command is successful if its exit status does not exceed OKSTATUS.
 153 Output from COMMAND goes to buffer *vc*.  The last argument of the command is
 154 the master name of FILE; this is appended to an optional list of FLAGS."
 155   (setq file (expand-file-name file))
 156   (if vc-command-messages
 157       (message "Running %s on %s..." command file))
 158   (let ((obuf (current-buffer)) (camefrom (current-buffer))
 159         (squeezed nil)
 160         (vc-file (and file (vc-name file)))
 161         status)
 162     (set-buffer (get-buffer-create "*vc*"))
 163     (make-local-variable 'vc-parent-buffer)
 164     (setq vc-parent-buffer camefrom)
 165     (erase-buffer)
 166
 167     ;; This is so that command arguments typed in the *vc* buffer will
 168     ;; have reasonable defaults.
 169     (setq default-directory (file-name-directory file))
 170
 171     (mapcar
 172      (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
 173      flags)
 174     (if vc-file
 175         (setq squeezed (append squeezed (list vc-file))))
 176     (let ((default-directory (file-name-directory (or file "./"))))
 177       (setq status (apply 'call-process command nil t nil squeezed)))
 178     (goto-char (point-max))
 179     (previous-line 1)
 180     (if (or (not (integerp status)) (< okstatus status))
 181         (progn
 182           (previous-line 1)
 183           (print (cons command squeezed))
 184           (next-line 1)
 185           (pop-to-buffer "*vc*")
 186           (vc-shrink-to-fit)
 187           (goto-char (point-min))
 188           (error "Running %s...FAILED (%s)" command
 189                  (if (integerp status)
 190                      (format "status %d" status)
 191                    status))
 192           )
 193       (if vc-command-messages
 194           (message "Running %s...OK" command))
 195       )
 196     (set-buffer obuf)
 197     status)
 198   )
 199
 200 ;;; Save a bit of the text around POSN in the current buffer, to help
 201 ;;; us find the corresponding position again later.  This works even
 202 ;;; if all markers are destroyed or corrupted.
 203 (defun vc-position-context (posn)
 204   (list posn
 205         (buffer-size)
 206         (buffer-substring posn
 207                           (min (point-max) (+ posn 100)))))
 208
 209 ;;; Return the position of CONTEXT in the current buffer, or nil if we
 210 ;;; couldn't find it.
 211 (defun vc-find-position-by-context (context)
 212   (let ((context-string (nth 2 context)))
 213     (if (equal "" context-string)
 214         (point-max)
 215       (save-excursion
 216         (let ((diff (- (nth 1 context) (buffer-size))))
 217           (if (< diff 0) (setq diff (- diff)))
 218           (goto-char (nth 0 context))
 219           (if (or (search-forward context-string nil t)
 220                   ;; Can't use search-backward since the match may continue
 221                   ;; after point.
 222                   (progn (goto-char (- (point) diff (length context-string)))
 223                          ;; goto-char doesn't signal an error at
 224                          ;; beginning of buffer like backward-char would
 225                          (search-forward context-string nil t)))
 226               ;; to beginning of OSTRING
 227               (- (point) (length context-string))))))))
 228
 229 (defun vc-revert-buffer1 (&optional arg no-confirm)
 230   ;; Most of this was shamelessly lifted from Sebastian Kremer's rcs.el mode.
 231   ;; Revert buffer, try to keep point and mark where user expects them in spite
 232   ;; of changes because of expanded version-control key words.
 233   ;; This is quite important since otherwise typeahead won't work as expected.
 234   (interactive "P")
 235   (widen)
 236   (let ((point-context (vc-position-context (point)))
 237         ;; Use mark-marker to avoid confusion in transient-mark-mode.
 238         (mark-context  (if (eq (marker-buffer (mark-marker)) (current-buffer))
 239                            (vc-position-context (mark-marker))))
 240         ;; Make the right thing happen in transient-mark-mode.
 241         (mark-active nil))
 242
 243     ;; the actual revisit
 244     (revert-buffer arg no-confirm)
 245
 246     ;; Restore point and mark
 247     (let ((new-point (vc-find-position-by-context point-context)))
 248       (if new-point (goto-char new-point)))
 249     (if mark-context
 250         (let ((new-mark (vc-find-position-by-context mark-context)))
 251           (if new-mark (set-mark new-mark))))))
 252
 253
 254 (defun vc-buffer-sync ()
 255   ;; Make sure the current buffer and its working file are in sync
 256   (if (and (buffer-modified-p)
 257            (or
 258             vc-suppress-confirm
 259             (y-or-n-p (format "%s has been modified.  Write it out? "
 260                               (buffer-name)))))
 261       (save-buffer)))
 262
 263 (defun vc-workfile-unchanged-p (file)
 264   ;; Has the given workfile changed since last checkout?
 265   (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
 266         (lastmod (nth 5 (file-attributes file))))
 267     (if checkout-time
 268      (equal lastmod checkout-time)
 269      (if (zerop (vc-backend-diff file nil))
 270          (progn
 271            (vc-file-setprop file 'vc-checkout-time lastmod)
 272            t)
 273        (progn
 274            (vc-file-setprop file 'vc-checkout-time '(0 . 0))
 275            nil
 276          ))
 277      )))
 278
 279 ;; Here's the major entry point.
 280
 281 ;;;###autoload
 282 (defun vc-next-action (verbose)
 283   "Do the next logical checkin or checkout operation on the current file.
 284    If the file is not already registered, this registers it for version
 285 control and then retrieves a writeable, locked copy for editing.
 286    If the file is registered and not locked by anyone, this checks out
 287 a writeable and locked file ready for editing.
 288    If the file is checked out and locked by the calling user, this
 289 first checks to see if the file has changed since checkout.  If not,
 290 it performs a revert.
 291    If the file has been changed, this pops up a buffer for creation of
 292 a log message; when the message has been entered, it checks in the
 293 resulting changes along with the log message as change commentary.  If
 294 the variable vc-keep-workfiles is non-nil (which is its default), a
 295 read-only copy of the changed file is left in place afterwards.
 296    If the file is registered and locked by someone else, you are given
 297 the option to steal the lock."
 298   (interactive "P")
 299   (while vc-parent-buffer
 300       (pop-to-buffer vc-parent-buffer))
 301   (if buffer-file-name
 302       (let
 303           (do-update owner version
 304                      (file buffer-file-name)
 305                      (vc-file (vc-name buffer-file-name))
 306                      (err-msg nil)
 307                      owner)
 308
 309         (cond
 310
 311          ;; if there is no master file corresponding, create one
 312          ((not vc-file)
 313           (vc-register verbose)
 314           (if vc-initial-comment
 315               (setq vc-log-after-operation-hook
 316                     'vc-checkout-writeable-buffer-hook)
 317             (vc-checkout-writeable-buffer)))
 318
 319          ;; if there is no lock on the file, assert one and get it
 320          ((not (setq owner (vc-locking-user file)))
 321           (vc-checkout-writeable-buffer))
 322
 323          ;; a checked-out version exists, but the user may not own the lock
 324          ((not (string-equal owner (user-login-name)))
 325           (vc-steal-lock
 326            file
 327            (and verbose (read-string "Version to steal: "))
 328            owner))
 329
 330          ;; OK, user owns the lock on the file
 331          (t (progn
 332
 333               ;; give luser a chance to save before checking in.
 334               (vc-buffer-sync)
 335
 336               ;; Revert if file is unchanged and buffer is too.
 337               ;; If buffer is modified, that means the user just said no
 338               ;; to saving it; in that case, don't revert,
 339               ;; because the user might intend to save
 340               ;; after finishing the log entry.
 341               (if (and (vc-workfile-unchanged-p file)
 342                        (not (buffer-modified-p)))
 343                   (progn
 344                     (vc-backend-revert file)
 345                     ;; DO NOT revert the file without asking the user!
 346                     (vc-resynch-window file t nil))
 347
 348                 ;; user may want to set nonstandard parameters
 349                 (if verbose
 350                     (setq version (read-string "New version level: ")))
 351
 352                 ;; OK, let's do the checkin
 353                 (vc-checkin file version))))))
 354     (error "There is no file associated with buffer %s" (buffer-name))))
 355
 356 ;;; These functions help the vc-next-action entry point
 357
 358 (defun vc-checkout-writeable-buffer ()
 359   "Retrieve a writeable copy of the latest version of the current buffer's file."
 360   (vc-checkout (buffer-file-name) t)
 361   )
 362
 363 ;;;###autoload
 364 (defun vc-register (&optional override)
 365   "Register the current file into your version-control system."
 366   (interactive "P")
 367   (if (vc-name buffer-file-name)
 368       (error "This file is already registered."))
 369   ;; Watch out for new buffers of size 0: the corresponding file
 370   ;; does not exist yet, even though buffer-modified-p is nil.
 371   (if (and (not (buffer-modified-p))
 372            (zerop (buffer-size))
 373            (not (file-exists-p buffer-file-name)))
 374       (set-buffer-modified-p t))
 375   (vc-buffer-sync)
 376   (vc-admin
 377    buffer-file-name
 378    (and override (read-string "Initial version level: ")))
 379   )
 380
 381 (defun vc-resynch-window (file &optional keep noquery)
 382   ;; If the given file is in the current buffer,
 383   ;; either revert on it so we see expanded keyworks,
 384   ;; or unvisit it (depending on vc-keep-workfiles)
 385   ;; NOQUERY if non-nil inhibits confirmation for reverting.
 386   ;; NOQUERY should be t *only* if it is known the only difference
 387   ;; between the buffer and the file is due to RCS rather than user editing!
 388   (and (string= buffer-file-name file)
 389        (if keep
 390            (progn
 391              (vc-revert-buffer1 t noquery)
 392              (vc-mode-line buffer-file-name))
 393          (progn
 394            (delete-window)
 395            (kill-buffer (current-buffer))))))
 396
 397
 398 (defun vc-admin (file rev)
 399   "Check a file into your version-control system.
 400 FILE is the unmodified name of the file.  REV should be the base version
 401 level to check it in under."
 402   (if vc-initial-comment
 403       (let ((camefrom (current-buffer)))
 404         (pop-to-buffer (get-buffer-create "*VC-log*"))
 405         (make-local-variable 'vc-parent-buffer)
 406         (setq vc-parent-buffer camefrom)
 407         (vc-log-mode)
 408         (narrow-to-region (point-max) (point-max))
 409         (vc-mode-line file (file-name-nondirectory file))
 410         (setq vc-log-operation 'vc-backend-admin)
 411         (setq vc-log-file file)
 412         (setq vc-log-version rev)
 413         (message "Enter initial comment.  Type C-c C-c when done."))
 414     (progn
 415       (vc-backend-admin file rev)
 416       ;; Inhibit query here, since otherwise we always get asked.
 417       (vc-resynch-window file vc-keep-workfiles t))))
 418
 419 (defun vc-steal-lock (file rev &optional owner)
 420   "Steal the lock on the current workfile."
 421   (interactive)
 422   (if (not owner)
 423       (setq owner (vc-locking-user file)))
 424   (if (not (y-or-n-p (format "Take the lock on %s:%s from %s?" file rev owner)))
 425       (error "Steal cancelled."))
 426   (require 'sendmail)
 427   (pop-to-buffer (get-buffer-create "*VC-mail*"))
 428   (setq default-directory (expand-file-name "~/"))
 429   (auto-save-mode auto-save-default)
 430   (mail-mode)
 431   (erase-buffer)
 432   (mail-setup owner (format "%s:%s" file rev) nil nil nil
 433               (list (list 'vc-finish-steal file rev)))
 434   (goto-char (point-max))
 435   (insert
 436    (format "I stole the lock on %s:%s, " file rev)
 437    (current-time-string)
 438    ".\n")
 439   (message "Please explain why you stole the lock.  Type C-c C-c when done."))
 440
 441 ;; This is called when the notification has been sent.
 442 (defun vc-finish-steal (file version)
 443   (vc-backend-steal file version)
 444   (vc-resynch-window file t t))
 445
 446 (defun vc-checkout (file &optional writeable)
 447   "Retrieve a copy of the latest version of the given file."
 448   ;; If ftp is on this system and the name matches the ange-ftp format
 449   ;; for a remote file, the user is trying something that won't work.
 450   (if (and (string-match "^/[^/:]+:" file) (vc-find-binary "ftp"))
 451       (error "Sorry, you can't check out files over FTP"))
 452   (vc-backend-checkout file writeable)
 453   (if (string-equal file buffer-file-name)
 454       (vc-resynch-window file t t))
 455   )
 456
 457 (defun vc-checkin (file &optional rev comment)
 458   "Check in the file specified by FILE.
 459 The optional argument REV may be a string specifying the new version level
 460 \(if nil increment the current level).  The file is either retained with write
 461 permissions zeroed, or deleted (according to the value of vc-keep-workfiles).
 462 COMMENT is a comment string; if omitted, a buffer is
 463 popped up to accept a comment."
 464   (let ((camefrom (current-buffer)))
 465     (pop-to-buffer (get-buffer-create "*VC-log*"))
 466     (make-local-variable 'vc-parent-buffer)
 467     (setq vc-parent-buffer camefrom))
 468   (vc-log-mode)
 469   (narrow-to-region (point-max) (point-max))
 470   (vc-mode-line file (file-name-nondirectory file))
 471   (setq vc-log-operation 'vc-backend-checkin
 472         vc-log-file file
 473         vc-log-version rev
 474         vc-log-after-operation-hook 'vc-checkin-hook)
 475   (message "Enter log message.  Type C-c C-c when done.")
 476   (if comment
 477       (progn
 478         (insert comment)
 479         (vc-finish-logentry))))
 480
 481 ;;; Here is a checkin hook that may prove useful to sites using the
 482 ;;; ChangeLog facility supported by Emacs.
 483 (defun vc-comment-to-changelog ()
 484   (let ((log (find-change-log)))
 485     (if log
 486         (let ((default-directory (or (file-name-directory log)
 487                                      default-directory)))
 488           (vc-update-change-log
 489            (file-relative-name buffer-file-name))))))
 490
 491 (defun vc-finish-logentry ()
 492   "Complete the operation implied by the current log entry."
 493   (interactive)
 494   (goto-char (point-max))
 495   (if (not (bolp)) (newline))
 496   ;; Append the contents of the log buffer to the comment ring
 497   (save-excursion
 498     (set-buffer (get-buffer-create "*VC-comment-ring*"))
 499     (goto-char (point-max))
 500     (set-mark (point))
 501     (insert-buffer-substring "*VC-log*")
 502     (if (and (not (bobp)) (not (= (char-after (1- (point))) ?\f)))
 503         (insert-char ?\f 1))
 504     (if (not (bobp))
 505         (forward-char -1))
 506     (exchange-point-and-mark)
 507     ;; Check for errors
 508     (vc-backend-logentry-check vc-log-file)
 509     )
 510   ;; OK, do it to it
 511   (if vc-log-operation
 512       (funcall vc-log-operation
 513                vc-log-file
 514                vc-log-version
 515                (buffer-string))
 516     (error "No log operation is pending."))
 517   ;; Return to "parent" buffer of this checkin and remove checkin window
 518   (pop-to-buffer (get-file-buffer vc-log-file))
 519   (delete-window (get-buffer-window "*VC-log*"))
 520   (bury-buffer "*VC-log*")
 521   (bury-buffer "*VC-comment-ring*")
 522   ;; Now make sure we see the expanded headers
 523   (vc-resynch-window buffer-file-name vc-keep-workfiles t)
 524   (run-hooks vc-log-after-operation-hook)
 525   )
 526
 527 ;; Code for access to the comment ring
 528
 529 (defun vc-next-comment ()
 530   "Fill the log buffer with the next message in the msg ring."
 531   (interactive)
 532   (erase-buffer)
 533   (save-excursion
 534     (set-buffer "*VC-comment-ring*")
 535     (forward-page)
 536     (if (= (point) (point-max))
 537         (goto-char (point-min)))
 538     (mark-page)
 539     (append-to-buffer "*VC-log*" (point) (1- (mark)))
 540     ))
 541
 542 (defun vc-previous-comment ()
 543   "Fill the log buffer with the previous message in the msg ring."
 544   (interactive)
 545   (erase-buffer)
 546   (save-excursion
 547     (set-buffer "*VC-comment-ring*")
 548     (if (= (point) (point-min))
 549         (goto-char (point-max)))
 550     (backward-page)
 551     (mark-page)
 552     (append-to-buffer "*VC-log*" (point) (1- (mark)))
 553     ))
 554
 555 (defun vc-comment-search-backward (regexp)
 556   "Fill the log buffer with the last message in the msg ring matching REGEXP."
 557   (interactive "sSearch backward for: ")
 558   (erase-buffer)
 559   (save-excursion
 560     (set-buffer "*VC-comment-ring*")
 561     (if (= (point) (point-min))
 562         (goto-char (point-max)))
 563     (re-search-backward regexp nil t)
 564     (mark-page)
 565     (append-to-buffer "*VC-log*" (point) (1- (mark)))
 566     ))
 567
 568 (defun vc-comment-search-forward (regexp)
 569   "Fill the log buffer with the next message in the msg ring matching REGEXP."
 570   (interactive "sSearch forward for: ")
 571   (erase-buffer)
 572   (save-excursion
 573     (set-buffer "*VC-comment-ring*")
 574     (if (= (point) (point-max))
 575         (goto-char (point-min)))
 576     (re-search-forward regexp nil t)
 577     (mark-page)
 578     (append-to-buffer "*VC-log*" (point) (1- (mark)))
 579     ))
 580
 581 ;; Additional entry points for examining version histories
 582
 583 ;;;###autoload
 584 (defun vc-diff (historic)
 585   "Display diffs between file versions."
 586   (interactive "P")
 587   (while vc-parent-buffer
 588       (pop-to-buffer vc-parent-buffer))
 589   (if historic
 590       (call-interactively 'vc-version-diff)
 591     (let ((file buffer-file-name)
 592           unchanged)
 593       (vc-buffer-sync)
 594       (setq unchanged (vc-workfile-unchanged-p buffer-file-name))
 595       (if unchanged
 596           (message "No changes to %s since latest version." file)
 597         (pop-to-buffer "*vc*")
 598         (vc-backend-diff file nil)
 599         (vc-shrink-to-fit)
 600         (goto-char (point-min))
 601         )
 602       (not unchanged)
 603       )
 604     )
 605   )
 606
 607 (defun vc-version-diff (file rel1 rel2)
 608   "For FILE, report diffs between two stored versions REL1 and REL2 of it.
 609 If FILE is a directory, generate diffs between versions for all registered
 610 files in or below it."
 611   (interactive "FFile or directory to diff: \nsOlder version: \nsNewer version: ")
 612   (if (string-equal rel1 "") (setq rel1 nil))
 613   (if (string-equal rel2 "") (setq rel2 nil))
 614   (if (file-directory-p file)
 615       (let ((camefrom (current-buffer)))
 616         (set-buffer (get-buffer-create "*vc-status*"))
 617         (make-local-variable 'vc-parent-buffer)
 618         (setq vc-parent-buffer camefrom)
 619         (erase-buffer)
 620         (insert "Diffs between "
 621                 (or rel1 "last version checked in")
 622                 " and "
 623                 (or rel2 "current workfile(s)")
 624                 ":\n\n")
 625         (set-buffer (get-buffer-create "*vc*"))
 626         (vc-file-tree-walk
 627          (function (lambda (f)
 628                      (message "Looking at %s" f)
 629                      (and
 630                       (not (file-directory-p f))
 631                       (vc-registered f)
 632                       (vc-backend-diff f rel1 rel2)
 633                       (append-to-buffer "*vc-status*" (point-min) (point-max)))
 634                      )))
 635         (pop-to-buffer "*vc-status*")
 636         (insert "\nEnd of diffs.\n")
 637         (goto-char (point-min))
 638         (set-buffer-modified-p nil)
 639         )
 640     (progn
 641       (vc-backend-diff file rel1 rel2)
 642       (goto-char (point-min))
 643       (if (equal (point-min) (point-max))
 644           (message "No changes to %s between %s and %s." file rel1 rel2)
 645         (pop-to-buffer "*vc*")
 646         (goto-char (point-min))
 647         )
 648       )
 649     )
 650   )
 651
 652 ;; Header-insertion code
 653
 654 ;;;###autoload
 655 (defun vc-insert-headers ()
 656   "Insert headers in a file for use with your version-control system.
 657 Headers desired are inserted at the start of the buffer, and are pulled from
 658 the variable vc-header-alist"
 659   (interactive)
 660   (while vc-parent-buffer
 661       (pop-to-buffer vc-parent-buffer))
 662   (save-excursion
 663     (save-restriction
 664       (widen)
 665       (if (or (not (vc-check-headers))
 666               (y-or-n-p "Version headers already exist.  Insert another set?"))
 667           (progn
 668             (let* ((delims (cdr (assq major-mode vc-comment-alist)))
 669                    (comment-start-vc (or (car delims) comment-start "#"))
 670                    (comment-end-vc (or (car (cdr delims)) comment-end ""))
 671                    (hdstrings (cdr (assoc (vc-backend-deduce (buffer-file-name)) vc-header-alist))))
 672               (mapcar (function (lambda (s)
 673                                   (insert comment-start-vc "\t" s "\t"
 674                                           comment-end-vc "\n")))
 675                       hdstrings)
 676               (if vc-static-header-alist
 677                   (mapcar (function (lambda (f)
 678                                       (if (string-match (car f) buffer-file-name)
 679                                           (insert (format (cdr f) (car hdstrings))))))
 680                           vc-static-header-alist))
 681               )
 682             )))))
 683
 684 ;; Status-checking functions
 685
 686 ;;;###autoload
 687 (defun vc-directory (verbose)
 688   "Show version-control status of all files under the current directory."
 689   (interactive "P")
 690   (let (nonempty)
 691     (save-excursion
 692       (set-buffer (get-buffer-create "*vc-status*"))
 693       (erase-buffer)
 694       (vc-file-tree-walk
 695        (function (lambda (f)
 696                    (if (vc-registered f)
 697                        (let ((user (vc-locking-user f)))
 698                          (if (or user verbose)
 699                              (insert (format
 700                                       "%s       %s\n"
 701                                       (concat user) f))))))))
 702       (setq nonempty (not (zerop (buffer-size)))))
 703     (if nonempty
 704         (progn
 705           (pop-to-buffer "*vc-status*" t)
 706           (vc-shrink-to-fit)
 707           (goto-char (point-min)))
 708       (message "No files are currently %s under %s"
 709                (if verbose "registered" "locked") default-directory))
 710     ))
 711
 712 ;; Named-configuration support for SCCS
 713
 714 (defun vc-add-triple (name file rev)
 715   (save-excursion
 716     (find-file (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file))
 717     (goto-char (point-max))
 718     (insert name "\t:\t" file "\t" rev "\n")
 719     (basic-save-buffer)
 720     (kill-buffer (current-buffer))
 721     ))
 722
 723 (defun vc-record-rename (file newname)
 724   (save-excursion
 725     (find-file (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file))
 726     (goto-char (point-min))
 727     (replace-regexp (concat ":" (regexp-quote file) "$") (concat ":" newname))
 728     (basic-save-buffer)
 729     (kill-buffer (current-buffer))
 730     ))
 731
 732 (defun vc-lookup-triple (file name)
 733   ;; Return the numeric version corresponding to a named snapshot of file
 734   ;; If name is nil or a version number string it's just passed through
 735   (cond ((null name) "")
 736         ((let ((firstchar (aref name 0)))
 737            (and (>= firstchar ?0) (<= firstchar ?9)))
 738          name)
 739         (t
 740          (car (vc-master-info
 741                (concat (vc-backend-subdirectory-name file) "/" vc-name-assoc-file)
 742                (list (concat name "\t:\t" file "\t\\(.+\\)"))))
 743          )))
 744
 745 ;; Named-configuration entry points
 746
 747 (defun vc-quiescent-p ()
 748   ;; Is the current directory ready to be snapshot?
 749   (catch 'quiet
 750     (vc-file-tree-walk
 751      (function (lambda (f)
 752                  (if (and (vc-registered f) (vc-locking-user f))
 753                      (throw 'quiet nil)))))
 754     t))
 755
 756 ;;;###autoload
 757 (defun vc-create-snapshot (name)
 758   "Make a snapshot called NAME.
 759 The snapshot is made from all registered files at or below the current
 760 directory.  For each file, the version level of its latest
 761 version becomes part of the named configuration."
 762   (interactive "sNew snapshot name: ")
 763   (if (not (vc-quiescent-p))
 764       (error "Can't make a snapshot, locked files are in the way.")
 765     (vc-file-tree-walk
 766      (function (lambda (f) (and
 767                    (vc-name f)
 768                    (vc-backend-assign-name f name)))))
 769     ))
 770
 771 ;;;###autoload
 772 (defun vc-retrieve-snapshot (name)
 773   "Retrieve the snapshot called NAME.
 774 This function fails if any files are locked at or below the current directory
 775 Otherwise, all registered files are checked out (unlocked) at their version
 776 levels in the snapshot."
 777   (interactive "sSnapshot name to retrieve: ")
 778   (if (not (vc-quiescent-p))
 779       (error "Can't retrieve a snapshot, locked files are in the way.")
 780     (vc-file-tree-walk
 781      (function (lambda (f) (and
 782                    (vc-name f)
 783                    (vc-error-occurred (vc-backend-checkout f nil name))))))
 784     ))
 785
 786 ;; Miscellaneous other entry points
 787
 788 ;;;###autoload
 789 (defun vc-print-log ()
 790   "List the change log of the current buffer in a window."
 791   (interactive)
 792   (while vc-parent-buffer
 793       (pop-to-buffer vc-parent-buffer))
 794   (if (and buffer-file-name (vc-name buffer-file-name))
 795       (progn
 796         (vc-backend-print-log buffer-file-name)
 797         (pop-to-buffer (get-buffer-create "*vc*"))
 798         (vc-shrink-to-fit)
 799         (goto-char (point-min))
 800         )
 801     (error "There is no version-control master associated with this buffer")
 802     )
 803   )
 804
 805 ;;;###autoload
 806 (defun vc-revert-buffer ()
 807   "Revert the current buffer's file back to the latest checked-in version.
 808 This asks for confirmation if the buffer contents are not identical
 809 to that version."
 810   (interactive)
 811   (while vc-parent-buffer
 812       (pop-to-buffer vc-parent-buffer))
 813   (let ((file buffer-file-name)
 814         (obuf (current-buffer)) (changed (vc-diff nil)))
 815     (if (and changed (or vc-suppress-confirm
 816                          (not (yes-or-no-p "Discard changes? "))))
 817         (progn
 818           (delete-window)
 819           (error "Revert cancelled."))
 820       (set-buffer obuf))
 821     (if changed
 822         (delete-window))
 823     (vc-backend-revert file)
 824     (vc-resynch-window file t t)
 825     )
 826   )
 827
 828 ;;;###autoload
 829 (defun vc-cancel-version (norevert)
 830   "Undo your latest checkin."
 831   (interactive "P")
 832   (while vc-parent-buffer
 833     (pop-to-buffer vc-parent-buffer))
 834   (let* ((target (concat (vc-latest-version (buffer-file-name))))
 835         (yours (concat (vc-your-latest-version (buffer-file-name))))
 836         (prompt (if (string-equal yours target)
 837                     "Remove your version %s from master?"
 838                   "Version %s was not your change.  Remove it anyway?")))
 839     (if (null (yes-or-no-p (format prompt target)))
 840         nil
 841       (vc-backend-uncheck (buffer-file-name) target)
 842       (if norevert
 843           (vc-mode-line (buffer-file-name))
 844         (vc-checkout (buffer-file-name) nil)))
 845     ))
 846
 847 (defun vc-rename-file (old new)
 848   "Rename a file, taking its master files with it."
 849   (interactive "fOld name: \nFNew name: ")
 850   (let ((oldbuf (get-file-buffer old)))
 851     (if (buffer-modified-p oldbuf)
 852         (error "Please save files before moving them."))
 853     (if (get-file-buffer new)
 854         (error "Already editing new file name."))
 855     (let ((oldmaster (vc-name old)))
 856       (if oldmaster
 857         (if (vc-locking-user old)
 858             (error "Please check in files before moving them."))
 859         (if (or (file-symlink-p oldmaster)
 860                 ;; This had FILE, I changed it to OLD. -- rms.
 861                 (file-symlink-p (vc-backend-subdirectory-name old)))
 862             (error "This is not a safe thing to do in the presence of symbolic links."))
 863         (rename-file oldmaster (vc-name new)))
 864       (if (or (not oldmaster) (file-exists-p old))
 865           (rename-file old new)))
 866 ; ?? Renaming a file might change its contents due to keyword expansion.
 867 ; We should really check out a new copy if the old copy was precisely equal
 868 ; to some checked in version.  However, testing for this is tricky....
 869     (if oldbuf
 870         (save-excursion
 871           (set-buffer oldbuf)
 872           (set-visited-file-name new)
 873           (set-buffer-modified-p nil))))
 874   ;; This had FILE, I changed it to OLD. -- rms.
 875   (vc-backend-dispatch old
 876                        (vc-record-rename old new)
 877                        nil)
 878   )
 879
 880 ;;;###autoload
 881 (defun vc-update-change-log (&rest args)
 882   "Find change log file and add entries from recent RCS logs.
 883 The mark is left at the end of the text prepended to the change log.
 884 With prefix arg of C-u, only find log entries for the current buffer's file.
 885 With any numeric prefix arg, find log entries for all files currently visited.
 886 From a program, any arguments are passed to the `rcs2log' script."
 887   (interactive
 888    (cond ((consp current-prefix-arg)    ;C-u
 889           (list buffer-file-name))
 890          (current-prefix-arg            ;Numeric argument.
 891           (let ((files nil)
 892                 (buffers (buffer-list))
 893                 file)
 894             (while buffers
 895               (setq file (buffer-file-name (car buffers)))
 896               (and file (vc-backend-deduce file)
 897                    (setq files (cons (file-relative-name file) files)))
 898               (setq buffers (cdr buffers)))
 899             files))))
 900   (find-file-other-window "ChangeLog")
 901   (barf-if-buffer-read-only)
 902   (vc-buffer-sync)
 903   (undo-boundary)
 904   (goto-char (point-min))
 905   (push-mark)
 906   (message "Computing change log entries...")
 907   (message "Computing change log entries... %s"
 908            (if (eq 0 (apply 'call-process "rcs2log" nil t nil args))
 909                "done" "failed")))
 910
 911 ;; Functions for querying the master and lock files.
 912
 913 (defun match-substring (bn)
 914   (buffer-substring (match-beginning bn) (match-end bn)))
 915
 916 (defun vc-parse-buffer (patterns &optional file properties)
 917   ;; Use PATTERNS to parse information out of the current buffer
 918   ;; by matching each regular expression in the list and returning \\1.
 919   ;; If a regexp has two tag brackets, assume the second is a date
 920   ;; field and we want the most recent entry matching the template.
 921   ;; If FILE and PROPERTIES are given, the latter must be a list of
 922   ;; properties of the same length as PATTERNS; each property is assigned
 923   ;; the corresponding value.
 924   (mapcar (function (lambda (p)
 925              (goto-char (point-min))
 926              (if (string-match "\\\\(.*\\\\(" p)
 927                  (let ((latest-date "") (latest-val))
 928                    (while (re-search-forward p nil t)
 929                      (let ((date (match-substring 2)))
 930                        (if (string< latest-date date)
 931                            (progn
 932                              (setq latest-date date)
 933                              (setq latest-val
 934                                    (match-substring 1))))))
 935                    latest-val))
 936              (prog1
 937                  (and (re-search-forward p nil t)
 938                       (let ((value (match-substring 1)))
 939                         (if file
 940                             (vc-file-setprop file (car properties) value))
 941                         value))
 942                (setq properties (cdr properties)))))
 943           patterns)
 944   )
 945
 946 (defun vc-master-info (file fields &optional rfile properties)
 947   ;; Search for information in a master file.
 948   (if (and file (file-exists-p file))
 949       (save-excursion
 950         (let ((buf))
 951           (setq buf (create-file-buffer file))
 952           (set-buffer buf))
 953         (erase-buffer)
 954         (insert-file-contents file nil)
 955         (set-buffer-modified-p nil)
 956         (auto-save-mode nil)
 957         (prog1
 958             (vc-parse-buffer fields rfile properties)
 959           (kill-buffer (current-buffer)))
 960         )
 961     (if rfile
 962         (mapcar
 963          (function (lambda (p) (vc-file-setprop rfile p nil)))
 964          properties))
 965     )
 966   )
 967
 968 (defun vc-log-info (command file patterns &optional properties)
 969   ;; Search for information in log program output
 970   (if (and file (file-exists-p file))
 971       (save-excursion
 972         (let ((buf))
 973           (setq buf (get-buffer-create "*vc*"))
 974           (set-buffer buf))
 975         (apply 'vc-do-command 0 command file nil)
 976         (set-buffer-modified-p nil)
 977         (prog1
 978             (vc-parse-buffer patterns file properties)
 979           (kill-buffer (current-buffer))
 980           )
 981         )
 982     (if file
 983         (mapcar
 984          (function (lambda (p) (vc-file-setprop file p nil)))
 985          properties))
 986     )
 987   )
 988
 989 (defun vc-locking-user (file)
 990   "Return the name of the person currently holding a lock on FILE.
 991 Return nil if there is no such person."
 992   (if (or (not vc-keep-workfiles)
 993           (eq vc-mistrust-permissions 't)
 994           (and vc-mistrust-permissions
 995                (funcall vc-mistrust-permissions (vc-backend-subdirectory-name file))))
 996       (vc-true-locking-user file)
 997     ;; This implementation assumes that any file which is under version
 998     ;; control and has -rw-r--r-- is locked by its owner.  This is true
 999     ;; for both RCS and SCCS, which keep unlocked files at -r--r--r--.
1000     ;; We have to be careful not to exclude files with execute bits on;
1001     ;; scripts can be under version control too.  The advantage of this
1002     ;; hack is that calls to the very expensive vc-fetch-properties
1003     ;; function only have to be made if (a) the file is locked by someone
1004     ;; other than the current user, or (b) some untoward manipulation
1005     ;; behind vc's back has twiddled the `group' or `other' write bits.
1006     (let ((attributes (file-attributes file)))
1007       (cond ((string-match ".r-.r-.r-." (nth 8 attributes))
1008              nil)
1009             ((and (= (nth 2 attributes) (user-uid))
1010                   (string-match ".rw.r-.r-." (nth 8 attributes)))
1011              (user-login-name))
1012             (t
1013              (vc-true-locking-user file))))))
1014
1015 (defun vc-true-locking-user (file)
1016   ;; The slow but reliable version
1017   (vc-fetch-properties file)
1018   (vc-file-getprop file 'vc-locking-user))
1019
1020 (defun vc-latest-version (file)
1021   ;; Return version level of the latest version of FILE
1022   (vc-fetch-properties file)
1023   (vc-file-getprop file 'vc-latest-version))
1024
1025 (defun vc-your-latest-version (file)
1026   ;; Return version level of the latest version of FILE checked in by you
1027   (vc-fetch-properties file)
1028   (vc-file-getprop file 'vc-your-latest-version))
1029
1030 ;; Collect back-end-dependent stuff here
1031 ;;
1032 ;; Everything eventually funnels through these functions.  To implement
1033 ;; support for a new version-control system, add another branch to the
1034 ;; vc-backend-dispatch macro and fill it in in each call.  The variable
1035 ;; vc-master-templates in vc-hooks.el will also have to change.
1036
1037 (defmacro vc-backend-dispatch (f s r)
1038   "Execute FORM1 or FORM2 depending on whether we're using SCCS or RCS."
1039   (list 'let (list (list 'type (list 'vc-backend-deduce f)))
1040         (list 'cond
1041               (list (list 'eq 'type (quote 'SCCS)) s)   ;; SCCS
1042               (list (list 'eq 'type (quote 'RCS)) r)    ;; RCS
1043               )))
1044
1045 (defun vc-lock-file (file)
1046   ;; Generate lock file name corresponding to FILE
1047   (let ((master (vc-name file)))
1048     (and
1049      master
1050      (string-match "\\(.*/\\)s\\.\\(.*\\)" master)
1051      (concat
1052       (substring master (match-beginning 1) (match-end 1))
1053       "p."
1054       (substring master (match-beginning 2) (match-end 2))))))
1055
1056
1057 (defun vc-fetch-properties (file)
1058   ;; Re-fetch all properties associated with the given file.
1059   ;; Currently these properties are:
1060   ;;    vc-locking-user
1061   ;;    vc-locked-version
1062   ;;    vc-latest-version
1063   ;;    vc-your-latest-version
1064   (vc-backend-dispatch
1065    file
1066    ;; SCCS
1067    (progn
1068      (vc-master-info (vc-lock-file file)
1069                      (list
1070                       "^[^ ]+ [^ ]+ \\([^ ]+\\)"
1071                       "^\\([^ ]+\\)")
1072                      file
1073                      '(vc-locking-user vc-locked-version))
1074      (vc-master-info (vc-name file)
1075                   (list
1076                    "^\001d D \\([^ ]+\\)"
1077                    (concat "^\001d D \\([^ ]+\\) .* "
1078                            (regexp-quote (user-login-name)) " ")
1079                    )
1080                   file
1081                   '(vc-latest-version vc-your-latest-version))
1082      )
1083    ;; RCS
1084    (vc-log-info "rlog" file
1085                 (list
1086                  "^locks: strict\n\t\\([^:]+\\)"
1087                  "^locks: strict\n\t[^:]+: \\(.+\\)"
1088                  "^revision[\t ]+\\([0-9.]+\\).*\ndate: \\([ /0-9:]+\\);"
1089                  (concat
1090                   "^revision[\t ]+\\([0-9.]+\\)\n.*author: "
1091                   (regexp-quote (user-login-name))
1092                   ";"))
1093                 '(vc-locking-user vc-locked-version
1094                                   vc-latest-version vc-your-latest-version))
1095    ))
1096
1097 (defun vc-backend-subdirectory-name (&optional file)
1098   ;; Where the master and lock files for the current directory are kept
1099   (symbol-name
1100    (or
1101     (and file (vc-backend-deduce file))
1102     vc-default-back-end
1103     (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))))
1104
1105 (defun vc-backend-admin (file &optional rev comment)
1106   ;; Register a file into the version-control system
1107   ;; Automatically retrieves a read-only version of the file with
1108   ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise
1109   ;; it deletes the workfile.
1110   (vc-file-clearprops file)
1111   (or vc-default-back-end
1112       (setq vc-default-back-end (if (vc-find-binary "rcs") 'RCS 'SCCS)))
1113   (message "Registering %s..." file)
1114   (let ((backend
1115          (cond
1116           ((file-exists-p (vc-backend-subdirectory-name)) vc-default-back-end)
1117           ((file-exists-p "RCS") 'RCS)
1118           ((file-exists-p "SCCS") 'SCCS)
1119           (t vc-default-back-end))))
1120     (cond ((eq backend 'SCCS)
1121            (vc-do-command 0 "admin" file        ;; SCCS
1122                           (and rev (concat "-r" rev))
1123                           "-fb"
1124                           (concat "-i" file)
1125                           (and comment (concat "-y" comment))
1126                           (format
1127                            (car (rassq 'SCCS vc-master-templates))
1128                            (or (file-name-directory file) "")
1129                            (file-name-nondirectory file)))
1130            (delete-file file)
1131            (if vc-keep-workfiles
1132                (vc-do-command 0 "get" file)))
1133           ((eq backend 'RCS)
1134            (vc-do-command 0 "ci" file   ;; RCS
1135                           (concat (if vc-keep-workfiles "-u" "-r") rev)
1136                           (and comment (concat "-t-" comment))
1137                           file)
1138            )))
1139   (message "Registering %s...done" file)
1140   )
1141
1142 (defun vc-backend-checkout (file &optional writeable rev)
1143   ;; Retrieve a copy of a saved version into a workfile
1144   (message "Checking out %s..." file)
1145   (vc-backend-dispatch file
1146    (progn
1147      (vc-do-command 0 "get" file        ;; SCCS
1148                     (if writeable "-e")
1149                     (and rev (concat "-r" (vc-lookup-triple file rev))))
1150      )
1151    (vc-do-command 0 "co" file   ;; RCS
1152                   (if writeable "-l")
1153                   (and rev (concat "-r" rev)))
1154    )
1155   (vc-file-setprop file 'vc-checkout-time (nth 5 (file-attributes file)))
1156   (message "Checking out %s...done" file)
1157   )
1158
1159 (defun vc-backend-logentry-check (file)
1160   (vc-backend-dispatch file
1161    (if (>= (- (region-end) (region-beginning)) 512)     ;; SCCS
1162        (progn
1163          (goto-char 512)
1164          (error
1165           "Log must be less than 512 characters.  Point is now at char 512.")))
1166    nil)
1167   )
1168
1169 (defun vc-backend-checkin (file &optional rev comment)
1170   ;; Register changes to FILE as level REV with explanatory COMMENT.
1171   ;; Automatically retrieves a read-only version of the file with
1172   ;; keywords expanded if vc-keep-workfiles is non-nil, otherwise
1173   ;; it deletes the workfile.
1174   (message "Checking in %s..." file)
1175   (save-excursion
1176     ;; Change buffers to get local value of vc-checkin-switches.
1177     (set-buffer (or (get-file-buffer file) (current-buffer)))
1178     (vc-backend-dispatch file
1179       (progn
1180         (apply 'vc-do-command 0 "delta" file
1181                (if rev (concat "-r" rev))
1182                (concat "-y" comment)
1183                vc-checkin-switches)
1184         (if vc-keep-workfiles
1185             (vc-do-command 0 "get" file))
1186         )
1187       (apply 'vc-do-command 0 "ci" file
1188              (concat (if vc-keep-workfiles "-u" "-r") rev)
1189              (concat "-m" comment)
1190              vc-checkin-switches)
1191       ))
1192   (vc-file-setprop file 'vc-locking-user nil)
1193   (message "Checking in %s...done" file)
1194   )
1195
1196 (defun vc-backend-revert (file)
1197   ;; Revert file to latest checked-in version.
1198   (message "Reverting %s..." file)
1199   (vc-backend-dispatch
1200    file
1201    (progn                       ;; SCCS
1202      (vc-do-command 0 "unget" file nil)
1203      (vc-do-command 0 "get" file nil))
1204    (progn
1205      (delete-file file)         ;; RCS
1206      (vc-do-command 0 "co" file "-u")))
1207   (vc-file-setprop file 'vc-locking-user nil)
1208   (message "Reverting %s...done" file)
1209   )
1210
1211 (defun vc-backend-steal (file &optional rev)
1212   ;; Steal the lock on the current workfile.  Needs RCS 5.6.2 or later for -M.
1213   (message "Stealing lock on %s..." file)
1214   (progn
1215     (vc-do-command 0 "unget" file "-n" (if rev (concat "-r" rev)))
1216     (vc-do-command 0 "get" file "-g" (if rev (concat "-r" rev)))
1217     )
1218   (progn
1219     (vc-do-command 0 "rcs" "-M" (concat "-u" rev) file)
1220     (delete-file file)
1221     (vc-do-command 0 "rcs" (concat "-l" rev) file)
1222     )
1223   (vc-file-setprop file 'vc-locking-user (user-login-name))
1224   (message "Stealing lock on %s...done" file)
1225   )
1226
1227 (defun vc-backend-uncheck (file target)
1228   ;; Undo the latest checkin.  Note: this code will have to get a lot
1229   ;; smarter when we support multiple branches.
1230   (message "Removing last change from %s..." file)
1231   (vc-backend-dispatch file
1232    (vc-do-command 0 "rmdel" file (concat "-r" target))
1233    (vc-do-command 0 "rcs" file (concat "-o" target))
1234    )
1235   (message "Removing last change from %s...done" file)
1236   )
1237
1238 (defun vc-backend-print-log (file)
1239   ;; Print change log associated with FILE to buffer *vc*.
1240   (vc-do-command 0
1241                  (vc-backend-dispatch file "prs" "rlog")
1242                  file)
1243   )
1244
1245 (defun vc-backend-assign-name (file name)
1246   ;; Assign to a FILE's latest version a given NAME.
1247   (vc-backend-dispatch file
1248    (vc-add-triple name file (vc-latest-version file))   ;; SCCS
1249    (vc-do-command 0 "rcs" file (concat "-n" name ":"))  ;; RCS
1250    )
1251   )
1252
1253 (defun vc-backend-diff (file oldvers &optional newvers)
1254   ;; Get a difference report between two versions
1255   (if (eq (vc-backend-deduce file) 'SCCS)
1256       (setq oldvers (vc-lookup-triple file oldvers))
1257       (setq newvers (vc-lookup-triple file newvers)))
1258   (apply 'vc-do-command 1
1259          (or (vc-backend-dispatch file "vcdiff" "rcsdiff")
1260              (error "File %s is not under version control." file))
1261          file
1262          (and oldvers (concat "-r" oldvers))
1263          (and newvers (concat "-r" newvers))
1264          vc-diff-options
1265   ))
1266
1267 (defun vc-check-headers ()
1268   "Check if the current file has any headers in it."
1269   (interactive)
1270   (save-excursion
1271     (goto-char (point-min))
1272     (vc-backend-dispatch buffer-file-name
1273      (re-search-forward  "%[MIRLBSDHTEGUYFPQCZWA]%" nil t)      ;; SCCS
1274      (re-search-forward "\\$[A-Za-z\300-\326\330-\366\370-\377]+\\(: [\t -#%-\176\240-\377]*\\)?\\$" nil t)             ;; RCS
1275      )
1276     ))
1277
1278 ;; Back-end-dependent stuff ends here.
1279
1280 ;; Set up key bindings for use while editing log messages
1281
1282 (defun vc-log-mode ()
1283   "Minor mode for driving version-control tools.
1284 These bindings are added to the global keymap when you enter this mode:
1285 \\[vc-next-action]              perform next logical version-control operation on current file
1286 \\[vc-register]                 register current file
1287 \\[vc-toggle-read-only]         like next-action, but won't register files
1288 \\[vc-insert-headers]           insert version-control headers in current file
1289 \\[vc-print-log]                display change history of current file
1290 \\[vc-revert-buffer]            revert buffer to latest version
1291 \\[vc-cancel-version]           undo latest checkin
1292 \\[vc-diff]             show diffs between file versions
1293 \\[vc-directory]                show all files locked by any user in or below .
1294 \\[vc-update-change-log]                add change log entry from recent checkins
1295
1296 While you are entering a change log message for a version, the following
1297 additional bindings will be in effect.
1298
1299 \\[vc-finish-logentry]  proceed with check in, ending log message entry
1300
1301 Whenever you do a checkin, your log comment is added to a ring of
1302 saved comments.  These can be recalled as follows:
1303
1304 \\[vc-next-comment]     replace region with next message in comment ring
1305 \\[vc-previous-comment] replace region with previous message in comment ring
1306 \\[vc-search-comment-reverse]   search backward for regexp in the comment ring
1307 \\[vc-search-comment-forward]   search backward for regexp in the comment ring
1308
1309 Entry to the change-log submode calls the value of text-mode-hook, then
1310 the value of vc-log-mode-hook.
1311
1312 Global user options:
1313         vc-initial-comment      If non-nil, require user to enter a change
1314                                 comment upon first checkin of the file.
1315
1316         vc-keep-workfiles       Non-nil value prevents workfiles from being
1317                                 deleted when changes are checked in
1318
1319         vc-suppress-confirm     Suppresses some confirmation prompts,
1320                                 notably for reversions.
1321
1322         vc-diff-options         A list consisting of the flags
1323                                 to be used for generating context diffs.
1324
1325         vc-header-alist         Which keywords to insert when adding headers
1326                                 with \\[vc-insert-headers].  Defaults to
1327                                 '(\"\%\W\%\") under SCCS, '(\"\$Id\$\") under RCS.
1328
1329         vc-static-header-alist  By default, version headers inserted in C files
1330                                 get stuffed in a static string area so that
1331                                 ident(RCS) or what(SCCS) can see them in the
1332                                 compiled object code.  You can override this
1333                                 by setting this variable to nil, or change
1334                                 the header template by changing it.
1335
1336         vc-command-messages     if non-nil, display run messages from the
1337                                 actual version-control utilities (this is
1338                                 intended primarily for people hacking vc
1339                                 itself).
1340 "
1341   (interactive)
1342   (set-syntax-table text-mode-syntax-table)
1343   (use-local-map vc-log-entry-mode)
1344   (setq local-abbrev-table text-mode-abbrev-table)
1345   (setq major-mode 'vc-log-mode)
1346   (setq mode-name "VC-Log")
1347   (make-local-variable 'vc-log-file)
1348   (make-local-variable 'vc-log-version)
1349   (set-buffer-modified-p nil)
1350   (setq buffer-file-name nil)
1351   (run-hooks 'text-mode-hook 'vc-log-mode-hook)
1352 )
1353
1354 ;; Initialization code, to be done just once at load-time
1355 (if vc-log-entry-mode
1356     nil
1357   (setq vc-log-entry-mode (make-sparse-keymap))
1358   (define-key vc-log-entry-mode "\M-n" 'vc-next-comment)
1359   (define-key vc-log-entry-mode "\M-p" 'vc-previous-comment)
1360   (define-key vc-log-entry-mode "\M-r" 'vc-comment-search-backward)
1361   (define-key vc-log-entry-mode "\M-s" 'vc-comment-search-forward)
1362   (define-key vc-log-entry-mode "\C-c\C-c" 'vc-finish-logentry)
1363   )
1364
1365 ;;; These things should probably be generally available
1366
1367 (defun vc-shrink-to-fit ()
1368   "Shrink a window vertically until it's just large enough to contain its text"
1369   (let ((minsize (1+ (count-lines (point-min) (point-max)))))
1370     (if (< minsize (window-height))
1371         (let ((window-min-height 2))
1372           (shrink-window (- (window-height) minsize))))))
1373
1374 (defun vc-file-tree-walk (func &rest args)
1375   "Walk recursively through default directory,
1376 invoking FUNC f ARGS on all non-directory files f underneath it."
1377   (vc-file-tree-walk-internal default-directory func args)
1378   (message "Traversing directory %s...done" default-directory))
1379
1380 (defun vc-file-tree-walk-internal (file func args)
1381   (if (not (file-directory-p file))
1382       (apply func file args)
1383     (message "Traversing directory %s..." file)
1384     (let ((dir (file-name-as-directory file)))
1385       (mapcar
1386        (function
1387         (lambda (f) (or
1388                      (string-equal f ".")
1389                      (string-equal f "..")
1390                      (let ((dirf (concat dir f)))
1391                         (or
1392                          (file-symlink-p dirf) ;; Avoid possible loops
1393                          (vc-file-tree-walk-internal dirf func args))))))
1394        (directory-files dir)))))
1395
1396 (provide 'vc)
1397
1398 ;;; DEVELOPER'S NOTES ON CONCURRENCY PROBLEMS IN THIS CODE
1399 ;;;
1400 ;;; These may be useful to anyone who has to debug or extend the package.
1401 ;;;
1402 ;;; A fundamental problem in VC is that there are time windows between
1403 ;;; vc-next-action's computations of the file's version-control state and
1404 ;;; the actions that change it.  This is a window open to lossage in a
1405 ;;; multi-user environment; someone else could nip in and change the state
1406 ;;; of the master during it.
1407 ;;;
1408 ;;; The performance problem is that rlog/prs calls are very expensive; we want
1409 ;;; to avoid them as much as possible.
1410 ;;;
1411 ;;; ANALYSIS:
1412 ;;;
1413 ;;; The performance problem, it turns out, simplifies in practice to the
1414 ;;; problem of making vc-locking-user fast.  The two other functions that call
1415 ;;; prs/rlog will not be so commonly used that the slowdown is a problem; one
1416 ;;; makes snapshots, the other deletes the calling user's last change in the
1417 ;;; master.
1418 ;;;
1419 ;;; The race condition implies that we have to either (a) lock the master
1420 ;;; during the entire execution of vc-next-action, or (b) detect and
1421 ;;; recover from errors resulting from dispatch on an out-of-date state.
1422 ;;;
1423 ;;; Alternative (a) appears to be unfeasible.  The problem is that we can't
1424 ;;; guarantee that the lock will ever be removed.  Suppose a user starts a
1425 ;;; checkin, the change message buffer pops up, and the user, having wandered
1426 ;;; off to do something else, simply forgets about it?
1427 ;;;
1428 ;;; Alternative (b), on the other hand, works well with a cheap way to speed up
1429 ;;; vc-locking-user.  Usually, if a file is registered, we can read its locked/
1430 ;;; unlocked state and its current owner from its permissions.
1431 ;;;
1432 ;;; This shortcut will fail if someone has manually changed the workfile's
1433 ;;; permissions; also if developers are munging the workfile in several
1434 ;;; directories, with symlinks to a master (in this latter case, the
1435 ;;; permissions shortcut will fail to detect a lock asserted from another
1436 ;;; directory).
1437 ;;;
1438 ;;; Note that these cases correspond exactly to the errors which could happen
1439 ;;; because of a competing checkin/checkout race in between two instances of
1440 ;;; vc-next-action.
1441 ;;;
1442 ;;; For VC's purposes, a workfile/master pair may have the following states:
1443 ;;;
1444 ;;; A. Unregistered.  There is a workfile, there is no master.
1445 ;;;
1446 ;;; B. Registered and not locked by anyone.
1447 ;;;
1448 ;;; C. Locked by calling user and unchanged.
1449 ;;;
1450 ;;; D. Locked by the calling user and changed.
1451 ;;;
1452 ;;; E. Locked by someone other than the calling user.
1453 ;;;
1454 ;;; This makes for 25 states and 20 error conditions.  Here's the matrix:
1455 ;;;
1456 ;;; VC's idea of state
1457 ;;;  |
1458 ;;;  V  Actual state   RCS action              SCCS action          Effect
1459 ;;;    A  B  C  D  E
1460 ;;;  A .  1  2  3  4   ci -u -t-          admin -fb -i<file>      initial admin
1461 ;;;  B 5  .  6  7  8   co -l              get -e                  checkout
1462 ;;;  C 9  10 .  11 12  co -u              unget; get              revert
1463 ;;;  D 13 14 15 .  16  ci -u -m<comment>  delta -y<comment>; get  checkin
1464 ;;;  E 17 18 19 20 .   rcs -u -M ; rcs -l unget -n ; get -g       steal lock
1465 ;;;
1466 ;;; All commands take the master file name as a last argument (not shown).
1467 ;;;
1468 ;;; In the discussion below, a "self-race" is a pathological situation in
1469 ;;; which VC operations are being attempted simultaneously by two or more
1470 ;;; Emacsen running under the same username.
1471 ;;;
1472 ;;; The vc-next-action code has the following windows:
1473 ;;;
1474 ;;; Window P:
1475 ;;;    Between the check for existence of a master file and the call to
1476 ;;; admin/checkin in vc-buffer-admin (apparent state A).  This window may
1477 ;;; never close if the initial-comment feature is on.
1478 ;;;
1479 ;;; Window Q:
1480 ;;;    Between the call to vc-workfile-unchanged-p in and the immediately
1481 ;;; following revert (apparent state C).
1482 ;;;
1483 ;;; Window R:
1484 ;;;    Between the call to vc-workfile-unchanged-p in and the following
1485 ;;; checkin (apparent state D).  This window may never close.
1486 ;;;
1487 ;;; Window S:
1488 ;;;    Between the unlock and the immediately following checkout during a
1489 ;;; revert operation (apparent state C).  Included in window Q.
1490 ;;;
1491 ;;; Window T:
1492 ;;;    Between vc-locking-user and the following checkout (apparent state B).
1493 ;;;
1494 ;;; Window U:
1495 ;;;    Between vc-locking-user and the following revert (apparent state C).
1496 ;;; Includes windows Q and S.
1497 ;;;
1498 ;;; Window V:
1499 ;;;    Between vc-locking-user and the following checkin (apparent state
1500 ;;; D).  This window may never be closed if the user fails to complete the
1501 ;;; checkin message.  Includes window R.
1502 ;;;
1503 ;;; Window W:
1504 ;;;    Between vc-locking-user and the following steal-lock (apparent
1505 ;;; state E).  This window may never cloce if the user fails to complete
1506 ;;; the steal-lock message.  Includes window X.
1507 ;;;
1508 ;;; Window X:
1509 ;;;    Between the unlock and the immediately following re-lock during a
1510 ;;; steal-lock operation (apparent state E).  This window may never cloce
1511 ;;; if the user fails to complete the steal-lock message.
1512 ;;;
1513 ;;; Errors:
1514 ;;;
1515 ;;; Apparent state A ---
1516 ;;;
1517 ;;; 1. File looked unregistered but is actually registered and not locked.
1518 ;;;
1519 ;;;    Potential cause: someone else's admin during window P, with
1520 ;;; caller's admin happening before their checkout.
1521 ;;;
1522 ;;;    RCS: ci will fail with a "no lock set by <user>" message.
1523 ;;;    SCCS: admin will fail with error (ad19).
1524 ;;;
1525 ;;;    We can let these errors be passed up to the user.
1526 ;;;
1527 ;;; 2. File looked unregistered but is actually locked by caller, unchanged.
1528 ;;;
1529 ;;;    Potential cause: self-race during window P.
1530 ;;;
1531 ;;;    RCS: will revert the file to the last saved version and unlock it.
1532 ;;;    SCCS: will fail with error (ad19).
1533 ;;;
1534 ;;;    Either of these consequences is acceptable.
1535 ;;;
1536 ;;; 3. File looked unregistered but is actually locked by caller, changed.
1537 ;;;
1538 ;;;    Potential cause: self-race during window P.
1539 ;;;
1540 ;;;    RCS: will register the caller's workfile as a delta with a
1541 ;;; null change comment (the -t- switch will be ignored).
1542 ;;;    SCCS: will fail with error (ad19).
1543 ;;;
1544 ;;; 4. File looked unregistered but is locked by someone else.
1545 ;;;
1546 ;;;    Potential cause: someone else's admin during window P, with
1547 ;;; caller's admin happening *after* their checkout.
1548 ;;;
1549 ;;;    RCS: will fail with a "no lock set by <user>" message.
1550 ;;;    SCCS: will fail with error (ad19).
1551 ;;;
1552 ;;;    We can let these errors be passed up to the user.
1553 ;;;
1554 ;;; Apparent state B ---
1555 ;;;
1556 ;;; 5. File looked registered and not locked, but is actually unregistered.
1557 ;;;
1558 ;;;    Potential cause: master file got nuked during window P.
1559 ;;;
1560 ;;;    RCS: will fail with "RCS/<file>: No such file or directory"
1561 ;;;    SCCS: will fail with error ut4.
1562 ;;;
1563 ;;;    We can let these errors be passed up to the user.
1564 ;;;
1565 ;;; 6. File looked registered and not locked, but is actually locked by the
1566 ;;; calling user and unchanged.
1567 ;;;
1568 ;;;    Potential cause: self-race during window T.
1569 ;;;
1570 ;;;    RCS: in the same directory as the previous workfile, co -l will fail
1571 ;;; with "co error: writable foo exists; checkout aborted".  In any other
1572 ;;; directory, checkout will succeed.
1573 ;;;    SCCS: will fail with ge17.
1574 ;;;
1575 ;;;    Either of these consequences is acceptable.
1576 ;;;
1577 ;;; 7. File looked registered and not locked, but is actually locked by the
1578 ;;; calling user and changed.
1579 ;;;
1580 ;;;    As case 6.
1581 ;;;
1582 ;;; 8. File looked registered and not locked, but is actually locked by another
1583 ;;; user.
1584 ;;;
1585 ;;;    Potential cause: someone else checks it out during window T.
1586 ;;;
1587 ;;;    RCS: co error: revision 1.3 already locked by <user>
1588 ;;;    SCCS: fails with ge4 (in directory) or ut7 (outside it).
1589 ;;;
1590 ;;;    We can let these errors be passed up to the user.
1591 ;;;
1592 ;;; Apparent state C ---
1593 ;;;
1594 ;;; 9. File looks locked by calling user and unchanged, but is unregistered.
1595 ;;;
1596 ;;;    As case 5.
1597 ;;;
1598 ;;; 10. File looks locked by calling user and unchanged, but is actually not
1599 ;;; locked.
1600 ;;;
1601 ;;;    Potential cause: a self-race in window U, or by the revert's
1602 ;;; landing during window X of some other user's steal-lock or window S
1603 ;;; of another user's revert.
1604 ;;;
1605 ;;;    RCS: succeeds, refreshing the file from the identical version in
1606 ;;; the master.
1607 ;;;    SCCS: fails with error ut4 (p file nonexistent).
1608 ;;;
1609 ;;;    Either of these consequences is acceptable.
1610 ;;;
1611 ;;; 11. File is locked by calling user.  It looks unchanged, but is actually
1612 ;;; changed.
1613 ;;;
1614 ;;;    Potential cause: the file would have to be touched by a self-race
1615 ;;; during window Q.
1616 ;;;
1617 ;;;    The revert will succeed, removing whatever changes came with
1618 ;;; the touch.  It is theoretically possible that work could be lost.
1619 ;;;
1620 ;;; 12. File looks like it's locked by the calling user and unchanged, but
1621 ;;; it's actually locked by someone else.
1622 ;;;
1623 ;;;    Potential cause: a steal-lock in window V.
1624 ;;;
1625 ;;;    RCS: co error: revision <rev> locked by <user>; use co -r or rcs -u
1626 ;;;    SCCS: fails with error un2
1627 ;;;
1628 ;;;    We can pass these errors up to the user.
1629 ;;;
1630 ;;; Apparent state D ---
1631 ;;;
1632 ;;; 13. File looks like it's locked by the calling user and changed, but it's
1633 ;;; actually unregistered.
1634 ;;;
1635 ;;;    Potential cause: master file got nuked during window P.
1636 ;;;
1637 ;;;    RCS: Checks in the user's version as an initial delta.
1638 ;;;    SCCS: will fail with error ut4.
1639 ;;;
1640 ;;;    This case is kind of nasty.  It means VC may fail to detect the
1641 ;;; loss of previous version information.
1642 ;;;
1643 ;;; 14. File looks like it's locked by the calling user and changed, but it's
1644 ;;; actually unlocked.
1645 ;;;
1646 ;;;    Potential cause: self-race in window V, or the checkin happening
1647 ;;; during the window X of someone else's steal-lock or window S of
1648 ;;; someone else's revert.
1649 ;;;
1650 ;;;    RCS: ci will fail with "no lock set by <user>".
1651 ;;;    SCCS: delta will fail with error ut4.
1652 ;;;
1653 ;;; 15. File looks like it's locked by the calling user and changed, but it's
1654 ;;; actually locked by the calling user and unchanged.
1655 ;;;
1656 ;;;    Potential cause: another self-race --- a whole checkin/checkout
1657 ;;; sequence by the calling user would have to land in window R.
1658 ;;;
1659 ;;;    SCCS: checks in a redundant delta and leaves the file unlocked as usual.
1660 ;;;    RCS: reverts to the file state as of the second user's checkin, leaving
1661 ;;; the file unlocked.
1662 ;;;
1663 ;;;    It is theoretically possible that work could be lost under RCS.
1664 ;;;
1665 ;;; 16. File looks like it's locked by the calling user and changed, but it's
1666 ;;; actually locked by a different user.
1667 ;;;
1668 ;;;    RCS: ci error: no lock set by <user>
1669 ;;;    SCCS: unget will fail with error un2
1670 ;;;
1671 ;;;    We can pass these errors up to the user.
1672 ;;;
1673 ;;; Apparent state E ---
1674 ;;;
1675 ;;; 17. File looks like it's locked by some other user, but it's actually
1676 ;;; unregistered.
1677 ;;;
1678 ;;;    As case 13.
1679 ;;;
1680 ;;; 18. File looks like it's locked by some other user, but it's actually
1681 ;;; unlocked.
1682 ;;;
1683 ;;;    Potential cause: someone released a lock during window W.
1684 ;;;
1685 ;;;    RCS: The calling user will get the lock on the file.
1686 ;;;    SCCS: unget -n will fail with cm4.
1687 ;;;
1688 ;;;    Either of these consequences will be OK.
1689 ;;;
1690 ;;; 19. File looks like it's locked by some other user, but it's actually
1691 ;;; locked by the calling user and unchanged.
1692 ;;;
1693 ;;;    Potential cause: the other user relinquishing a lock followed by
1694 ;;; a self-race, both in window W.
1695 ;;;
1696 ;;;     Under both RCS and SCCS, both unlock and lock will succeed, making
1697 ;;; the sequence a no-op.
1698 ;;;
1699 ;;; 20. File looks like it's locked by some other user, but it's actually
1700 ;;; locked by the calling user and changed.
1701 ;;;
1702 ;;;     As case 19.
1703 ;;;
1704 ;;; PROBLEM CASES:
1705 ;;;
1706 ;;;    In order of decreasing severity:
1707 ;;;
1708 ;;;    Cases 11 and 15 under RCS are the only one that potentially lose work.
1709 ;;; They would require a self-race for this to happen.
1710 ;;;
1711 ;;;    Case 13 in RCS loses information about previous deltas, retaining
1712 ;;; only the information in the current workfile.  This can only happen
1713 ;;; if the master file gets nuked in window P.
1714 ;;;
1715 ;;;    Case 3 in RCS and case 15 under SCCS insert a redundant delta with
1716 ;;; no change comment in the master.  This would require a self-race in
1717 ;;; window P or R respectively.
1718 ;;;
1719 ;;;    Cases 2, 10, 19 and 20 do extra work, but make no changes.
1720 ;;;
1721 ;;;    Unfortunately, it appears to me that no recovery is possible in these
1722 ;;; cases.  They don't yield error messages, so there's no way to tell that
1723 ;;; a race condition has occurred.
1724 ;;;
1725 ;;;    All other cases don't change either the workfile or the master, and
1726 ;;; trigger command errors which the user will see.
1727 ;;;
1728 ;;;    Thus, there is no explicit recovery code.
1729
1730 ;;; vc.el ends here