From 057245a38377690e462de56daf2a2492fcc81c25 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Tue, 6 Feb 1990 11:43:44 +0000 Subject: [PATCH] Initial revision --- hemlock/rcs.lisp | 278 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 278 insertions(+) create mode 100644 hemlock/rcs.lisp diff --git a/hemlock/rcs.lisp b/hemlock/rcs.lisp new file mode 100644 index 000000000..d675f3a59 --- /dev/null +++ b/hemlock/rcs.lisp @@ -0,0 +1,278 @@ +;;; -*- Package: HEMLOCK -*- +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rcs.lisp,v 1.1 1990/02/06 11:43:44 wlott Exp $ +;;; +;;; Various commands for dealing with RCS under hemlock. +;;; + +(in-package "HEMLOCK") + + +(defun current-buffer-pathname () + (let ((pathname (buffer-pathname (current-buffer)))) + (unless pathname + (editor-error "The buffer has no pathname.")) + pathname)) + + +(defmacro in-directory (directory &body forms) + (let ((cwd (gensym))) + `(let ((,cwd (ext:default-directory))) + (unwind-protect + (progn + (setf (ext:default-directory) (directory-namestring ,directory)) + ,@forms) + (setf (ext:default-directory) ,cwd))))) + + +(defvar *error-stream* (make-string-output-stream)) + +(defmacro do-command (&rest args) + (let ((proc (gensym))) + `(progn + (get-output-stream-string *error-stream*) + (let ((,proc (ext:run-program ,@args :error *error-stream*))) + (case (ext:process-status ,proc) + (:exited + (unless (zerop (ext:process-exit-code ,proc)) + (editor-error "~A" (get-output-stream-string *error-stream*)))) + (:signaled + (editor-error "~A killed with signal ~A ~@[core dumped]" + ',(car args) + (ext:process-exit-code ,proc) + (ext:process-core-dumped ,proc))) + (t + (editor-error "~S still alive?" ,proc))))))) + +(defun buffer-different-from-file (buffer filename) + (with-open-file (file filename) + (do ((buffer-line (mark-line (buffer-start-mark buffer)) + (line-next buffer-line)) + (file-line (read-line file nil nil) + (read-line file nil nil))) + ((and (or (null buffer-line) + (zerop (line-length buffer-line))) + (null file-line)) + nil) + (when (or (null buffer-line) + (null file-line) + (string/= (line-string buffer-line) file-line)) + (return t))))) + +(defun rcs-lock-file (pathname) + (message "Locking ~A" (namestring pathname)) + (in-directory pathname + (let ((file (file-namestring pathname))) + (do-command "rcs" `("-l" ,file)) + (multiple-value-bind + (won dev ino mode) + (mach:unix-stat file) + (declare (ignore dev ino)) + (when won + (mach:unix-chmod file (logior mode mach:writeown))))))) + +(defun rcs-unlock-file (pathname) + (message "Unlocking ~A" (namestring pathname)) + (in-directory pathname + (do-command "rcs" `("-u" ,(file-namestring pathname))))) + +(defun rcs-check-in-file (pathname keep-lock) + (let ((old-buffer (current-buffer)) + (allow-delete nil) + (buffer nil)) + (unwind-protect + (when (block in-recursive-edit + (do ((i 0 (1+ i))) + ((not (null buffer))) + (setf buffer + (make-buffer (format nil "RCS Log Entry ~D for ~S" + i (file-namestring pathname)) + :modes '("Text") + :delete-hook + (list #'(lambda (buffer) + (declare (ignore buffer)) + (unless allow-delete + (return-from in-recursive-edit + t))))))) + (setf (buffer-minor-mode buffer "Save") nil) + (when (getstring "Ckp" *mode-names*) + (setf (buffer-minor-mode buffer "Ckp") nil)) + (change-to-buffer buffer) + (do-recursive-edit) + + (message "Checking in ~A" (namestring pathname)) + (in-directory pathname + (do-command "rcsci" `(,@(if keep-lock '("-l")) + "-U" + ,(file-namestring pathname)) + :input (make-hemlock-region-stream + (buffer-region buffer)))) + nil) + (editor-error "Someone deleted the RCS Log Entry buffer.")) + (change-to-buffer old-buffer) + (setf allow-delete t) + (delete-buffer buffer)))) + +(defun rcs-check-out-file (pathname lock) + (message "Checking out ~A" (namestring pathname)) + (in-directory pathname + (let ((backup (lisp::pick-backup-name (namestring pathname)))) + (rename-file pathname backup) + (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname))) + (delete-file backup)))) + + + +(defun pick-temp-file (defaults) + (let ((index 0)) + (loop + (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults))) + (cond ((probe-file name) + (incf index)) + (t + (return name))))))) + +(defcommand "RCS Lock Buffer File" (p) + "Attempt to lock the file in the current buffer." + "Attempt to lock the file in the current buffer." + (declare (ignore p)) + (let ((file (current-buffer-pathname)) + (buffer (current-buffer)) + (name (pick-temp-file "/tmp/"))) + (rcs-lock-file file) + (unwind-protect + (progn + (in-directory file + (do-command "rcsco" `("-p" ,(file-namestring file)) + :output (namestring name))) + (when (buffer-different-from-file buffer name) + (message + "RCS file is different, be sure to merge your changes in.")) + (setf (buffer-writable buffer) t) + (message "Buffer is now writable.")) + (when (probe-file name) + (delete-file name))))) + +(defcommand "RCS Lock File" (p) + "Prompt for a file, and attempt to lock it." + "Prompt for a file, and attempt to lock it." + (declare (ignore p)) + (rcs-lock-file (prompt-for-file :prompt "File to lock: " + :default (buffer-pathname (current-buffer)) + :must-exist nil))) + +(defcommand "RCS Unlock Buffer File" (p) + "Unlock the file in the current buffer." + "Unlock the file in the current buffer." + (declare (ignore p)) + (rcs-unlock-file (current-buffer-pathname)) + (setf (buffer-writable (current-buffer)) nil) + (message "Buffer is no longer writable.")) + +(defcommand "RCS Unlock File" (p) + "Prompt for a file, and attempt to unlock it." + "Prompt for a file, and attempt to unlock it." + (declare (ignore p)) + (rcs-unlock-file (prompt-for-file :prompt "File to unlock: " + :default (buffer-pathname (current-buffer)) + :must-exist nil))) + +(defcommand "RCS Check In Buffer File" (p) + "Checkin the file in the current buffer. With an argument, do not release + the lock." + "Checkin the file in the current buffer. With an argument, do not release + the lock." + (let ((buffer (current-buffer)) + (pathname (current-buffer-pathname))) + (when (buffer-modified buffer) + (save-file-command nil)) + (rcs-check-in-file pathname p) + (visit-file-command nil pathname buffer))) + +(defcommand "RCS Check In File" (p) + "Prompt for a file, and attempt to check it in. With an argument, do not + release the lock." + "Prompt for a file, and attempt to check it in. With an argument, do not + release the lock." + (rcs-check-in-file (prompt-for-file :prompt "File to lock: " + :default + (buffer-pathname (current-buffer)) + :must-exist nil) + p)) + +(defcommand "RCS Check Out Buffer File" (p) + "Checkout the file in the current buffer. With an argument, lock the file." + "Checkout the file in the current buffer. With an argument, lock the file." + (let* ((buffer (current-buffer)) + (pathname (current-buffer-pathname)) + (point (current-point)) + (lines (1- (count-lines (region (buffer-start-mark buffer) point))))) + (when (buffer-modified buffer) + (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? ")) + (editor-error "Aborted."))) + (rcs-check-out-file pathname p) + (setf (buffer-modified buffer) nil) + (when p + (setf (buffer-writable buffer) t) + (message "Buffer is now writable.")) + (visit-file-command nil pathname) + (unless (line-offset point lines) + (buffer-end point)))) + +(defcommand "RCS Check Out File" (p) + "Prompt for a file and attempt to check it out. With an argument, lock the + file." + "Prompt for a file and attempt to check it out. With an argument, lock the + file." + (let ((pathname (prompt-for-file :prompt "File to check out: " + :default (buffer-pathname (current-buffer)) + :must-exist nil))) + (rcs-check-out-file pathname p) + (find-file-command nil pathname))) + +(defhvar "RCS Log Entry Buffer" + "Name of the buffer to put RCS log entries into." + :value "RCS Log") + +(defun get-log-buffer () + (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*))) + (unless buffer + (setf buffer (make-buffer (value rcs-log-entry-buffer))) + (setf (buffer-minor-mode buffer "Save") nil) + (when (getstring "Ckp" *mode-names*) + (setf (buffer-minor-mode buffer "Ckp") nil))) + buffer)) + +(defcommand "RCS Buffer File Log Entry" (p) + "Get the RCS Log for the file in the current buffer in a buffer." + "Get the RCS Log for the file in the current buffer in a buffer." + (declare (ignore p)) + (let ((buffer (get-log-buffer)) + (pathname (current-buffer-pathname))) + (delete-region (buffer-region buffer)) + (message "Extracing log info.") + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (in-directory pathname + (do-command "rlog" (list (file-namestring pathname)) + :output (make-hemlock-output-stream mark)))) + (change-to-buffer buffer) + (buffer-start (current-point)) + (setf (buffer-modified buffer) nil))) + +(defcommand "RCS File Log Entry" (p) + "Prompt for a file and get it's RCS log entry in a buffer." + "Prompt for a file and get it's RCS log entry in a buffer." + (declare (ignore p)) + (let ((file (prompt-for-file :prompt "File to get log of: " + :default (buffer-pathname (current-buffer)) + :must-exist nil)) + (buffer (get-log-buffer))) + (delete-region (buffer-region buffer)) + (message "Extracing log info.") + (with-mark ((mark (buffer-start-mark buffer) :left-inserting)) + (in-directory file + (do-command "rlog" (list (file-namestring file)) + :output (make-hemlock-output-stream mark)))) + (change-to-buffer buffer) + (buffer-start (current-point)) + (setf (buffer-modified buffer) nil))) -- GitLab