rcs.lisp 16.6 KB
Newer Older
1
;;; -*- Package: HEMLOCK; Mode: Lisp -*-
wlott's avatar
wlott committed
2
;;;
3
;;; $Header: src/hemlock/rcs.lisp $
wlott's avatar
wlott committed
4
;;;
ch's avatar
ch committed
5
;;; Various commands for dealing with RCS under Hemlock.
6 7
;;;
;;; Written by William Lott and Christopher Hoover.
wlott's avatar
wlott committed
8 9 10
;;; 
(in-package "HEMLOCK")

11 12 13

;;;;

wlott's avatar
wlott committed
14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30
(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)))))


31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
(defvar *last-rcs-command-name* nil)
(defvar *last-rcs-command-output-string* nil)
(defvar *rcs-output-stream* (make-string-output-stream))

(defmacro do-command (command &rest args)
  `(progn
     (setf *last-rcs-command-name* ',command)
     (get-output-stream-string *rcs-output-stream*)
     (let ((process (ext:run-program ',command ,@args
				     :error *rcs-output-stream*)))
       (setf *last-rcs-command-output-string*
	     (get-output-stream-string *rcs-output-stream*))
       (case (ext:process-status process)
	 (:exited
	  (unless (zerop (ext:process-exit-code process))
	    (editor-error "~A aborted with an error; ~
47 48
			   use the ``RCS Last Command Output'' command for ~
			   more information" ',command)))
49 50 51 52 53 54 55
	 (:signaled
	  (editor-error "~A killed with signal ~A~@[ (core dumped)]."
			',command
			(ext:process-exit-code process)
			(ext:process-core-dumped process)))
	 (t
	  (editor-error "~S still alive?" process))))))
wlott's avatar
wlott committed
56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71

(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)))))

72 73 74 75 76 77 78
(defun turn-auto-save-off (buffer)
  (setf (buffer-minor-mode buffer "Save") nil)
  ;;
  ;; William's personal hack
  (when (getstring "Ckp" *mode-names*)
    (setf (buffer-minor-mode buffer "Ckp") nil)))

79 80 81 82 83 84

(defhvar "RCS Lock File Hook"
  "RCS Lock File Hook"
  :value nil)

(defun rcs-lock-file (buffer pathname)
85
  (message "Locking ~A ..." (namestring pathname))
wlott's avatar
wlott committed
86 87 88
  (in-directory pathname
    (let ((file (file-namestring pathname)))
      (do-command "rcs" `("-l" ,file))
wlott's avatar
wlott committed
89
      (multiple-value-bind (won dev ino mode) (unix:unix-stat file)
90 91
	(declare (ignore ino))
	(cond (won
wlott's avatar
wlott committed
92
	       (unix:unix-chmod file (logior mode unix:writeown)))
93
	      (t
wlott's avatar
wlott committed
94 95
	       (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
			     (unix:get-unix-error-msg dev)))))))
96
  (invoke-hook rcs-lock-file-hook buffer pathname))
wlott's avatar
wlott committed
97

98 99 100 101 102 103

(defhvar "RCS Unlock File Hook"
  "RCS Unlock File Hook"
  :value nil)

(defun rcs-unlock-file (buffer pathname)
104
  (message "Unlocking ~A ..." (namestring pathname))
wlott's avatar
wlott committed
105
  (in-directory pathname
106 107
    (do-command "rcs" `("-u" ,(file-namestring pathname))))
  (invoke-hook rcs-unlock-file-hook buffer pathname))
wlott's avatar
wlott committed
108

109 110 111

;;;; Check In

112 113 114 115
(defhvar "RCS Check In File Hook"
  "RCS Check In File Hook"
  :value nil)

116 117 118 119 120
(defhvar "RCS Keep Around After Unlocking"
  "If non-NIL (the default) keep the working file around after unlocking it.
   When NIL, the working file and buffer are deleted."
  :value t)

121
(defun rcs-check-in-file (buffer pathname keep-lock)
wlott's avatar
wlott committed
122 123
  (let ((old-buffer (current-buffer))
	(allow-delete nil)
124
	(log-buffer nil))
wlott's avatar
wlott committed
125 126 127
    (unwind-protect
	(when (block in-recursive-edit
		(do ((i 0 (1+ i)))
128 129 130 131 132 133 134 135 136 137 138 139 140
		    ((not (null log-buffer)))
		  (setf log-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)))))))
		(turn-auto-save-off log-buffer)
		(change-to-buffer log-buffer)
wlott's avatar
wlott committed
141 142
		(do-recursive-edit)
	  
143 144
		(message "Checking in ~A~:[~; keeping the lock~] ..."
			 (namestring pathname) keep-lock)
145 146
		(let ((log-stream (make-hemlock-region-stream
				   (buffer-region log-buffer))))
147
		  (sub-check-in-file pathname buffer keep-lock log-stream))
148
		(invoke-hook rcs-check-in-file-hook buffer pathname)
wlott's avatar
wlott committed
149 150
		nil)
	  (editor-error "Someone deleted the RCS Log Entry buffer."))
151 152
      (when (member old-buffer *buffer-list*)
	(change-to-buffer old-buffer))
wlott's avatar
wlott committed
153
      (setf allow-delete t)
154
      (delete-buffer-if-possible log-buffer))))
wlott's avatar
wlott committed
155

156
(defun sub-check-in-file (pathname buffer keep-lock log-stream)
157 158
  (let* ((filename (file-namestring pathname))
	 (rcs-filename (concatenate 'simple-string
159 160
				    "./RCS/" filename ",v"))
	 (keep-working-copy (or keep-lock
161 162 163
				(not (hemlock-bound-p
				      'rcs-keep-around-after-unlocking
				      :buffer buffer))
164 165 166
				(variable-value
				 'rcs-keep-around-after-unlocking
				 :buffer buffer))))
167
    (in-directory pathname
168
      (do-command "ci" `(,@(if keep-lock '("-l"))
169
			    ,@(if keep-working-copy '("-u"))
170
			    ,filename)
171
		  :input log-stream)
172 173 174 175
      (if keep-working-copy
	  ;; 
	  ;; Set the times on the user's file to be equivalent to that of
	  ;; the rcs file.
176
	  #-(or hpux svr4)
177 178
	  (multiple-value-bind
	      (dev ino mode nlink uid gid rdev size atime mtime)
wlott's avatar
wlott committed
179
	      (unix:unix-stat rcs-filename)
180 181 182 183
	    (declare (ignore mode nlink uid gid rdev size))
	    (cond (dev
		   (multiple-value-bind
		       (wonp errno)
ram's avatar
ram committed
184
		       (unix:unix-utimes filename atime 0 mtime 0)
185
		     (unless wonp
wlott's avatar
wlott committed
186 187
		       (editor-error "UNIX:UNIX-UTIMES failed: ~A"
				     (unix:get-unix-error-msg errno)))))
188
		  (t
wlott's avatar
wlott committed
189 190
		   (editor-error "UNIX:UNIX-STAT failed: ~A"
				 (unix:get-unix-error-msg ino)))))
191 192
	  (delete-buffer-if-possible buffer)))))

193

194 195 196

;;;; Check Out

197 198 199 200
(defhvar "RCS Check Out File Hook"
  "RCS Check Out File Hook"
  :value nil)

201 202
(defvar *translate-file-names-before-locking* nil)

203
(defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
204 205 206
  (when (and lock *translate-file-names-before-locking*)
    (multiple-value-bind (unmatched-dir new-dirs file-name)
			 (maybe-translate-definition-file pathname)
207
      (when new-dirs
208 209 210 211 212
	(let ((new-name (translate-definition-file unmatched-dir
						   (car new-dirs)
						   file-name)))
	  (when (probe-file (directory-namestring new-name))
	    (setf pathname new-name))))))
213 214
  (cond
   ((and (not always-overwrite-p)
215 216
	 (let ((pn (probe-file pathname)))
	   (and pn (ext:file-writable pn))))
217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
    ;; File exists and is writable so check and see if the user really
    ;; wants to check it out.
    (command-case (:prompt
		   (format nil "The file ~A is writable.  Overwrite? "
			   (file-namestring pathname))
		   :help
		   "Type one of the following single-character commands:")
      ((:yes :confirm)
       "Overwrite the file."
       (rcs-check-out-file buffer pathname lock))
      (:no
       "Don't check it out after all.")
      ((#\r #\R)
       "Rename the file before checking it out."
       (let ((new-pathname (prompt-for-file
			    :prompt "New Filename: "
			    :default (buffer-default-pathname
				      (current-buffer))
			    :must-exist nil)))
	 (rename-file pathname new-pathname)
	 (rcs-check-out-file buffer pathname lock)))))
   (t
    (rcs-check-out-file buffer pathname lock)))
  pathname)
241

242
(defun rcs-check-out-file (buffer pathname lock)
243
  (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
wlott's avatar
wlott committed
244
  (in-directory pathname
245 246 247 248
    (let* ((file (file-namestring pathname))
	   (backup (if (probe-file file)
		       (lisp::pick-backup-name file))))
      (when backup (rename-file file backup))
249
      (do-command "co" `(,@(if lock '("-l")) ,file))
250
      (invoke-hook rcs-check-out-file-hook buffer pathname)
251
      (when backup (delete-file backup)))))
wlott's avatar
wlott committed
252

253

254 255 256 257 258 259 260 261 262 263 264 265 266
;;;; Last Command Output

(defcommand "RCS Last Command Output" (p)
  "Print the full output of the last RCS command."
  "Print the full output of the last RCS command."
  (declare (ignore p))
  (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
    (editor-error "No RCS commands have executed!"))
  (with-pop-up-display (s :buffer-name "*RCS Command Output*")
    (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
    (write-line *last-rcs-command-output-string* s)))


267 268 269 270 271 272 273 274 275 276
;;;; Commands for Checking In / Checking Out and Locking / Unlocking 

(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)))))))
277

wlott's avatar
wlott committed
278 279 280 281 282 283 284
(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/")))
285
    (rcs-lock-file buffer file)
wlott's avatar
wlott committed
286 287 288
    (unwind-protect
	(progn
	  (in-directory file
289
  	    (do-command "co" `("-p" ,(file-namestring file))
wlott's avatar
wlott committed
290 291 292
			:output (namestring name)))
	  (when (buffer-different-from-file buffer name)
	    (message
293
	     "RCS file is different; be sure to merge in your changes."))
wlott's avatar
wlott committed
294 295 296 297 298 299 300 301 302
	  (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))
303 304 305 306
  (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
				      :default (buffer-default-pathname
						(current-buffer))
				      :must-exist nil)))
wlott's avatar
wlott committed
307 308 309 310 311

(defcommand "RCS Unlock Buffer File" (p)
  "Unlock the file in the current buffer."
  "Unlock the file in the current buffer."
  (declare (ignore p))
312
  (rcs-unlock-file (current-buffer) (current-buffer-pathname))
wlott's avatar
wlott committed
313 314 315 316 317 318 319
  (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))
320 321 322 323
  (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
					:default (buffer-default-pathname
						  (current-buffer))
					:must-exist nil)))
wlott's avatar
wlott committed
324 325

(defcommand "RCS Check In Buffer File" (p)
326 327 328 329
  "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."
wlott's avatar
wlott committed
330 331 332 333
  (let ((buffer (current-buffer))
	(pathname (current-buffer-pathname)))
    (when (buffer-modified buffer)
      (save-file-command nil))
334
    (rcs-check-in-file buffer pathname p)
335 336 337 338
    (when (member buffer *buffer-list*)
      ;; If the buffer has not been deleted, make sure it is up to date
      ;; with respect to the file.
      (visit-file-command nil pathname buffer))))
wlott's avatar
wlott committed
339 340

(defcommand "RCS Check In File" (p)
341 342 343 344
  "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."
345 346 347 348 349
  (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
					  :default
					  (buffer-default-pathname
					   (current-buffer))
					  :must-exist nil)
wlott's avatar
wlott committed
350 351 352
		     p))

(defcommand "RCS Check Out Buffer File" (p)
353 354 355 356
  "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."
wlott's avatar
wlott committed
357 358 359 360 361 362 363 364
  (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.")))
    (setf (buffer-modified buffer) nil)
365
    (setf pathname (maybe-rcs-check-out-file buffer pathname p nil))
wlott's avatar
wlott committed
366 367 368 369 370 371 372 373
    (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)
374 375 376 377
  "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."
wlott's avatar
wlott committed
378
  (let ((pathname (prompt-for-file :prompt "File to check out: "
379 380
				   :default (buffer-default-pathname
					     (current-buffer))
wlott's avatar
wlott committed
381
				   :must-exist nil)))
382
    (setf pathname (maybe-rcs-check-out-file nil pathname p nil))
wlott's avatar
wlott committed
383 384
    (find-file-command nil pathname)))

385 386 387

;;;; Log File

wlott's avatar
wlott committed
388 389 390 391
(defhvar "RCS Log Entry Buffer"
  "Name of the buffer to put RCS log entries into."
  :value "RCS Log")

392 393 394 395
(defhvar "RCS Log Buffer Hook"
  "RCS Log Buffer Hook"
  :value nil)

wlott's avatar
wlott committed
396 397 398 399
(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)))
400 401
      (turn-auto-save-off buffer)
      (invoke-hook rcs-log-buffer-hook buffer))
wlott's avatar
wlott committed
402 403 404 405 406 407 408 409 410
    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))
411
    (message "Extracting log info ...")
wlott's avatar
wlott committed
412 413 414 415 416 417 418 419 420
    (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)
421 422
  "Prompt for a file and get its RCS log entry in a buffer."
  "Prompt for a file and get its RCS log entry in a buffer."
wlott's avatar
wlott committed
423 424
  (declare (ignore p))
  (let ((file (prompt-for-file :prompt "File to get log of: "
425 426
			       :default (buffer-default-pathname
					 (current-buffer))
wlott's avatar
wlott committed
427 428 429
			       :must-exist nil))
	(buffer (get-log-buffer)))
    (delete-region (buffer-region buffer))
430
    (message "Extracing log info ...")
wlott's avatar
wlott committed
431 432 433 434 435 436 437
    (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)))
438

439

440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457
;;;; Status and Modeline Frobs.

(defhvar "RCS Status"
  "RCS status of this buffer.  Either nil, :locked, :out-of-date, or
  :unlocked."
  :value nil)

;;;
;;; Note: This doesn't behave correctly w/r/t to branched files.
;;; 
(defun rcs-file-status (pathname)
  (let* ((directory (directory-namestring pathname))
	 (filename (file-namestring pathname))
	 (rcs-file (concatenate 'simple-string directory
				"RCS/" filename ",v")))
    (if (probe-file rcs-file)
	;; This is an RCS file
	(let ((probe-file (probe-file pathname)))
458
	  (cond ((and probe-file (file-writable probe-file))
459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519
		 :locked)
		((or (not probe-file)
		     (< (file-write-date pathname)
			(file-write-date rcs-file)))
		 :out-of-date)
		(t
		 :unlocked))))))

(defun rcs-update-buffer-status (buffer &optional tn)
  (unless (hemlock-bound-p 'rcs-status :buffer buffer)
    (defhvar "RCS Status"
      "RCS Status of this buffer."
      :buffer buffer
      :value nil))
  (let ((tn (or tn (buffer-pathname buffer))))
    (setf (variable-value 'rcs-status :buffer buffer)
	  (if tn (rcs-file-status tn))))
  (hi::update-modelines-for-buffer buffer))
;;; 
(add-hook read-file-hook 'rcs-update-buffer-status)
(add-hook write-file-hook 'rcs-update-buffer-status)

(defcommand "RCS Update All RCS Status Variables" (p)
  "Update the ``RCS Status'' variable for all buffers."
  "Update the ``RCS Status'' variable for all buffers."
  (declare (ignore p))
  (dolist (buffer *buffer-list*)
    (rcs-update-buffer-status buffer))
  (dolist (window *window-list*)
    (update-modeline-fields (window-buffer window) window)))

;;; 
;;; Action Hooks
(defun rcs-action-hook (buffer pathname)
  (cond (buffer
	 (rcs-update-buffer-status buffer))
	(t
	 (let ((pathname (probe-file pathname)))
	   (when pathname
	     (dolist (buffer *buffer-list*)
	       (let ((buffer-pathname (buffer-pathname buffer)))
		 (when (equal pathname buffer-pathname)
		   (rcs-update-buffer-status buffer)))))))))
;;; 
(add-hook rcs-check-in-file-hook 'rcs-action-hook)
(add-hook rcs-check-out-file-hook 'rcs-action-hook)
(add-hook rcs-lock-file-hook 'rcs-action-hook)
(add-hook rcs-unlock-file-hook 'rcs-action-hook)


;;;
;;; RCS Modeline Field
(make-modeline-field
 :name :rcs-status
 :function #'(lambda (buffer window)
	       (declare (ignore buffer window))
	       (ecase (value rcs-status)
		 (:out-of-date "[OLD]  ")
		 (:locked "[LOCKED]  ")
		 (:unlocked "[RCS]  ")
		 ((nil) ""))))