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