Initial revision

lisp/vc-hooks.el

+;;; vc-hooks.el -- resident support for version-control
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Version: 4.0
+
+;;	$Id: vc-hooks.el,v 1.44 1992/07/31 06:43:05 esr Exp $	
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; See the commentary of vc.el.
+
+;;; Code:
+
+(defvar vc-master-templates
+  '(("%sRCS/%s,v" . RCS) ("%s%s,v" . RCS) ("%sRCS/%s" . RCS)
+    ("%sSCCS/s.%s" . SCCS) ("%ss.%s". SCCS))
+  "*Where to look for version-control master files.
+The first pair corresponding to a given back end is used as a template
+when creating new masters.")
+
+(defvar vc-make-backup-files nil
+  "*If non-nil, backups of registered files are made according to
+the make-backup-files variable.  Otherwise, prevents backups being made.")
+
+;; Tell Emacs about this new kind of minor mode
+(if (not (assoc 'vc-mode-string minor-mode-alist))
+    (setq minor-mode-alist (cons '(vc-mode-string vc-mode-string)
+				 minor-mode-alist)))
+
+(make-variable-buffer-local 'vc-mode-string)
+
+;; We need a notion of per-file properties because the version
+;; control state of a file is expensive to derive --- we don't
+;; want to recompute it even on every find.
+
+(defvar vc-file-prop-obarray [0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]
+  "Obarray for per-file properties.")
+
+(defun vc-file-setprop (file property value)
+  ;; set per-file property
+  (put (intern file vc-file-prop-obarray) property value))
+
+(defun vc-file-getprop (file property)
+  ;; get per-file property
+  (get (intern file vc-file-prop-obarray) property))
+
+;;; actual version-control code starts here
+
+(defun vc-registered (file)
+  ;; Search for a master corresponding to the given file
+  (let ((dirname (or (file-name-directory file) ""))
+	(basename (file-name-nondirectory file)))
+    (catch 'found
+      (mapcar
+       (function (lambda (s)
+	  (let ((trial (format (car s) dirname basename)))
+	    (if (and (file-exists-p trial)
+		     ;; Make sure the file we found with name
+		     ;; TRIAL is not the source file itself.
+		     ;; That can happen with RCS-style names
+		     ;; if the file name is truncated
+		     ;; (e.g. to 14 chars).  See if either
+		     ;; directory or attributes differ.
+		     (or (not (string= dirname
+				       (file-name-directory trial)))
+			 (not (equal
+			       (file-attributes file)
+			       (file-attributes trial)))))
+		(throw 'found (cons trial (cdr s)))))))
+       vc-master-templates)
+      nil)
+    ))
+
+(defun vc-backend-deduce (file)
+  "Return the version-control type of a file, nil if it is not registered"
+  (and file
+       (or (vc-file-getprop file 'vc-backend)
+	   (vc-file-setprop file 'vc-backend (cdr (vc-registered file))))))
+
+(defun vc-toggle-read-only ()
+  "If the file in the current buffer id under version control, perform the
+logical next version-control action; otherwise, just toggle the buffer's
+read-only flag."
+  (interactive)
+  (if (vc-backend-deduce (buffer-file-name))
+      (vc-next-action nil)
+    (toggle-read-only)))
+
+(defun vc-mode-line (file &optional label)
+  "Set `vc-mode-string' to display type of version control for FILE.
+The value is set in the current buffer, which should be the buffer
+visiting FILE."
+  (let ((vc-type (vc-backend-deduce file)))
+    (if vc-type
+	(progn
+	  (if (null (current-local-map))
+	      (use-local-map (make-sparse-keymap)))
+	  (define-key (current-local-map) "\C-x\C-q" 'vc-toggle-read-only)
+	  (setq vc-mode-string
+		(concat " " (or label (symbol-name vc-type))))))
+    ;; force update of mode line
+    (set-buffer-modified-p (buffer-modified-p))
+    vc-type))
+
+;;; install a call to the above as a find-file hook
+(defun vc-find-file-hook ()
+  (if (and (vc-mode-line buffer-file-name) (not vc-make-backup-files))
+      (progn
+	(make-local-variable 'make-backup-files)
+	(setq make-backup-files nil))))
+
+(or (memq 'vc-find-file-hook find-file-hooks)
+    (setq find-file-hooks
+	  (cons 'vc-find-file-hook find-file-hooks)))
+
+;;; more hooks, this time for file-not-found
+(defun vc-file-not-found-hook ()
+  "When file is not found, try to check it out from RCS or SCCS.
+Returns t if checkout was successful, nil otherwise."
+  (if (vc-backend-deduce buffer-file-name)
+      (progn
+	(require 'vc)
+	(not (vc-error-occurred (vc-checkout buffer-file-name))))))
+
+(or (memq 'vc-file-not-found-hook find-file-not-found-hooks)
+    (setq find-file-not-found-hooks
+	  (cons 'vc-file-not-found-hook find-file-not-found-hooks)))
+
+;;; Now arrange for bindings and autoloading of the main package.
+;;; Bindings for this have to go in the global map, as it may have
+;;; to coexist with a lot of different major modes.
+
+(setq vc-prefix-map (lookup-key global-map "\C-xv"))
+(if (not (keymapp vc-prefix-map))
+    (progn
+      (setq vc-prefix-map (make-sparse-keymap))
+      (define-key global-map "\C-xv" vc-prefix-map)
+      (define-key vc-prefix-map "a" 'vc-update-change-log)
+      (define-key vc-prefix-map "c" 'vc-cancel-version)
+      (define-key vc-prefix-map "d" 'vc-diff)
+      (define-key vc-prefix-map "h" 'vc-insert-headers)
+      (define-key vc-prefix-map "i" 'vc-register)
+      (define-key vc-prefix-map "l" 'vc-print-log)
+      (define-key vc-prefix-map "r" 'vc-retrieve-snapshot)
+      (define-key vc-prefix-map "s" 'vc-create-snapshot)
+      (define-key vc-prefix-map "u" 'vc-revert-buffer)
+      (define-key vc-prefix-map "v" 'vc-next-action)
+      (define-key vc-prefix-map "=" 'vc-directory)
+      ))
+
+(autoload 'vc-update-change-log "vc.el" nil t)
+(autoload 'vc-cancel-version "vc.el" nil t)
+(autoload 'vc-diff "vc.el" nil t)
+(autoload 'vc-insert-headers "vc.el" nil t)
+(autoload 'vc-register "vc.el" nil t)
+(autoload 'vc-print-log "vc.el" nil t)
+(autoload 'vc-retrieve-snapshot "vc.el" nil t)
+(autoload 'vc-creat-snapshot "vc.el" nil t)
+(autoload 'vc-directory "vc.el" nil t)
+(autoload 'vc-revert-buffer "vc.el" nil t)
+(autoload 'vc-next-action "vc.el" nil t)
+
+(provide 'vc-hooks)
+
+;;; vc-hooks.el ends here

lisp/vc.el

+;;; vc.el --- drive a version-control system from within Emacs
+
+;; Copyright (C) 1992 Free Software Foundation, Inc.
+
+;; Author: Eric S. Raymond <esr@snark.thyrsus.com>
+;; Version: 4.0
+
+;;	$Id: vc.el,v 1.58 1992/07/31 07:17:21 esr Exp $	
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This was designed and implemented by Eric Raymond <esr@snark.thyrsus.com>.
+;; Paul Eggert <eggert@twinsun.com>, Sebastian Kremer <sk@thp.uni-koeln.de>,
+;; and Richard Stallman contributed valuable criticism, support, and testing.
+;;
+;; Supported version-control systems presently include SCCS and RCS;
+;; your RCS version should be 5.6.2 or later for proper operation of
+;; the lock-breaking code.
+;;
+;; The RCS code assumes strict locking.  You can support the RCS -x option
+;; by adding pairs to the vc-master-templates list.
+;;
+;; Proper function of the SCCS diff commands requires the shellscript vcdiff
+;; to be installed somewhere on Emacs's path for executables.
+;;
+;; This code depends on call-process passing back the subprocess exit
+;; status.  Thus, you need Emacs 18.58 or later to run it.
+;;
+;; The vc code maintains some internal state in order to reduce expensive
+;; version-control operations to a minimum.  Some names are only computed
+;; once. If you perform version control operations with RCS/SCCS/CVS while
+;; vc's back is turned, or move/rename master files while vc is running,
+;; vc may get seriously confused.  Don't do these things!
+;;
+;; Developer's notes on some concurrency issues are included at the end of
+;; the file.
+
+;;; Code:
+
+(require 'vc-hooks)
+
+;; General customization
+
+(defvar vc-default-back-end nil
+  "*Back-end actually used by this interface; may be SCCS or RCS.
+The value is only computed when needed to avoid an expensive search.")
+(defvar vc-diff-options '("-a" "-c1")
+  "*The command/flags list to be used in constructing diff commands.")
+(defvar vc-suppress-confirm nil
+  "*If non-nil, reat user as expert; suppress yes-no prompts on some things.")
+(defvar vc-keep-workfiles t
+  "*If non-nil, don't delete working files after registering changes.")
+(defvar vc-initial-comment nil
+  "*Prompt for initial comment when a file is registered.")
+(defvar vc-command-messages nil
+  "*Display run messages from back-end commands.")
+(defvar vc-mistrust-permissions 'file-symlink-p
+  "*Don't assume that permissions and ownership track version-control status.")
+
+;; Header-insertion hair
+
+(defvar vc-header-alist
+  '((SCCS "\%W\%") (RCS "\$Id\$"))
+  "*Header keywords to be inserted when vc-insert-header is executed.")
+(defconst vc-static-header-alist
+  '(("\\.c$" .
+     "\n#ifndef lint\nstatic char vcid[] = \"\%s\";\n#endif /* lint */\n"))
+  "*Associate static header string templates with file types.  A \%s in the
+template is replaced with the first string associated with the file's
+verson-control type in vc-header-strings.")
+(defvar vc-comment-alist
+  '((nroff-mode ".\\\"" ""))
+  "*Special comment delimiters to be used in generating vc headers only.
+Add an entry in this list if you need to override the normal comment-start
+and comment-end variables.  This will only be necessary if the mode language
+is sensitive to blank lines.")
+
+;; Variables the user doesn't need to know about.
+(defvar vc-log-entry-mode nil)
+(defvar vc-log-operation nil)
+
+(defconst vc-name-assoc-file "VC-names")
+
+(defmacro vc-error-occurred (&rest body)
+  (list 'condition-case nil (cons 'progn (append body '(nil))) '(error t)))
+
+;; File property caching
+
+(defun vc-file-clearprops (file)
+  ;; clear all properties of a given file
+  (setplist (intern file vc-file-prop-obarray) nil))
+
+;; Random helper functions
+
+(defun vc-name (file)
+  "Return the master name of a file, nil if it is not registered"
+  (or (vc-file-getprop file 'vc-name)
+      (vc-file-setprop file 'vc-name
+		       (let ((name-and-type (vc-registered file)))
+			 (and name-and-type (car name-and-type))))))
+
+(defvar vc-binary-assoc nil)
+
+(defun vc-find-binary (name)
+  "Look for a command anywhere on the subprocess-command search path."
+  (or (cdr (assoc name vc-binary-assoc))
+      (let ((full nil))
+	(catch 'found
+	  (mapcar
+	   (function (lambda (s)
+	      (if (and s (file-exists-p (setq full (concat s "/" name))))
+		  (throw 'found nil))))
+	  exec-path))
+	(if full
+	    (setq vc-binary-assoc (cons (cons name full) vc-binary-assoc)))
+	full)))
+
+(defun vc-do-command (okstatus command file &rest flags)
+  "Execute a version-control command, notifying user and checking for errors.
+The command is successful if its exit status does not exceed OKSTATUS.
+Output from COMMAND goes to buffer *vc*.  The last argument of the command is
+the master name of FILE; this is appended to an optional list of FLAGS."
+  (setq file (expand-file-name file))
+  (if vc-command-messages
+      (message (format "Running %s on %s..." command file)))
+  (let ((obuf (current-buffer))
+	(squeezed nil)
+	(vc-file (and file (vc-name file)))
+	status)
+    (set-buffer (get-buffer-create "*vc*"))
+    (erase-buffer)
+    (mapcar
+     (function (lambda (s) (and s (setq squeezed (append squeezed (list s))))))
+     flags)
+    (if vc-file
+	(setq squeezed (append squeezed (list vc-file))))
+    (let
+	((default-directory (file-name-directory (or file "./"))))
+      (setq status (apply 'call-process command nil t nil squeezed))
+      )
+    (goto-char (point-max))
+    (previous-line 1)
+    (if (or (not (integerp status)) (< okstatus status))
+	(progn
+	  (previous-line 1)
+	  (print (cons command squeezed))
+	  (next-line 1)
+	  (pop-to-buffer "*vc*")
+	  (vc-shrink-to-fit)
+	  (goto-char (point-min))
+	  (error (format "Running %s...FAILED (%s)" command
+			 (if (integerp status)
+			     (format "status %d" status)
+			   status)))
+	  )
+      (if vc-command-messages
+	  (message (format "Running %s...OK" command)))
+      )
+    (set-buffer obuf)
+    status)
+  )
+
+(defun vc-revert-buffer1 (&optional arg no-confirm)
+  ;; This code was shamelessly lifted from Sebastian Kremer's rcs.el mode.
+  ;; Revert buffer, try to keep point where user expects it in spite
+  ;; of changes because of expanded version-control key words.
+  ;; This is quite important since otherwise typeahead won't work as expected.
+  (interactive "P")
+  (widen)
+  (let* ((opoint (point))
+	 (osize (buffer-size))
+	 diff
+	 (context 100)
+	 (ostring (buffer-substring (point)
+				    (min (point-max)
+					 (+ (point) context))))
+	 (l (length ostring)))
+    (revert-buffer arg no-confirm)
+    (setq diff (- osize (buffer-size)))
+    (if (< diff 0) (setq diff (- diff)))
+    (goto-char opoint)
+    (cond ((equal "" ostring)
+	   (goto-char (point-max)))
+	  ((or (search-forward ostring nil t)
+	       ;; Can't use search-backward since the match may continue
+	       ;; after point.
+	       (progn (goto-char (- (point) diff l))
+		      ;; goto-char doesn't signal an error at
+		      ;; beginning of buffer like backward-char would
+		      (search-forward ostring nil t)))
+	   ;; to beginning of OSTRING
+	   (backward-char l)))))
+
+(defun vc-buffer-sync ()
+  ;; Make sure the current buffer and its working file are in sync
+  (if (and (buffer-modified-p)
+	   (or
+	    vc-suppress-confirm
+	    (y-or-n-p (format "%s has been modified.  Write it out? "
+			      (buffer-name)))))
+      (save-buffer)))
+
+(defun vc-workfile-unchanged-p (file)
+  ;; Has the given workfile changed since last checkout?
+  (let ((checkout-time (vc-file-getprop file 'vc-checkout-time))
+	(lastmod (nth 5 (file-attributes file))))
+    (if checkout-time
+     (equal lastmod checkout-time)
+     (if (zerop (vc-backend-diff file nil))
+	 (progn
+	   (vc-file-setprop file 'vc-checkout-time lastmod)
+	   t)
+       (progn
+	   (vc-file-setprop file 'vc-checkout-time '(0 . 0))
+	   nil
+	 ))
+     )))
+
+;; Here's the major entry point
+
+(defun vc-next-action (verbose)
+  "Do the next logical checkin or checkout operation on the current file.
+   If the file is not already registered, this registers it for version
+control and then retrieves a writeable, locked copy for editing.
+   If the file is registered and not locked by anyone, this checks out
+a writeable and locked file ready for editing.
+   If the file is checked out and locked by the calling user, this
+first checks to see if the file has changed since checkout.  If not,
+it performs a revert.
+   If the file has been changed, this pops up a buffer for creation of
+a log message; when the message has been entered, it checks in the
+resulting changes along with the log message as change commentary.  If
+the variable vc-keep-workfiles is non-nil (which is its default), a
+read-only copy of the changed file is left in place afterwards.
+   If the file is registered and locked by someone else, you are given
+the option to steal the lock."
+  (interactive "P")
+  (if buffer-file-name
+      (let
+	  (do-update owner version
+		     (file buffer-file-name)
+		     (vc-file (vc-name buffer-file-name))
+		     (err-msg nil)
+		     owner)
+
+	(cond
+
+	 ;; if there is no master file corresponding, create one
+	 ((not vc-file)
+	  (vc-register verbose)
+	  (vc-next-action verbose))
+
+	 ;; if there is no lock on the file, assert one and get it
+	 ((not (setq owner (vc-locking-user file)))
+	  (vc-checkout file t))
+
+	 ;; a checked-out version exists, but the user may not own the lock
+	 ((not (string-equal owner (user-login-name)))
+	  (vc-steal-lock
+	   file
+	   (and verbose (read-string "Version to steal: "))
+	   owner))
+
+	 ;; OK, user owns the lock on the file
+	 (t (progn
+
+	      ;; give luser a chance to save before checking in.
+	      (vc-buffer-sync)
+
+	      ;; revert if file is unchanged
+	      (if (vc-workfile-unchanged-p file)
+		  (progn
+		    (vc-backend-revert file)
+		    (vc-resynch-window file t))
+
+		;; user may want to set nonstandard parameters
+		(if verbose
+		    (setq version (read-string "New version level: ")))
+
+		;; OK, let's do the checkin
+		(vc-checkin file version))))))
+    (error "There is no file associated with buffer %s" (buffer-name))))
+
+;;; These functions help the vc-next-action entry point
+
+(defun vc-register (&optional override)
+  "Register the current file into your version-control system."
+  (interactive "P")
+  (if (vc-name buffer-file-name)
+      (error "This file is already registered."))
+  (vc-buffer-sync)
+  (vc-admin
+   buffer-file-name
+   (and override (read-string "Initial version level: ")))
+  )
+
+(defun vc-resynch-window (file &optional keep)
+  ;; If the given file is in the current buffer,
+  ;; either revert on it so we see expanded keyworks,
+  ;; or unvisit it (depending on vc-keep-workfiles)
+  (and (string= buffer-file-name file)
+       (if keep
+	   (progn
+	     (vc-revert-buffer1 nil t)
+	     (vc-mode-line buffer-file-name))
+	 (progn
+	   (delete-window)
+	   (kill-buffer (current-buffer))))))
+
+
+(defun vc-admin (file rev)
+  "Checks a file into your version-control system.
+FILE is the unmodified name of the file.  REV should be the base version
+level to check it in under."
+  (if vc-initial-comment
+      (progn
+	(pop-to-buffer (get-buffer-create "*VC-log*"))
+	(vc-log-mode)
+	(narrow-to-region (point-max) (point-max))
+	(vc-mode-line file (file-name-nondirectory file))
+	(setq vc-log-operation 'vc-backend-admin)
+	(setq vc-log-file file)
+	(setq vc-log-version rev)
+	(message "Enter initial comment.  Type C-c C-c when done."))
+    (progn
+      (vc-backend-admin file rev)
+      (vc-resynch-window file vc-keep-workfiles))))
+
+(defun vc-steal-lock (file rev &optional owner)
+  "Steal the lock on the current workfile."
+  (interactive)
+  (if (not owner)
+      (setq owner (vc-locking-user file)))
+  (if (not (y-or-n-p (format "Take the lock on %s:%s from %s?" file rev owner)))
+      (error "Steal cancelled."))
+  (pop-to-buffer (get-buffer-create "*VC-log*"))
+  (vc-log-mode)
+  (narrow-to-region (point-max) (point-max))
+  (insert
+   (format "To: %s\n\nI stole the lock on %s:%s, " owner file rev)
+   (current-time-string)
+   "\n")
+  (vc-mode-line file (file-name-nondirectory file))
+  (setq vc-log-operation 'vc-finish-steal)
+  (setq vc-log-file file)
+  (setq vc-log-version rev)
+  (message "Please explain why you stole the lock.  Type C-c C-c when done.")
+  )
+
+(defun vc-finish-steal (file version)
+  ;; Actually do the lock acquisition; send the former owner a notification
+  (vc-backend-steal file version)
+  (require 'sendmail)	;; (send-mail) isn't on the standard autoload list.
+  (mail-send)
+  (vc-resynch-window file t)
+  )
+
+(defun vc-checkout (file &optional writeable)
+  "Retrieve a copy of the latest version of the given file."
+  (vc-backend-checkout file writeable)
+  (if (string-equal file buffer-file-name)
+      (vc-resynch-window file t))
+  )
+
+(defun vc-checkin (file &optional rev comment)
+  "Check in the file specified by FILE.
+The optional argument REV may be a string specifying the new version level
+(if nil increment the current level).  The file is either retained with write
+permissions zeroed, or deleted (according to the value of vc-keep-workfiles).
+COMMENT is a comment string; if omitted, a buffer is
+popped up to accept a comment."
+  (pop-to-buffer (get-buffer-create "*VC-log*"))
+  (vc-log-mode)
+  (narrow-to-region (point-max) (point-max))
+  (vc-mode-line file (file-name-nondirectory file))
+  (setq vc-log-operation 'vc-backend-checkin)
+  (setq vc-log-file file)
+  (setq vc-log-version rev)
+  (message "Enter log message.  Type C-c C-c when done.")
+  (if comment
+      (progn
+	(insert comment)
+	(vc-finish-logentry))))
+
+(defun vc-finish-logentry ()
+  "Complete the operation implied by the current log entry."
+  (interactive)
+  (goto-char (point-max))
+  (if (not (bolp)) (newline))
+  ;; delimit current page
+  (save-excursion
+    (widen)
+    (goto-char (point-max))
+    (if (and (not (bobp)) (not (= (char-after (1- (point))) ?\f)))
+	(insert-char ?\f 1)))
+  (if (not (bobp))
+      (forward-char -1))
+  (mark-page)
+  ;; Check for errors
+  (vc-backend-logentry-check vc-log-file)
+  ;; OK, do it to it
+  (if vc-log-operation
+      (funcall vc-log-operation 
+	       vc-log-file
+	       vc-log-version
+	       (buffer-substring (region-beginning) (1- (region-end))))
+    (error "No log operation is pending."))
+  ;; Return to "parent" buffer of this checkin and remove checkin window
+  (pop-to-buffer (get-file-buffer vc-log-file))
+  (delete-window (get-buffer-window "*VC-log*"))
+  (bury-buffer "*VC-log*")
+  ;; Now make sure we see the expanded headers
+  (vc-resynch-window buffer-file-name vc-keep-workfiles)
+  )
+
+;; Code for access to the comment ring
+
+(defun vc-next-comment ()
+  "Fill the log buffer with the next message in the msg ring."
+  (interactive)
+  (widen)
+  (forward-page)
+  (if (= (point) (point-max))
+      (goto-char (point-min)))
+  (mark-page)
+  (narrow-to-page))
+
+(defun vc-previous-comment ()
+  "Fill the log buffer with the previous message in the msg ring."
+  (interactive)
+  (widen)
+  (if (= (point) (point-min))
+      (goto-char (point-max)))
+  (backward-page)