Commit 594722a8 authored by Eric S. Raymond's avatar Eric S. Raymond
Browse files

Initial revision

parent 54a0539a
;;; 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
;;; 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)