| 1 | ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; $Header$
|
|---|
| 4 | ;;;
|
|---|
| 5 | ;;; Various commands for dealing with RCS under Hemlock.
|
|---|
| 6 | ;;;
|
|---|
| 7 | ;;; Written by William Lott and Christopher Hoover.
|
|---|
| 8 | ;;;
|
|---|
| 9 | (in-package :hemlock)
|
|---|
| 10 |
|
|---|
| 11 | |
|---|
| 12 |
|
|---|
| 13 | ;;;;
|
|---|
| 14 |
|
|---|
| 15 | (defun current-buffer-pathname ()
|
|---|
| 16 | (let ((pathname (buffer-pathname (current-buffer))))
|
|---|
| 17 | (unless pathname
|
|---|
| 18 | (editor-error "The buffer has no pathname."))
|
|---|
| 19 | pathname))
|
|---|
| 20 |
|
|---|
| 21 |
|
|---|
| 22 | (defmacro in-directory (directory &body forms)
|
|---|
| 23 | (let ((cwd (gensym)))
|
|---|
| 24 | `(let ((,cwd (ext:default-directory)))
|
|---|
| 25 | (unwind-protect
|
|---|
| 26 | (progn
|
|---|
| 27 | (setf (ext:default-directory) (directory-namestring ,directory))
|
|---|
| 28 | ,@forms)
|
|---|
| 29 | (setf (ext:default-directory) ,cwd)))))
|
|---|
| 30 |
|
|---|
| 31 |
|
|---|
| 32 | (defvar *last-rcs-command-name* nil)
|
|---|
| 33 | (defvar *last-rcs-command-output-string* nil)
|
|---|
| 34 | (defvar *rcs-output-stream* (make-string-output-stream))
|
|---|
| 35 |
|
|---|
| 36 | (defmacro do-command (command &rest args)
|
|---|
| 37 | `(progn
|
|---|
| 38 | (setf *last-rcs-command-name* ',command)
|
|---|
| 39 | (get-output-stream-string *rcs-output-stream*)
|
|---|
| 40 | (let ((process (ext:run-program ',command ,@args
|
|---|
| 41 | :error *rcs-output-stream*)))
|
|---|
| 42 | (setf *last-rcs-command-output-string*
|
|---|
| 43 | (get-output-stream-string *rcs-output-stream*))
|
|---|
| 44 | (case (ext:process-status process)
|
|---|
| 45 | (:exited
|
|---|
| 46 | (unless (zerop (ext:process-exit-code process))
|
|---|
| 47 | (editor-error "~A aborted with an error; ~
|
|---|
| 48 | use the ``RCS Last Command Output'' command for ~
|
|---|
| 49 | more information" ',command)))
|
|---|
| 50 | (:signaled
|
|---|
| 51 | (editor-error "~A killed with signal ~A~@[ (core dumped)]."
|
|---|
| 52 | ',command
|
|---|
| 53 | (ext:process-exit-code process)
|
|---|
| 54 | (ext:process-core-dumped process)))
|
|---|
| 55 | (t
|
|---|
| 56 | (editor-error "~S still alive?" process))))))
|
|---|
| 57 |
|
|---|
| 58 | (defun buffer-different-from-file (buffer filename)
|
|---|
| 59 | (with-open-file (file filename)
|
|---|
| 60 | (do ((buffer-line (mark-line (buffer-start-mark buffer))
|
|---|
| 61 | (line-next buffer-line))
|
|---|
| 62 | (file-line (read-line file nil nil)
|
|---|
| 63 | (read-line file nil nil)))
|
|---|
| 64 | ((and (or (null buffer-line)
|
|---|
| 65 | (zerop (line-length buffer-line)))
|
|---|
| 66 | (null file-line))
|
|---|
| 67 | nil)
|
|---|
| 68 | (when (or (null buffer-line)
|
|---|
| 69 | (null file-line)
|
|---|
| 70 | (string/= (line-string buffer-line) file-line))
|
|---|
| 71 | (return t)))))
|
|---|
| 72 |
|
|---|
| 73 | (defun turn-auto-save-off (buffer)
|
|---|
| 74 | (setf (buffer-minor-mode buffer "Save") nil)
|
|---|
| 75 | ;;
|
|---|
| 76 | ;; William's personal hack
|
|---|
| 77 | (when (getstring "Ckp" *mode-names*)
|
|---|
| 78 | (setf (buffer-minor-mode buffer "Ckp") nil)))
|
|---|
| 79 |
|
|---|
| 80 |
|
|---|
| 81 | (defhvar "RCS Lock File Hook"
|
|---|
| 82 | "RCS Lock File Hook"
|
|---|
| 83 | :value nil)
|
|---|
| 84 |
|
|---|
| 85 | (defun rcs-lock-file (buffer pathname)
|
|---|
| 86 | (message "Locking ~A ..." (namestring pathname))
|
|---|
| 87 | (in-directory pathname
|
|---|
| 88 | (let ((file (file-namestring pathname)))
|
|---|
| 89 | (do-command "rcs" `("-l" ,file))
|
|---|
| 90 | (multiple-value-bind (won dev ino mode) (unix:unix-stat file)
|
|---|
| 91 | (declare (ignore ino))
|
|---|
| 92 | (cond (won
|
|---|
| 93 | (unix:unix-chmod file (logior mode unix:writeown)))
|
|---|
| 94 | (t
|
|---|
| 95 | (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
|
|---|
| 96 | (unix:get-unix-error-msg dev)))))))
|
|---|
| 97 | (invoke-hook rcs-lock-file-hook buffer pathname))
|
|---|
| 98 |
|
|---|
| 99 |
|
|---|
| 100 | (defhvar "RCS Unlock File Hook"
|
|---|
| 101 | "RCS Unlock File Hook"
|
|---|
| 102 | :value nil)
|
|---|
| 103 |
|
|---|
| 104 | (defun rcs-unlock-file (buffer pathname)
|
|---|
| 105 | (message "Unlocking ~A ..." (namestring pathname))
|
|---|
| 106 | (in-directory pathname
|
|---|
| 107 | (do-command "rcs" `("-u" ,(file-namestring pathname))))
|
|---|
| 108 | (invoke-hook rcs-unlock-file-hook buffer pathname))
|
|---|
| 109 |
|
|---|
| 110 | |
|---|
| 111 |
|
|---|
| 112 | ;;;; Check In
|
|---|
| 113 |
|
|---|
| 114 | (defhvar "RCS Check In File Hook"
|
|---|
| 115 | "RCS Check In File Hook"
|
|---|
| 116 | :value nil)
|
|---|
| 117 |
|
|---|
| 118 | (defhvar "RCS Keep Around After Unlocking"
|
|---|
| 119 | "If non-NIL (the default) keep the working file around after unlocking it.
|
|---|
| 120 | When NIL, the working file and buffer are deleted."
|
|---|
| 121 | :value t)
|
|---|
| 122 |
|
|---|
| 123 | (defun rcs-check-in-file (buffer pathname keep-lock)
|
|---|
| 124 | (let ((old-buffer (current-buffer))
|
|---|
| 125 | (allow-delete nil)
|
|---|
| 126 | (log-buffer nil))
|
|---|
| 127 | (unwind-protect
|
|---|
| 128 | (when (block in-recursive-edit
|
|---|
| 129 | (do ((i 0 (1+ i)))
|
|---|
| 130 | ((not (null log-buffer)))
|
|---|
| 131 | (setf log-buffer
|
|---|
| 132 | (make-buffer
|
|---|
| 133 | (format nil "RCS Log Entry ~D for ~S" i
|
|---|
| 134 | (file-namestring pathname))
|
|---|
| 135 | :modes '("Text")
|
|---|
| 136 | :delete-hook
|
|---|
| 137 | (list #'(lambda (buffer)
|
|---|
| 138 | (declare (ignore buffer))
|
|---|
| 139 | (unless allow-delete
|
|---|
| 140 | (return-from in-recursive-edit t)))))))
|
|---|
| 141 | (turn-auto-save-off log-buffer)
|
|---|
| 142 | (change-to-buffer log-buffer)
|
|---|
| 143 | (do-recursive-edit)
|
|---|
| 144 |
|
|---|
| 145 | (message "Checking in ~A~:[~; keeping the lock~] ..."
|
|---|
| 146 | (namestring pathname) keep-lock)
|
|---|
| 147 | (let ((log-stream (make-hemlock-region-stream
|
|---|
| 148 | (buffer-region log-buffer))))
|
|---|
| 149 | (sub-check-in-file pathname buffer keep-lock log-stream))
|
|---|
| 150 | (invoke-hook rcs-check-in-file-hook buffer pathname)
|
|---|
| 151 | nil)
|
|---|
| 152 | (editor-error "Someone deleted the RCS Log Entry buffer."))
|
|---|
| 153 | (when (member old-buffer *buffer-list*)
|
|---|
| 154 | (change-to-buffer old-buffer))
|
|---|
| 155 | (setf allow-delete t)
|
|---|
| 156 | (delete-buffer-if-possible log-buffer))))
|
|---|
| 157 |
|
|---|
| 158 | (defun sub-check-in-file (pathname buffer keep-lock log-stream)
|
|---|
| 159 | (let* ((filename (file-namestring pathname))
|
|---|
| 160 | (rcs-filename (concatenate 'simple-string
|
|---|
| 161 | "./RCS/" filename ",v"))
|
|---|
| 162 | (keep-working-copy (or keep-lock
|
|---|
| 163 | (not (hemlock-bound-p
|
|---|
| 164 | 'rcs-keep-around-after-unlocking
|
|---|
| 165 | :buffer buffer))
|
|---|
| 166 | (variable-value
|
|---|
| 167 | 'rcs-keep-around-after-unlocking
|
|---|
| 168 | :buffer buffer))))
|
|---|
| 169 | (in-directory pathname
|
|---|
| 170 | (do-command "ci" `(,@(if keep-lock '("-l"))
|
|---|
| 171 | ,@(if keep-working-copy '("-u"))
|
|---|
| 172 | ,filename)
|
|---|
| 173 | :input log-stream)
|
|---|
| 174 | (if keep-working-copy
|
|---|
| 175 | ;;
|
|---|
| 176 | ;; Set the times on the user's file to be equivalent to that of
|
|---|
| 177 | ;; the rcs file.
|
|---|
| 178 | #-(or hpux svr4)
|
|---|
| 179 | (multiple-value-bind
|
|---|
| 180 | (dev ino mode nlink uid gid rdev size atime mtime)
|
|---|
| 181 | (unix:unix-stat rcs-filename)
|
|---|
| 182 | (declare (ignore mode nlink uid gid rdev size))
|
|---|
| 183 | (cond (dev
|
|---|
| 184 | (multiple-value-bind
|
|---|
| 185 | (wonp errno)
|
|---|
| 186 | (unix:unix-utimes filename atime 0 mtime 0)
|
|---|
| 187 | (unless wonp
|
|---|
| 188 | (editor-error "UNIX:UNIX-UTIMES failed: ~A"
|
|---|
| 189 | (unix:get-unix-error-msg errno)))))
|
|---|
| 190 | (t
|
|---|
| 191 | (editor-error "UNIX:UNIX-STAT failed: ~A"
|
|---|
| 192 | (unix:get-unix-error-msg ino)))))
|
|---|
| 193 | (delete-buffer-if-possible buffer)))))
|
|---|
| 194 |
|
|---|
| 195 |
|
|---|
| 196 | |
|---|
| 197 |
|
|---|
| 198 | ;;;; Check Out
|
|---|
| 199 |
|
|---|
| 200 | (defhvar "RCS Check Out File Hook"
|
|---|
| 201 | "RCS Check Out File Hook"
|
|---|
| 202 | :value nil)
|
|---|
| 203 |
|
|---|
| 204 | (defvar *translate-file-names-before-locking* nil)
|
|---|
| 205 |
|
|---|
| 206 | (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
|
|---|
| 207 | (when (and lock *translate-file-names-before-locking*)
|
|---|
| 208 | (multiple-value-bind (unmatched-dir new-dirs file-name)
|
|---|
| 209 | (maybe-translate-definition-file pathname)
|
|---|
| 210 | (when new-dirs
|
|---|
| 211 | (let ((new-name (translate-definition-file unmatched-dir
|
|---|
| 212 | (car new-dirs)
|
|---|
| 213 | file-name)))
|
|---|
| 214 | (when (probe-file (directory-namestring new-name))
|
|---|
| 215 | (setf pathname new-name))))))
|
|---|
| 216 | (cond
|
|---|
| 217 | ((and (not always-overwrite-p)
|
|---|
| 218 | (let ((pn (probe-file pathname)))
|
|---|
| 219 | (and pn (hemlock-ext:file-writable pn))))
|
|---|
| 220 | ;; File exists and is writable so check and see if the user really
|
|---|
| 221 | ;; wants to check it out.
|
|---|
| 222 | (command-case (:prompt
|
|---|
| 223 | (format nil "The file ~A is writable. Overwrite? "
|
|---|
| 224 | (file-namestring pathname))
|
|---|
| 225 | :help
|
|---|
| 226 | "Type one of the following single-character commands:")
|
|---|
| 227 | ((:yes :confirm)
|
|---|
| 228 | "Overwrite the file."
|
|---|
| 229 | (rcs-check-out-file buffer pathname lock))
|
|---|
| 230 | (:no
|
|---|
| 231 | "Don't check it out after all.")
|
|---|
| 232 | ((#\r #\R)
|
|---|
| 233 | "Rename the file before checking it out."
|
|---|
| 234 | (let ((new-pathname (prompt-for-file
|
|---|
| 235 | :prompt "New Filename: "
|
|---|
| 236 | :default (buffer-default-pathname
|
|---|
| 237 | (current-buffer))
|
|---|
| 238 | :must-exist nil)))
|
|---|
| 239 | (rename-file pathname new-pathname)
|
|---|
| 240 | (rcs-check-out-file buffer pathname lock)))))
|
|---|
| 241 | (t
|
|---|
| 242 | (rcs-check-out-file buffer pathname lock)))
|
|---|
| 243 | pathname)
|
|---|
| 244 |
|
|---|
| 245 | (defun rcs-check-out-file (buffer pathname lock)
|
|---|
| 246 | (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
|
|---|
| 247 | (in-directory pathname
|
|---|
| 248 | (let* ((file (file-namestring pathname))
|
|---|
| 249 | (backup (if (probe-file file)
|
|---|
| 250 | (lisp::pick-backup-name file))))
|
|---|
| 251 | (when backup (rename-file file backup))
|
|---|
| 252 | (do-command "co" `(,@(if lock '("-l")) ,file))
|
|---|
| 253 | (invoke-hook rcs-check-out-file-hook buffer pathname)
|
|---|
| 254 | (when backup (delete-file backup)))))
|
|---|
| 255 |
|
|---|
| 256 | |
|---|
| 257 |
|
|---|
| 258 | ;;;; Last Command Output
|
|---|
| 259 |
|
|---|
| 260 | (defcommand "RCS Last Command Output" (p)
|
|---|
| 261 | "Print the full output of the last RCS command."
|
|---|
| 262 | "Print the full output of the last RCS command."
|
|---|
| 263 | (declare (ignore p))
|
|---|
| 264 | (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
|
|---|
| 265 | (editor-error "No RCS commands have executed!"))
|
|---|
| 266 | (with-pop-up-display (s :buffer-name "*RCS Command Output*")
|
|---|
| 267 | (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
|
|---|
| 268 | (write-line *last-rcs-command-output-string* s)))
|
|---|
| 269 |
|
|---|
| 270 | |
|---|
| 271 |
|
|---|
| 272 | ;;;; Commands for Checking In / Checking Out and Locking / Unlocking
|
|---|
| 273 |
|
|---|
| 274 | (defun pick-temp-file (defaults)
|
|---|
| 275 | (let ((index 0))
|
|---|
| 276 | (loop
|
|---|
| 277 | (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
|
|---|
| 278 | (cond ((probe-file name)
|
|---|
| 279 | (incf index))
|
|---|
| 280 | (t
|
|---|
| 281 | (return name)))))))
|
|---|
| 282 |
|
|---|
| 283 | (defcommand "RCS Lock Buffer File" (p)
|
|---|
| 284 | "Attempt to lock the file in the current buffer."
|
|---|
| 285 | "Attempt to lock the file in the current buffer."
|
|---|
| 286 | (declare (ignore p))
|
|---|
| 287 | (let ((file (current-buffer-pathname))
|
|---|
| 288 | (buffer (current-buffer))
|
|---|
| 289 | (name (pick-temp-file "/tmp/")))
|
|---|
| 290 | (rcs-lock-file buffer file)
|
|---|
| 291 | (unwind-protect
|
|---|
| 292 | (progn
|
|---|
| 293 | (in-directory file
|
|---|
| 294 | (do-command "co" `("-p" ,(file-namestring file))
|
|---|
| 295 | :output (namestring name)))
|
|---|
| 296 | (when (buffer-different-from-file buffer name)
|
|---|
| 297 | (message
|
|---|
| 298 | "RCS file is different; be sure to merge in your changes."))
|
|---|
| 299 | (setf (buffer-writable buffer) t)
|
|---|
| 300 | (message "Buffer is now writable."))
|
|---|
| 301 | (when (probe-file name)
|
|---|
| 302 | (delete-file name)))))
|
|---|
| 303 |
|
|---|
| 304 | (defcommand "RCS Lock File" (p)
|
|---|
| 305 | "Prompt for a file, and attempt to lock it."
|
|---|
| 306 | "Prompt for a file, and attempt to lock it."
|
|---|
| 307 | (declare (ignore p))
|
|---|
| 308 | (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
|
|---|
| 309 | :default (buffer-default-pathname
|
|---|
| 310 | (current-buffer))
|
|---|
| 311 | :must-exist nil)))
|
|---|
| 312 |
|
|---|
| 313 | (defcommand "RCS Unlock Buffer File" (p)
|
|---|
| 314 | "Unlock the file in the current buffer."
|
|---|
| 315 | "Unlock the file in the current buffer."
|
|---|
| 316 | (declare (ignore p))
|
|---|
| 317 | (rcs-unlock-file (current-buffer) (current-buffer-pathname))
|
|---|
| 318 | (setf (buffer-writable (current-buffer)) nil)
|
|---|
| 319 | (message "Buffer is no longer writable."))
|
|---|
| 320 |
|
|---|
| 321 | (defcommand "RCS Unlock File" (p)
|
|---|
| 322 | "Prompt for a file, and attempt to unlock it."
|
|---|
| 323 | "Prompt for a file, and attempt to unlock it."
|
|---|
| 324 | (declare (ignore p))
|
|---|
| 325 | (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
|
|---|
| 326 | :default (buffer-default-pathname
|
|---|
| 327 | (current-buffer))
|
|---|
| 328 | :must-exist nil)))
|
|---|
| 329 |
|
|---|
| 330 | (defcommand "RCS Check In Buffer File" (p)
|
|---|
| 331 | "Checkin the file in the current buffer. With an argument, do not
|
|---|
| 332 | release the lock."
|
|---|
| 333 | "Checkin the file in the current buffer. With an argument, do not
|
|---|
| 334 | release the lock."
|
|---|
| 335 | (let ((buffer (current-buffer))
|
|---|
| 336 | (pathname (current-buffer-pathname)))
|
|---|
| 337 | (when (buffer-modified buffer)
|
|---|
| 338 | (save-file-command nil))
|
|---|
| 339 | (rcs-check-in-file buffer pathname p)
|
|---|
| 340 | (when (member buffer *buffer-list*)
|
|---|
| 341 | ;; If the buffer has not been deleted, make sure it is up to date
|
|---|
| 342 | ;; with respect to the file.
|
|---|
| 343 | (visit-file-command nil pathname buffer))))
|
|---|
| 344 |
|
|---|
| 345 | (defcommand "RCS Check In File" (p)
|
|---|
| 346 | "Prompt for a file, and attempt to check it in. With an argument, do
|
|---|
| 347 | not release the lock."
|
|---|
| 348 | "Prompt for a file, and attempt to check it in. With an argument, do
|
|---|
| 349 | not release the lock."
|
|---|
| 350 | (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
|
|---|
| 351 | :default
|
|---|
| 352 | (buffer-default-pathname
|
|---|
| 353 | (current-buffer))
|
|---|
| 354 | :must-exist nil)
|
|---|
| 355 | p))
|
|---|
| 356 |
|
|---|
| 357 | (defcommand "RCS Check Out Buffer File" (p)
|
|---|
| 358 | "Checkout the file in the current buffer. With an argument, lock the
|
|---|
| 359 | file."
|
|---|
| 360 | "Checkout the file in the current buffer. With an argument, lock the
|
|---|
| 361 | file."
|
|---|
| 362 | (let* ((buffer (current-buffer))
|
|---|
| 363 | (pathname (current-buffer-pathname))
|
|---|
| 364 | (point (current-point))
|
|---|
| 365 | (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
|
|---|
| 366 | (when (buffer-modified buffer)
|
|---|
| 367 | (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
|
|---|
| 368 | (editor-error "Aborted.")))
|
|---|
| 369 | (setf (buffer-modified buffer) nil)
|
|---|
| 370 | (setf pathname (maybe-rcs-check-out-file buffer pathname p nil))
|
|---|
| 371 | (when p
|
|---|
| 372 | (setf (buffer-writable buffer) t)
|
|---|
| 373 | (message "Buffer is now writable."))
|
|---|
| 374 | (visit-file-command nil pathname)
|
|---|
| 375 | (unless (line-offset point lines)
|
|---|
| 376 | (buffer-end point))))
|
|---|
| 377 |
|
|---|
| 378 | (defcommand "RCS Check Out File" (p)
|
|---|
| 379 | "Prompt for a file and attempt to check it out. With an argument,
|
|---|
| 380 | lock the file."
|
|---|
| 381 | "Prompt for a file and attempt to check it out. With an argument,
|
|---|
| 382 | lock the file."
|
|---|
| 383 | (let ((pathname (prompt-for-file :prompt "File to check out: "
|
|---|
| 384 | :default (buffer-default-pathname
|
|---|
| 385 | (current-buffer))
|
|---|
| 386 | :must-exist nil)))
|
|---|
| 387 | (setf pathname (maybe-rcs-check-out-file nil pathname p nil))
|
|---|
| 388 | (find-file-command nil pathname)))
|
|---|
| 389 |
|
|---|
| 390 | |
|---|
| 391 |
|
|---|
| 392 | ;;;; Log File
|
|---|
| 393 |
|
|---|
| 394 | (defhvar "RCS Log Entry Buffer"
|
|---|
| 395 | "Name of the buffer to put RCS log entries into."
|
|---|
| 396 | :value "RCS Log")
|
|---|
| 397 |
|
|---|
| 398 | (defhvar "RCS Log Buffer Hook"
|
|---|
| 399 | "RCS Log Buffer Hook"
|
|---|
| 400 | :value nil)
|
|---|
| 401 |
|
|---|
| 402 | (defun get-log-buffer ()
|
|---|
| 403 | (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
|
|---|
| 404 | (unless buffer
|
|---|
| 405 | (setf buffer (make-buffer (value rcs-log-entry-buffer)))
|
|---|
| 406 | (turn-auto-save-off buffer)
|
|---|
| 407 | (invoke-hook rcs-log-buffer-hook buffer))
|
|---|
| 408 | buffer))
|
|---|
| 409 |
|
|---|
| 410 | (defcommand "RCS Buffer File Log Entry" (p)
|
|---|
| 411 | "Get the RCS Log for the file in the current buffer in a buffer."
|
|---|
| 412 | "Get the RCS Log for the file in the current buffer in a buffer."
|
|---|
| 413 | (declare (ignore p))
|
|---|
| 414 | (let ((buffer (get-log-buffer))
|
|---|
| 415 | (pathname (current-buffer-pathname)))
|
|---|
| 416 | (delete-region (buffer-region buffer))
|
|---|
| 417 | (message "Extracting log info ...")
|
|---|
| 418 | (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
|
|---|
| 419 | (in-directory pathname
|
|---|
| 420 | (do-command "rlog" (list (file-namestring pathname))
|
|---|
| 421 | :output (make-hemlock-output-stream mark))))
|
|---|
| 422 | (change-to-buffer buffer)
|
|---|
| 423 | (buffer-start (current-point))
|
|---|
| 424 | (setf (buffer-modified buffer) nil)))
|
|---|
| 425 |
|
|---|
| 426 | (defcommand "RCS File Log Entry" (p)
|
|---|
| 427 | "Prompt for a file and get its RCS log entry in a buffer."
|
|---|
| 428 | "Prompt for a file and get its RCS log entry in a buffer."
|
|---|
| 429 | (declare (ignore p))
|
|---|
| 430 | (let ((file (prompt-for-file :prompt "File to get log of: "
|
|---|
| 431 | :default (buffer-default-pathname
|
|---|
| 432 | (current-buffer))
|
|---|
| 433 | :must-exist nil))
|
|---|
| 434 | (buffer (get-log-buffer)))
|
|---|
| 435 | (delete-region (buffer-region buffer))
|
|---|
| 436 | (message "Extracing log info ...")
|
|---|
| 437 | (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
|
|---|
| 438 | (in-directory file
|
|---|
| 439 | (do-command "rlog" (list (file-namestring file))
|
|---|
| 440 | :output (make-hemlock-output-stream mark))))
|
|---|
| 441 | (change-to-buffer buffer)
|
|---|
| 442 | (buffer-start (current-point))
|
|---|
| 443 | (setf (buffer-modified buffer) nil)))
|
|---|
| 444 |
|
|---|
| 445 | |
|---|
| 446 |
|
|---|
| 447 | ;;;; Status and Modeline Frobs.
|
|---|
| 448 |
|
|---|
| 449 | (defhvar "RCS Status"
|
|---|
| 450 | "RCS status of this buffer. Either nil, :locked, :out-of-date, or
|
|---|
| 451 | :unlocked."
|
|---|
| 452 | :value nil)
|
|---|
| 453 |
|
|---|
| 454 | ;;;
|
|---|
| 455 | ;;; Note: This doesn't behave correctly w/r/t to branched files.
|
|---|
| 456 | ;;;
|
|---|
| 457 | (defun rcs-file-status (pathname)
|
|---|
| 458 | (let* ((directory (directory-namestring pathname))
|
|---|
| 459 | (filename (file-namestring pathname))
|
|---|
| 460 | (rcs-file (concatenate 'simple-string directory
|
|---|
| 461 | "RCS/" filename ",v")))
|
|---|
| 462 | (if (probe-file rcs-file)
|
|---|
| 463 | ;; This is an RCS file
|
|---|
| 464 | (let ((probe-file (probe-file pathname)))
|
|---|
| 465 | (cond ((and probe-file (hemlock-ext:file-writable probe-file))
|
|---|
| 466 | :locked)
|
|---|
| 467 | ((or (not probe-file)
|
|---|
| 468 | (< (file-write-date pathname)
|
|---|
| 469 | (file-write-date rcs-file)))
|
|---|
| 470 | :out-of-date)
|
|---|
| 471 | (t
|
|---|
| 472 | :unlocked))))))
|
|---|
| 473 |
|
|---|
| 474 | (defun rcs-update-buffer-status (buffer &optional tn)
|
|---|
| 475 | (unless (hemlock-bound-p 'rcs-status :buffer buffer)
|
|---|
| 476 | (defhvar "RCS Status"
|
|---|
| 477 | "RCS Status of this buffer."
|
|---|
| 478 | :buffer buffer
|
|---|
| 479 | :value nil))
|
|---|
| 480 | (let ((tn (or tn (buffer-pathname buffer))))
|
|---|
| 481 | (setf (variable-value 'rcs-status :buffer buffer)
|
|---|
| 482 | (if tn (rcs-file-status tn))))
|
|---|
| 483 | (hi::update-modelines-for-buffer buffer))
|
|---|
| 484 | ;;;
|
|---|
| 485 | (add-hook read-file-hook 'rcs-update-buffer-status)
|
|---|
| 486 | (add-hook write-file-hook 'rcs-update-buffer-status)
|
|---|
| 487 |
|
|---|
| 488 | (defcommand "RCS Update All RCS Status Variables" (p)
|
|---|
| 489 | "Update the ``RCS Status'' variable for all buffers."
|
|---|
| 490 | "Update the ``RCS Status'' variable for all buffers."
|
|---|
| 491 | (declare (ignore p))
|
|---|
| 492 | (dolist (buffer *buffer-list*)
|
|---|
| 493 | (rcs-update-buffer-status buffer))
|
|---|
| 494 | (dolist (window *window-list*)
|
|---|
| 495 | (update-modeline-fields (window-buffer window) window)))
|
|---|
| 496 |
|
|---|
| 497 | ;;;
|
|---|
| 498 | ;;; Action Hooks
|
|---|
| 499 | (defun rcs-action-hook (buffer pathname)
|
|---|
| 500 | (cond (buffer
|
|---|
| 501 | (rcs-update-buffer-status buffer))
|
|---|
| 502 | (t
|
|---|
| 503 | (let ((pathname (probe-file pathname)))
|
|---|
| 504 | (when pathname
|
|---|
| 505 | (dolist (buffer *buffer-list*)
|
|---|
| 506 | (let ((buffer-pathname (buffer-pathname buffer)))
|
|---|
| 507 | (when (equal pathname buffer-pathname)
|
|---|
| 508 | (rcs-update-buffer-status buffer)))))))))
|
|---|
| 509 | ;;;
|
|---|
| 510 | (add-hook rcs-check-in-file-hook 'rcs-action-hook)
|
|---|
| 511 | (add-hook rcs-check-out-file-hook 'rcs-action-hook)
|
|---|
| 512 | (add-hook rcs-lock-file-hook 'rcs-action-hook)
|
|---|
| 513 | (add-hook rcs-unlock-file-hook 'rcs-action-hook)
|
|---|
| 514 |
|
|---|
| 515 |
|
|---|
| 516 | ;;;
|
|---|
| 517 | ;;; RCS Modeline Field
|
|---|
| 518 | (make-modeline-field
|
|---|
| 519 | :name :rcs-status
|
|---|
| 520 | :function #'(lambda (buffer window)
|
|---|
| 521 | (declare (ignore buffer window))
|
|---|
| 522 | (ecase (value rcs-status)
|
|---|
| 523 | (:out-of-date "[OLD] ")
|
|---|
| 524 | (:locked "[LOCKED] ")
|
|---|
| 525 | (:unlocked "[RCS] ")
|
|---|
| 526 | ((nil) ""))))
|
|---|
