/[cmucl]/src/hemlock/rcs.lisp
ViewVC logotype

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5