;;; yaya.lcs.mit.edu:/u/sra/yaf-rcs.el, 1-Sep-1990 23:17:05, sra ;;; ;;; Yet another RCS interface, hopefully more complete. ;;; ;;; Ideas for this code, where not original, are from previous RCS packages: ;;; dired-rcs.el, by Christopher B. Liebman ; ;;; autoco.el, by Tim Shepard ; ;;; rcs.el, by James Elliott . ;; Basic function for invoking RCS commands in quiet mode. (defun rcs-exec (command filename &optional version &rest options) "Execute an RCS command in quiet mode." (setq options (nconc (rcs-version version) options)) (let (buffer) (unwind-protect (save-excursion (setq filename (expand-file-name filename)) (set-buffer (setq buffer (get-buffer-create " rcs-errors"))) (erase-buffer) (let ((default-directory (or (file-name-directory filename) default-directory))) (apply 'call-process command nil t nil "-q" (nconc (delq nil options) (list filename)))) (or (zerop (buffer-size)) (error (buffer-string)))) (if buffer (kill-buffer buffer))))) ;; Basic function for invoking RCS commands that do produce output. (defun rcs-view (command filename &optional version &rest options) "Execute an RCS command with output to a buffer, then view that buffer." (setq options (nconc (rcs-version version) options)) (let (buffer) (unwind-protect (save-window-excursion (setq filename (expand-file-name filename)) (setq buffer (get-buffer-create (concat command ": " (file-name-nondirectory filename)))) (set-buffer buffer) (erase-buffer) (let ((default-directory (or (file-name-directory filename) default-directory))) (apply 'call-process command nil t nil (nconc (delq nil options) (list filename)))) (goto-char (point-min)) (view-buffer buffer)) (if buffer (kill-buffer buffer))))) ;;; Basic function for parsing RCS version strings. Has some hair to ;;; interpret various forms of prefix arguments. (defun rcs-version (version) "Prompt the user for an RCS version string and check it, if necessary." (cond ((or (null version) (stringp version)) (list version)) ((and (consp version) (= 16 (car version))) (let ((v1 (read-string "Version 1: ")) (v2 (read-string "Version 2: "))) (list (and (not (equal "" v1)) (concat "-r" v1)) (and (not (equal "" v2)) (concat "-r" v2))))) ((consp version) (let ((v1 (read-string "Version: "))) (list (and (not (equal "" v1)) (concat "-r" v1))))) ((numberp version) (list (format "-r%d" version))) (t (error "Version argument must be number or string")))) ;;; Basic function to check for existence of an RCS file. (defun rcs-file (working-file) (let ((rcs-file (concat working-file ",v"))) (if (file-exists-p rcs-file) rcs-file (setq rcs-file (concat (file-name-directory working-file) "RCS/" (file-name-nondirectory working-file) ",v")) (and (file-exists-p rcs-file) rcs-file)))) ;;; Basic function to revert a buffer that is visiting a file we ;;; just modified with an RCS command, maybe. (defun rcs-maybe-revert-buffer (filename) (let ((buffer (get-file-buffer filename))) (and buffer (or (not (buffer-modified-p buffer)) (yes-or-no-p (format "%s HAS BEEN MODIFIED. Read it from disk anyway? " filename))) ;; Don't use (save-excursion) here, it screws up (revert-buffer)'s ;; attempts to leave point `unchanged.' (let ((previous-buffer (current-buffer))) (set-buffer buffer) (let ((point (point))) (revert-buffer t t) (goto-char (min point (point-max)))) (set-buffer previous-buffer))))) ;;; Basic function to save buffers visiting files that we're about to ;;; modify with RCS, maybe. (defun rcs-maybe-save-buffer (filename) (let ((buffer (get-file-buffer filename))) (and buffer (buffer-modified-p buffer) (y-or-n-p (format "Save %s? " filename)) (save-excursion (set-buffer buffer) (save-buffer))))) ;; Commands (defvar rcs-co-locked nil "If nil, rcs-co will not lock files it checks out.") (defun rcs-co (filename &optional version) "Check out latest version of a file from RCS. See variable rcs-co-locked." (interactive "FCheckout file from RCS: "\nP) (rcs-exec "co" filename version (and rcs-co-locked "-l")) (rcs-maybe-revert-buffer filename)) (defun rcs-lock (filename &optional version) "Lock the latest revision of an RCS file." (interactive "FLock RCS file: \nP") (rcs-exec "rcs" filename version "-l")) (defun rcs-unlock (filename &optional version) "Unlock latest revision of an RCS file." (interactive "FUnlock RCS file: \nP") (rcs-exec "rcs" filename version "-u")) (defun rcs-view-log (filename &optional version) "View the RCS log for a file." (interactive "FView log for RCS file: \nP") (rcs-view "rlog" filename version)) (defun rcs-diff (filename &optional version) "Diff current working file against the last checked-in RCS version." (interactive "FDiff changes since last check-in for file: \nP") (rcs-maybe-save-buffer filename) (rcs-view "rcsdiff" filename version "-c")) ;;; There is presently no upper bound on the size of rcs-ci-history. ;;; Unless you leave an emacs running for weeks at a time or use log ;;; messages containing the complete works of Shakespeare, this seems ;;; unlikely to be a serious problem. (defun rcs-ci (filename &optional version) "Check a file into RCS." (interactive "fCheck file into RCS: \nP") (rcs-maybe-save-buffer filename) (let ((buffer (generate-new-buffer (concat "RCS-ci: " filename))) (config (current-window-configuration))) (pop-to-buffer buffer) (rcs-ci-mode) (make-local-variable 'rcs-filename) (make-local-variable 'rcs-window-config) (make-local-variable 'rcs-version) (make-local-variable 'rcs-dired-filename) (setq rcs-filename filename) (setq rcs-window-config config) (setq rcs-version version) (setq rcs-dired-filename nil))) (defvar rcs-ci-mode-hook nil "*Invoked in rcs-ci-mode on a new log message.") (defvar rcs-ci-mode-map (let ((map (copy-keymap text-mode-map))) (define-key map "\C-C\C-C" 'rcs-ci-exit) (define-key map "\C-c\C-y" 'rcs-ci-yank) map)) (defun rcs-ci-mode () "Mode for creating RCS log messages. \\{rcs-ci-mode-map} Turning on rcs-ci-mode runs the hooks text-mode-hook and rcs-ci-mode-hook, in that order. See run-hooks for details." (kill-all-local-variables) (use-local-map rcs-ci-mode-map) (setq major-mode 'rcs-ci-mode) (setq mode-name "RCS-ci") (setq local-abbrev-table text-mode-abbrev-table) (set-syntax-table text-mode-syntax-table) (run-hooks 'text-mode-hook 'rcs-ci-mode-hook)) (defvar rcs-ci-history nil "History of RCS check-in messages used in this emacs session.") (defun rcs-ci-yank (n) "Yank a RCS check-in message into buffer from rcs-ci-history. By default, yanks most recent message. With a numeric prefix argument, yanks Nth most recent message. Message numbering starts at one, not zero." (interactive "p") (let ((message (nth (1- n) rcs-ci-history))) (if (stringp message) (insert message) (error "No RCS check-in message #%d." n)))) (defun rcs-ci-exit () "Do the check-in using current buffer as log message." (interactive) (goto-char (point-max)) (skip-chars-backward "\n\t ") (delete-region (point) (point-max)) (let ((message (buffer-string)) (brand-new (not (rcs-file rcs-filename)))) (cond ((< 0 (buffer-size))) (brand-new (insert "Initial revision")) ((y-or-n-p "No log message specified, check-in anyway? ") (insert "*** empty log message ***")) (t (error "No log message specified"))) (rcs-exec "ci" rcs-filename rcs-version (and brand-new "-t/dev/null") (concat "-m" message) "-u") (setq rcs-ci-history (cons message rcs-ci-history))) (set-buffer-modified-p nil) (let ((dired-filename rcs-dired-filename) (filename rcs-filename)) (set-window-configuration (prog1 rcs-window-config (kill-buffer (current-buffer)))) (rcs-maybe-revert-buffer filename) (and dired-filename (eq major-mode 'dired-mode) (let (buffer-read-only) (dired-redisplay dired-filename))))) (defun rcs-history (&optional regexp) "View buffer containing entries from rcs-ci-history. When called interactively, prompts for a regular expression REGEXP to be used in selecting entries to display. Just type hit to see the entire history list." (interactive "sView messages matching regexp: ") (let (buffer) (unwind-protect (save-window-excursion (set-buffer (setq buffer (get-buffer-create "*RCS-History*"))) (erase-buffer) (let ((n 1) (h rcs-ci-history)) (while h (if (string-match (or regexp "") (car h)) (insert "Log message #" (int-to-string n) ":\n" (car h) "\n----------------------------\n")) (setq n (1+ n) h (cdr h)))) (if (= 0 (buffer-size)) (message "No matches.") (goto-char (point-min)) (view-buffer buffer))) (if buffer (kill-buffer buffer))))) ;;; ;;; Dired commands. ;;; (defun dired-rcs (function &optional version) "Utility function for dired RCS commands." (let ((filename (dired-get-filename))) (funcall function filename version) (let (buffer-read-only) (dired-redisplay filename)))) (defun dired-rcs-co (&optional version) "In dired, checkout a file with RCS. See documentation for function rcs-co." (interactive "P") (dired-rcs 'rcs-co version)) (defun dired-rcs-ci (&optional version) "In dired, checkin a file with RCS." (interactive "P") ;; We don't use dired-rcs because it would update the wrong buffer. (let ((filename (dired-get-filename))) (rcs-ci filename version) (setq rcs-dired-filename filename))) (defun dired-rcs-lock (&optional version) "In dired, lock a file with RCS." (interactive "P") (dired-rcs 'rcs-lock version)) (defun dired-rcs-unlock (&optional version) "In dired, unlock a file with RCS." (interactive "P") (dired-rcs 'rcs-unlock version)) (defun dired-rcs-view-log (&optional version) "In dired, view log of an RCS file." (interactive "P") (dired-rcs 'rcs-view-log version)) (defun dired-rcs-diff (&optional version) "In dired, diff working file against latest one checked into RCS." (interactive "P") (dired-rcs 'rcs-diff version)) ;;; DWIM stuff. ;;; This function replaces the standard "toggle-read-only". ;;; The idea is that if you keep a bunch of unlocked working ;;; files around, you can lock the ones you want to edit ;;; simply by making them writable. ;;; ;;; This function is intended to be bound to C-x C-q. ;;; Or, if you prefer, fset toggle-read-only to be an alias for this function. (defun rcs-toggle-read-only-dwim () "Change whether this buffer is visiting its file read-only. May check the file in or out with RCS if seems appropriate." (interactive) (cond ((and buffer-read-only buffer-file-name (not (buffer-modified-p)) (file-exists-p buffer-file-name) (not (file-writable-p buffer-file-name)) (or (file-exists-p (concat (file-name-directory buffer-file-name) "RCS")) (file-exists-p (concat buffer-file-name ",v")))) (rcs-co-dwim buffer-file-name) (revert-buffer t t)) (t (setq buffer-read-only (not buffer-read-only)) (set-buffer-modified-p (buffer-modified-p))))) (defun rcs-co-dwim (filename &optional version) "Check out FILENAME from RCS, locked, even if never checked-in." (interactive "fFile to check out from RCS: \nP") (let ((dir (file-name-directory filename)) (file (file-name-nondirectory filename))) (if (or (file-exists-p (concat dir "RCS/" file ",v")) (file-exists-p (concat dir file ",v"))) (rcs-exec "co" filename version "-l") (rcs-exec "ci" filename version "-l" "-t/dev/null")))) (defun rcs-find-file-not-found-dwim () "Try checking out a file from RCS if working file doesn't exist. If this function is placed on find-file-not-found-hooks, it will attempt to check out files which have an RCS file but no working file. This is mostly useful with the tags package. This function always checks files out unlocked, which should be ok if you use rcs-toggle-read-only-dwim as well." ;; ;; NB: find-file-not-found hook functions return non-nil iff ;; they succeed in obtaining the file, and should never signal ;; errors because doing so would (at the very least) prevent ;; other find-file-not-found hook functions from running. ;; (let (ccvar) (condition-case ccvar (cond ((or (file-exists-p (concat buffer-file-name ",v")) (file-exists-p (concat (file-name-directory buffer-file-name) "RCS/" (file-name-nondirectory buffer-file-name) ",v"))) (message "Checking `%s' out from RCS..." buffer-file-name) (rcs-exec "co" buffer-file-name) (insert-file-contents buffer-file-name t) (setq error nil) (message "Checking `%s' out from RCS...done" buffer-file-name) t)) ; Say that we did get the file. (error ;; The following is based on the code in keyboard.c. Yuk. (let ((head (get (car ccvar) 'error-message)) (tail (cdr ccvar))) (cond ((eq 'error (car ccvar)) (setq head (car tail) tail nil)) ((memq 'file-error (get (car ccvar) 'error-conditions)) (setq head (car tail) tail (cdr tail)))) (if (null tail) (message "%s" head) (message "%s: %s" head (mapconcat 'identity tail ", ")))) nil)))) ; Say that we didn't get the file.