;;;; rcs.el - RCS interface for GNU Emacs.

;; Originally written by James J. Elliott <elliott@cs.wisc.edu>
;; Rewritten by Sebastian Kremer <sk@thp.uni-koeln.de>.

;; Copyright (C) 1990 James J. Elliott
;; Copyright (C) 1991 Sebastian Kremer

;; This program 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 1, or (at your option)
;; any later version.
;;
;; This program 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 this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

;; LISPDIR ENTRY for the Elisp Archive ===============================
;;    LCD Archive Entry:
;;    rcs|Sebastian Kremer|sk@thp.uni-koeln.de
;;    |RCS interface for GNU Emacs
;;    |$Date: 1992/02/10 10:29:26 $|$Revision: 1.55 $|

;; INSTALLATION ======================================================
;;
;; Put this file into your load-path and the following in your ~/.emacs:
;;
;;   (load "rcs")

;; USAGE =============================================================

;; C-x C-q to make an RCS-controlled file writable by checking it out locked
;; C-c I   * check in
;; C-c O   * check out without locking, C-u C-c O checkout locked
;; C-c U   unlock (revert to last checked-in version, flushing changes)
;; C-c D   * rcsdiff
;; C-c L   * rlog
;; C-c S   * show or set rcs status
;; C-c W   rcswho (list of lockers of all files in a directory)
;;
;; C-x C-f on a non-existent working file will offer to check it out from RCS

;; Prefix arg to commands marked with * lets you edit the switches,
;; making it very flexible (e.g. to check in new branches or with
;; specified revision numbers [-uREV, -lREV], or even in case the file
;; didn't change [-f]).

;; Read the manual for more info.

(defconst rcs-version  (substring "$Revision: 1.55 $" 11 -2)
  "$Id: rcs.el,v 1.55 1992/02/10 10:29:26 sk Exp $

Report bugs to: Sebastian Kremer <sk@thp.uni-koeln.de>

Available for anonymous FTP from
     ftp.cs.buffalo.edu:pub/Emacs/rcs.tar.Z
and
     ftp.uni-koeln.de:/pub/gnu/emacs/rcs.tar.Z")


;; Customization variables

(defvar rcs-bind-keys t
  "If nil, rcs.el will not bind any keys.
Has to be set before rcs.el is loaded.")

(defvar rcs-active t
  "*If non-nil, RCS controlled files are treated specially by Emacs.")

(defvar rcs-ange-ftp-ignore t
  "*If non-nil, remote ange-ftp files are never considered RCS controlled.
This saves a lot of time for slow connections.")

(defvar rcsdiff-switches nil
  "*If non-nil, a string specifying switches to be be passed to rcsdiff.
A list of strings (or nil) means that the commandline can be edited
after inserting those strings.")

(defvar rcs-default-co-switches nil
  "List of switches (strings) for co(1) to use on every `rcs-check-out'.")

(defvar rcs-default-ci-switches nil
  "List of switches (strings) for ci(1) to use on every `rcs-check-in'.
You can use the `-f' switch to force new revision with RCS 5.6 even if
the file did not change.")

(defvar rcs-default-rlog-switches nil
  "List of switches (strings) for rlog(1) to use on every `rcs-log'.")
 
(defvar rcs-read-log-function nil
  "*If non-nil, function of zero args to read an RCS log message.
If nil, log messages are read from the minibuffer.
Possible value: 'rcs-read-log-string-with-recursive-edit.")

;; End of customization variables

;; Buffer-local modeline variables, and hooking into Emacs.

(defvar rcs-mode nil
  "If non-nil, the current buffer's file is RCS-controlled:

If the emptry string, it is unlocked, and the modeline display the
head revision number.

Else it is a string of lockers as returned by function `rcs-status',
which is displayed in the modeline, in the format LOCKER:REV.")

(defvar rcs-mode-string nil)		; for use in modeline

;; In case you are using Joe Well's kill-fix.el, available from the
;; Elisp archive archive.cis.ohio-state.edu:pub/gnu/emacs/elisp-archive/,
;; this will prevent killing rcs modeline variables in a major mode change:
(put 'rcs-mode 'preserved t)
(put 'rcs-mode-string 'preserved t)

;; Tell Emacs about this new kind of minor mode
(if (not (assoc 'rcs-mode minor-mode-alist))
    (progn
      (setq minor-mode-alist (cons '(rcs-mode rcs-mode-string)
				   minor-mode-alist))
      ;; make-variable-buffer-local also initializes to nil (in 18.55),
      ;; but we better don't rely on this since it is not documented.
      (set-default (make-variable-buffer-local 'rcs-mode) nil)
      (set-default (make-variable-buffer-local 'rcs-mode-string) nil)))

(defun rcs-file-not-found ()
  ;; If current buffer's file is RCS controlled, check it out.
  ;; Called when find-file has not been able to find the specified file.
  ;; Return t if found, nil else for use as hook.
  (and rcs-active
       (rcs-status buffer-file-name)
       ;; No good asking user here since he shouldn't create a
       ;; new empty file when there is actually an RCS file for it.
       (rcs-check-out
	buffer-file-name
	(and (y-or-n-p "Check out writable and locked for editing? ")
	     '("-l")))
       ;; Indicate if file was found so that other not-found hooks
       ;; aren't run in that case
       t))

;; Install the above routine, making it the first hook
(or (memq 'rcs-file-not-found find-file-not-found-hooks)
      (setq find-file-not-found-hooks
            (cons 'rcs-file-not-found find-file-not-found-hooks)))

(defun rcs-status (fname &optional switches)
  "Returns the locker and version of this file if it is locked, an empty
string if it is not locked, and nil if it is not an RCS controlled file.
If several lockers, they are returned as one string, separated by SPC.

With a prefix arg, set the status instead of querying it.  This works
by passing the prompted-for SWITCHES to the `rcs' program."
  (interactive
   (list (rcs-read-file-name (concat (if current-prefix-arg "Set" "Query")
				     " RCS status of: "))
	 (and current-prefix-arg
	      (rcs-read-switches "Switches for rcs: "))))
  (setq fname (expand-file-name fname))
  (if switches
      (let ((output-buffer (rcs-get-output-buffer fname)))
	(save-excursion
	  (set-buffer output-buffer)
	  (apply 'call-process "rcs" nil t nil
		 (append switches (list "-q" fname)))
	  (if (> (buffer-size) 0)
	      (rcs-error "rcs" fname output-buffer))))
    (let (rname status head)
      (if (and rcs-ange-ftp-ignore
	       (fboundp 'ange-ftp-ftp-path)
	       (ange-ftp-ftp-path fname))
	  (setq status nil)		; remote file not considered for RCS
	(setq rname (rcs-data-file fname))
	(if rname
	    ;; parse contents of the RCS (`,v') file
	    (save-excursion
	      (set-buffer (rcs-get-output-buffer rname " *RCS-temp*"))
	      (insert-file-contents rname nil)
	      (goto-char (point-min))
	      (setq status
		    (if (re-search-forward "^locks[ \t\n\r\f]+\\([^;]*\\)" nil t)
			(save-restriction ;; ^J in `rcs-mode-string' looks ugly
			  (narrow-to-region (match-beginning 1) (match-end 1))
			  (goto-char (point-min))
			  (while (re-search-forward "[ \t\n\r\f]+" nil t)
			    (replace-match " " t t))
			  (buffer-string))
		      ""))
	      (goto-char (point-min))
	      (if (re-search-forward "^head[ \t\n\r\f]+\\([0-9.]+\\)")
		  (setq head (buffer-substring (match-beginning 1)
					       (match-end 1))))
	      ;; more useful information could be gleaned here
	      (erase-buffer)))
	(if (interactive-p)
	    (cond ((null status)
		   (message "Not an RCS-controlled file: %s" fname))
		  ((equal "" status)
		   (message "No current locker for %s" fname))
		  (t
		   (message "%s -- %s" fname status)))))
      ;; See if the STATUS we just computed so hard can be used to
      ;; update a buffer's modeline:
      (let ((buffer (get-file-buffer fname)))
	(and buffer
	     (save-excursion
	       (set-buffer buffer)
	       (rcs-set-modeline status head))))
      status)))

(defun rcs-we-locked (fname &optional status)
  ;; Return non-nil if current user has a lock on the specified file.
  ;; Value returned is the revision level that is locked (as string).
  ;; Optional 2nd arg STATUS precomputed value of (rcs-status FNAME)
  ;; can be passed for efficiency.
  (or status (setq status (rcs-status fname)))
  (and status;; STATUS is "" or string of lockers
       (string-match (concat (regexp-quote (user-login-name))
			     ":[ \t\n]*\\([0-9.]+\\)")
		     status)
       (substring status (match-beginning 1) (match-end 1))))

(defun rcs-load-postprocessor ()
  "Peeks at files after they are loaded to see if they merit special
treatment by virtue of being active RCS files.

You can also call this interactively to refresh the modeline, e.g.
after a major mode change that killed all local variables."
  (interactive)
  ;; If rcs-active is nil, the buffer local variables below stay nil.
  (and rcs-active
       buffer-file-name
       ;; this will also set the modeline:
       (rcs-status buffer-file-name)))

(defun rcs-set-modeline (status &optional head)
  ;; Set modeline of current buffer according to STATUS (see `rcs-status').
  ;; If non-nil, HEAD is the head revision to be displayed in case of
  ;; an unlocked file.  If HEAD is not given, just "RCS" is displayed.
  (setq rcs-mode status
	rcs-mode-string (and status
			     (if (equal "" status);; unlocked but under RCS
				 (if head
				     ;;(concat " RCS " head)
				     (concat " " head)
				   " RCS")
			       (concat " " status)))))

;; Install above routine
(or (memq 'rcs-load-postprocessor find-file-hooks)
      (setq find-file-hooks
            (cons 'rcs-load-postprocessor find-file-hooks)))


;; RCS utility functions

(defun rcs-read-switches (prompt &optional default)
  ;; Read a list of switches (strings), prompting with PROMPT.
  ;; User enters a single string, a space-separated list of switches.
  ;; Split on whitespace and return list of strings.
  ;; So it would not be possible to include whitespace in a switch
  ;; unless we hadn't added the escape to line mode if just a single
  ;; SPC is entered.
  (let ((answer (read-string prompt default))
	(beg 0)
	end result switch)
    (if (equal " " answer)
	(rcs-read-switches-allowing-space prompt default)
      (while (setq end (string-match "[ \t]+" answer beg))
	(setq switch (substring answer beg end)
	      beg (match-end 0))
	(or (equal "" switch)
	    (setq result (cons switch result))))
      (setq switch (substring answer beg))
      (or (equal "" switch)
	  (setq result (cons switch result)))
      (nreverse result))))

(defun rcs-read-switches-allowing-space (prompt &optional default)
  ;; Read switches, each separately, thus allowing whitespace.
  ;; DEFAULT is ignored.
  (let (answer result done (count 0))
    (while (not done)
      (setq answer (read-string
		    (concat prompt
			    "(#"
			    (int-to-string (setq count (1+ count)))
			    ", just RET for last) "))
	    done (equal "" answer))
      (or done (setq result (cons answer result))))
    (nreverse result)))

(defun rcs-read-file-name (prompt)
  ;; Read a file name prompting with PROMPT.
  ;; Default is current buffer's file, if any.
  (if buffer-file-name
      (let ((dir (file-name-nondirectory buffer-file-name)))
	(read-file-name (format (concat prompt "(default %s) ") dir)
			nil
			dir))
    (read-file-name prompt)))

(defun rcs-read-log-string (prompt)
  (if rcs-read-log-function
      (funcall rcs-read-log-function)
    (read-string prompt)))

(defun rcs-read-log-string-with-recursive-edit ()
  "Useful as value of `rcs-read-log-function'."
  (let ((buffer (get-buffer-create "*RCS log message*")))
    (save-window-excursion
      (switch-to-buffer buffer)
      ;;?(erase-buffer)
      (with-output-to-temp-buffer "*Help*"
	(princ (substitute-command-keys
		"\
Enter the RCS log message.
Type \\[mark-whole-buffer] \\[kill-region] to kill old entry.
Type \\[exit-recursive-edit] when finished editing or \\[abort-recursive-edit] to abort.")))
      (recursive-edit)
      (buffer-string))))

(defun rcs-revert-buffer (&optional arg no-confirm)
  ;; Revert buffer, try to keep point where user expects it in spite
  ;; of changes because of expanded RCS key words.
  ;; This is quite important since otherwise typeahead won't work as expected.
  (interactive "P")
  (widen)
  (let* ((opoint (point))
	 (osize (buffer-size))
	 (obobp (bobp))
	 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 (obobp
	   (goto-char (point-min)))
	  ((equal "" ostring)		; i.e., originally at eob
	   (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 rcs-refresh-buffer (filename)
  ;; Revert FILENAME's buffer from disk.
  (let ((output-buffer (get-file-buffer filename))
	(obuf (current-buffer)))
    (if output-buffer
	;; Can't use save-excursion here, want to move point inside
	;; rcs-revert-buffer
	(unwind-protect
	    (progn
	      (set-buffer output-buffer)
	      (rcs-revert-buffer t t))
	  (set-buffer obuf)))))

(defun rcs-get-output-buffer (file &optional name)
  ;; Get a buffer for RCS output for FILE, make it writable and clean it up.
  ;; Optional NAME is name to use instead of `*RCS-output*'.
  (let* ((default-major-mode 'fundamental-mode);; no frills!
	 (buf (get-buffer-create (or name "*RCS-output*"))))
    (save-excursion
      (set-buffer buf)
      (setq buffer-read-only nil
	    default-directory (file-name-directory (expand-file-name file)))
      (erase-buffer))
    buf))

(defun rcs-error (program fname buffer)
  ;; Display BUFFER (contains output from failed commmand) and signal
  ;; an RCS error.
  (display-buffer buffer)
  (error "RCS command `%s' failed on %s" program fname))


;; Functions that know about RCS working and data files.
;; If the `,v' extension etc. ever changes, here is the place to fix it.

(defun rcs-data-file (filename)
  "Return the name of the RCS data file for FILENAME, or nil."
  (setq filename (expand-file-name filename))
  ;; Try first `RCS/FILENAME,v', then `FILENAME,v'.
  ;; In RCS 5.6 should also try `RCS/FILENAME' as last possibility, or look
  ;; at the rcs -x extension option or RCSINIT environment variable.
  (let ((rname (concat (file-name-directory filename) "RCS/"
		       (file-name-nondirectory filename) ",v")))
    (or (file-readable-p rname)
	(setq rname (concat filename ",v")))
    (and (file-readable-p rname)
	 rname)))

;; here unused, but other packages need it (e.g dired-rcs.el)
(defun rcs-working-file (filename)
  "Convert an RCS file name to a working file name.
That is, convert `...foo,v' and `...RCS/foo,v' to `...foo'.
If FILENAME doesn't end in `,v' it is returned unchanged."
  (if (not (string-match ",v$" filename))
      filename
    (setq filename (substring filename 0 -2))
    (let ((dir (file-name-directory filename)))
      (if (null dir)
	  filename
	(let ((dir-file (directory-file-name dir)))
	  (if (equal "RCS" (file-name-nondirectory dir-file))
	      ;; Working file for ./RCS/foo,v is ./foo.
	      ;; Don't use expand-file-name as this converts "" -> pwd
	      ;; and thus forces a relative FILENAME to be relative to
	      ;; the current value of default-directory, which may not
	      ;; what the caller wants.  Besides, we want to change
	      ;; FILENAME only as much as necessary.
	      (concat (file-name-directory dir-file)
		      (file-name-nondirectory filename))
	    filename))))))

(defun rcs-files (directory)
  "Return list of RCS data files for all RCS controlled files in DIRECTORY."
  (setq directory (file-name-as-directory directory))
  (let ((rcs-dir (file-name-as-directory (expand-file-name "RCS" directory)))
	(rcs-files (directory-files directory t ",v$")))
    (if (file-directory-p rcs-dir)
	(setq rcs-files
	      (append (directory-files rcs-dir t ",v$")
		      rcs-files)))
    rcs-files))

;; here unused, but other packages need it (e.g dired-rcs.el)
(defun rcs-locked-files (directory)
  "Return list of RCS data file names of all RCS-locked files in DIRECTORY."
  (let ((output-buffer (rcs-get-output-buffer directory))
	(rcs-files (rcs-files directory))
	result)
    (and rcs-files
	 (save-excursion
	   (set-buffer output-buffer)
	   (apply (function call-process) "rlog" nil t nil "-L" "-R" rcs-files)
	   (goto-char (point-min))
	   (while (not (eobp))
	     (setq result (cons (buffer-substring (point)
						  (progn (forward-line 1)
							 (1- (point))))
				result)))
	   result))))


;; Operations on RCS-controlled files (check in, check out, logs, etc.)

(defun rcs-check-out (filename &optional switches)
  "Attempt to check the specified file out using RCS.
If a prefix argument is supplied, will let you edit the `co' switches
used, defaulting to \"-l\" to check out locked.
Use \"-rREV\" or \"-lREV\" to check out specific revisions."
  ;; Returns non-nil for success, signals an error else.
  (interactive (list (rcs-read-file-name "Check out file: ")
		     (and current-prefix-arg
			  (rcs-read-switches "Switches for co: " "-l"))))
  (message "Working...")
  (setq filename (expand-file-name filename))
  (let ((output-buffer (rcs-get-output-buffer filename)))
    (delete-windows-on output-buffer)
    (save-excursion
      (set-buffer output-buffer)
      (apply 'call-process "co" nil t nil
	     ;; -q: quiet (no diagnostics)
	     (append switches rcs-default-co-switches (list "-q" filename)))
      (if (or (not (file-readable-p filename))
	      (> (buffer-size) 0))
	  (rcs-error "co" filename output-buffer)))
    (rcs-refresh-buffer filename))
  (message ""))

(defun rcs-check-in (filename log &optional switches)
  "Attempt to check the specified file back in using RCS.
If a prefix argument is supplied, will let you edit the `ci' switches used,
with default \"-l\" switch to keep file locked.
Use \"-uREV\" or \"-lREV\" to check in as specific revision."
  (interactive (list (rcs-read-file-name "Check in file: ")
		     (rcs-read-log-string "Log message: ")
		     (and current-prefix-arg
			  (rcs-read-switches "Switches for ci: " "-l"))))
  (setq filename (expand-file-name filename))
  (setq switches (cons "-u" switches))
  ;; A "-l" in SWITCHES will override this "-u", so we can
  ;; unconditionally prepend it to SWITCHES.  We always need an
  ;; existing working file, to have something to put in the buffer
  ;; afterwards.
  (let* ((output-buffer (rcs-get-output-buffer filename))
	 (f-buffer (get-file-buffer filename)))
    (and (interactive-p)
	 f-buffer
	 (buffer-modified-p f-buffer)
	 (not (and (y-or-n-p "Save buffer first? ")
		   (save-excursion
		     (set-buffer f-buffer)
		     (save-buffer)
		     t)))
	 (not (y-or-n-p "Check in despite unsaved changes to file? "))
	 (error "Check-in aborted"))
    (message "Working...")
    (delete-windows-on output-buffer)
    (save-excursion
      (set-buffer output-buffer)
      (setq log (concat "-m" log))	; -m: log message, -q: quiet
      (apply 'call-process "ci" nil t nil
	     (append switches rcs-default-ci-switches (list log "-q" filename)))
      (if (> (buffer-size) 0)
	  (rcs-error "ci" filename output-buffer)))
    (rcs-refresh-buffer filename))
  (message ""))

(defun rcs-unlock (filename)
  "Attempt to remove your RCS lock on the specified file.
Requires confirmation if there are changes since the last checkin."
  (interactive (list (rcs-read-file-name "Unlock RCS file: ")))
  (setq filename (expand-file-name filename))
  (if (not (rcs-we-locked filename))
      (error "File was not locked to begin with"))
  (let* ((output-buffer (rcs-get-output-buffer filename))
	 (f-buffer (get-file-buffer filename))
	 (modified nil))
    ;;See if they've made any changes to the file. If so, double-check that
    ;;they want to discard them.
    (setq modified (and f-buffer (buffer-modified-p f-buffer)))
    (delete-windows-on output-buffer)
    (save-excursion
      (set-buffer output-buffer)
      (message "Examining file...")
      (call-process "rcsdiff" nil t nil filename)
      (goto-char (point-min))
      (re-search-forward "^diff +-r.*$")
      (forward-char 1)			;Skip past command itself
      (delete-region (point-min) (point)) ;Get rid of all but results
      (if modified			;There are changes to the buffer itself too.
	  (progn
	    (goto-char (point-max))
	    (insert "\nThere are unsaved changes to the buffer itself!\n"))
	(setq modified (< (point) (point-max))))
      (message "")
      (if modified
	  (display-buffer output-buffer))
      (if (and modified (not (yes-or-no-p;; not y-or-n-p since this
			      ;; gives a chance to use M-C-v to look at
			      ;; the diffs.  Also, it is safer.
			      "Discard changes made since file locked? ")))
	  (error "Unlock aborted"))
      (erase-buffer)			; clean up output buffer
      ;; -u: unlock, -q: quiet
      (call-process "rcs" nil t nil "-u" "-q" filename)
      (if (> (buffer-size) 0)
	  (rcs-error "rcs" filename output-buffer))))
  ;; Finally, check out a current copy.
  ;; -f: overwrite working file, even if it is writable (as it probably is)
  (rcs-check-out filename '("-f")))

(defun rcs-toggle-read-only ()
  "If the buffer is read-only and under RCS, adjust RCS status.
That is, make buffer writable and check file out locked for editing."
  (interactive)
  (if (and rcs-active
	   rcs-mode
	   buffer-read-only
	   buffer-file-name
	   (not (rcs-we-locked buffer-file-name rcs-mode)))
      (if (y-or-n-p "Check buffer out from RCS for edit? ")
	  (if (and (file-exists-p buffer-file-name)
		   (file-writable-p buffer-file-name))
	      (if (yes-or-no-p "\
Illegally writable copy of RCS controlled file - force checkout anyway? ")
		  (rcs-check-out buffer-file-name '("-f" "-l"))
		(error "Illegally writable copy of RCS controlled file %s"
		       buffer-file-name))
	    ;; Try to get a locked version. May error.
	    (rcs-check-out buffer-file-name '("-l")))
	(if (y-or-n-p
	     "File is RCS controlled - make buffer writable anyway? ")
	    (toggle-read-only)		; this also updates the modeline
	  (barf-if-buffer-read-only)))
    (toggle-read-only))
  (message ""))

(defun rcs-log (fname &optional switches)
  "Show the RCS log of changes for the specified file.
With an arg you can pass additional switches to the `rlog' program."
  (interactive (list (rcs-read-file-name "Show RCS log of: ")
		     (and current-prefix-arg
			  (rcs-read-switches "Switches for rlog: "))))
  (setq fname (expand-file-name fname))
  (if (not (rcs-status fname))
      (error "File is not under RCS control"))
  (save-excursion
    (let ((output-buffer (rcs-get-output-buffer fname)))
      (set-buffer output-buffer)
      (message "Requesting log...")
      (apply 'call-process "rlog" nil t nil
	     (append switches rcs-default-rlog-switches (list fname)))
      (goto-char (point-min))
      (message "")
      (display-buffer output-buffer))))

(defun rcs-diff (fname &optional switches)
  "Show the differences between current file and the last revision checked in.
With prefix arg, edit the `rcsdiff' commandline.
See also variable `rcsdiff-switches'."
  (interactive
   (list (rcs-read-file-name "Show RCS diffs for: ")
	 (if (or current-prefix-arg (listp rcsdiff-switches))
	     (rcs-read-switches "Switches for rcsdiff: "
				(if (stringp rcsdiff-switches)
				    rcsdiff-switches
				  (if (listp rcsdiff-switches)
				      (mapconcat 'identity rcsdiff-switches " ")
				    ""))))))
  (setq fname (expand-file-name fname))
  (if (not (rcs-status fname))
      (error "File is not under RCS control"))
  (or switches
      (setq switches (if (listp rcsdiff-switches)
			 rcsdiff-switches
		       (list rcsdiff-switches))))
  (let ((output-buffer (rcs-get-output-buffer fname))
	(f-buffer (get-file-buffer fname)))
    (if (and (interactive-p)
	     f-buffer
	     (buffer-modified-p f-buffer)
	     (y-or-n-p "Save file before comparing? "))
	(save-buffer))
    (save-excursion
    (set-buffer output-buffer)
    (message "Comparing files...")
    (apply 'call-process "rcsdiff" nil t nil
	   (append switches (list fname)))
    (message "Comparing files...done")
    (goto-char (point-max))		; shell-command does not drag point
    (insert (make-string 67 ?=) "\n")
    (goto-char (point-min))
    (display-buffer output-buffer))))

(defun rcs-who (directory)
  "Display list of RCS-locked files and their lockers in DIRECTORY."
  (interactive "DRcswho (directory): ")
  (or directory (setq directory default-directory))
  (setq directory (expand-file-name directory))
  (setq directory (file-name-as-directory directory))
  (let ((rcs-files (rcs-files directory)))
    (if (null rcs-files)
	(message "No RCS controlled files in %s" directory)
      (rcs-who-1 directory rcs-files))))

(defun rcs-who-1 (directory rcs-files)
  ;; Parse `rlog -L -h' output for `Working file:' and
  ;; `locks:' fields, flush the other fields.  The remaining rlog
  ;; output is presented to the user.
  ;; The -R and -L options are also understood by RCS 3 and 4, though
  ;; the output format is slightly different.  This code parses both
  ;; formats, but the output is slightly different in the case of
  ;; several lockers per file:  in V5, each locker gets a separate line.
  (save-excursion
    (let ((output-buffer (rcs-get-output-buffer directory "*RCS-who*")))
      ;; Name OUTPUT-BUFFER different from the usual RCS output buffers
      ;; since user may want to keep it around a while.  Else each RCS
      ;; command would flush it.
      (set-buffer output-buffer)
      (message "rcs-who %s..." directory)
      (apply 'call-process "rlog" nil t nil
	     "-L" "-h"			; -L: locked only, -h: head only
	     ;;"-V3" ; use this to test the code for older RCS versions
	     rcs-files)
      (goto-char (point-min))
      (if (and (not (zerop (buffer-size)))
	       (not (search-forward "Working file" nil t)))
	  (progn
	    (display-buffer output-buffer)
	    (error "Rlog error")))
      (goto-char (point-min))
      (let ((pos (point)))
	(while (re-search-forward "Working file: *" nil t)
	  (delete-region pos (point))	; flush anything before filename
	  (end-of-line 1)
	  (insert "\t")
	  (setq pos (point))
	  (if (re-search-forward "locks:[ \t\n]*\\(strict[ \t\n]*\\)?" nil t)
	      (progn
		(delete-region pos (point)))
	    (display-buffer output-buffer)
	    (error "Cannot parse this rlog format"))
	  ;; Now skip over the list of lockers.  In V5 this will be one
	  ;; line per locker, in V3 and V4 all lockers will be on the
	  ;; same line.
	  ;; In V5 the (optional) `strict' token comes before the list
	  ;; of lockers (we have already skipped over it and use the
	  ;; `access list' token as delimiter).
	  ;; In V3,4 the `strict' token comes after the list of lockers
	  ;; (skip over it now, if present).
	  ;; In any case, the `access list' terminates the lockers.
	  (re-search-forward ";[ \t\n]*strict\\|\naccess list:")
	  (goto-char (match-beginning 0))
	  (insert "\n")
	  ;; set POS so that next iteration will flush from here on
	  (setq pos (point)))
	(delete-region pos (point-max)))
      (message "")
      (if (/= 0 (buffer-size))
	  (display-buffer output-buffer)
	(message "No files locked in %s" directory)))))

;; Parsing RCS data files directly is too slow and too hard on Emacs' memory
;; usage.  A single invocation of rcs-status is OK, but not on a whole
;; directory.

;; (defun rcs-who-1-slow (directory rcs-files)
;;   (let ((output-buffer (rcs-get-output-buffer directory))
;; 	file status)
;;     (save-excursion
;;       (set-buffer output-buffer)
;;       (let (buffer-read-only)
;; 	(while rcs-files
;; 	  (setq file (car rcs-files)
;; 		rcs-files (cdr rcs-files)
;; 		status (rcs-status file))
;; 	  (if (> (length status) 0)
;; 	      (insert file
;; 		      "\t"
;; 		      status
;; 		      "\n"))))
;;       (display-buffer output-buffer))))

(if (null rcs-bind-keys)
    nil
  ;; Local maps will override this, since C-c is usually a local prefix.
  (global-set-key "\C-cD" 'rcs-diff)
  (global-set-key "\C-cI" 'rcs-check-in)
  (global-set-key "\C-cL" 'rcs-log)
  (global-set-key "\C-cO" 'rcs-check-out)
  (global-set-key "\C-cS" 'rcs-status)
  (global-set-key "\C-cU" 'rcs-unlock)
  (global-set-key "\C-cW" 'rcs-who)
  (global-set-key "\C-x\C-q" 'rcs-toggle-read-only))

(provide 'rcs)
(provide 'rcs-sk)			; there are so many RCS packages...