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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Sun Dec 6 15:52:19 1992 UTC (21 years, 4 months ago) by wlott
Branch: MAIN
Changes since 1.26: +2 -2 lines
Fixed MAYBE-RCS-CHECK-OUT-FILE to test to see if new-dirs of the
translation is not nil instead of checking unmatched-dir because
unmatched-dir might be nil even if there is a valid translation.
1 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 ;;;
3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.27 1992/12/06 15:52:19 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) (unix:unix-stat file)
90 (declare (ignore ino))
91 (cond (won
92 (unix:unix-chmod file (logior mode unix:writeown)))
93 (t
94 (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
95 (unix: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 (when (member old-buffer *buffer-list*)
152 (change-to-buffer old-buffer))
153 (setf allow-delete t)
154 (delete-buffer-if-possible log-buffer))))
155
156 (defun sub-check-in-file (pathname buffer keep-lock log-stream)
157 (let* ((filename (file-namestring pathname))
158 (rcs-filename (concatenate 'simple-string
159 "./RCS/" filename ",v"))
160 (keep-working-copy (or keep-lock
161 (not (hemlock-bound-p
162 'rcs-keep-around-after-unlocking
163 :buffer buffer))
164 (variable-value
165 'rcs-keep-around-after-unlocking
166 :buffer buffer))))
167 (in-directory pathname
168 (do-command "rcsci" `(,@(if keep-lock '("-l"))
169 ,@(if keep-working-copy '("-u"))
170 ,filename)
171 :input log-stream)
172 (if keep-working-copy
173 ;;
174 ;; Set the times on the user's file to be equivalent to that of
175 ;; the rcs file.
176 (multiple-value-bind
177 (dev ino mode nlink uid gid rdev size atime mtime)
178 (unix:unix-stat rcs-filename)
179 (declare (ignore mode nlink uid gid rdev size))
180 (cond (dev
181 (multiple-value-bind
182 (wonp errno)
183 (unix:unix-utimes filename atime 0 mtime 0)
184 (unless wonp
185 (editor-error "UNIX:UNIX-UTIMES failed: ~A"
186 (unix:get-unix-error-msg errno)))))
187 (t
188 (editor-error "UNIX:UNIX-STAT failed: ~A"
189 (unix:get-unix-error-msg ino)))))
190 (delete-buffer-if-possible buffer)))))
191
192
193
194 ;;;; Check Out
195
196 (defhvar "RCS Check Out File Hook"
197 "RCS Check Out File Hook"
198 :value nil)
199
200 (defvar *translate-file-names-before-locking* nil)
201
202 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
203 (when (and lock *translate-file-names-before-locking*)
204 (multiple-value-bind (unmatched-dir new-dirs file-name)
205 (maybe-translate-definition-file pathname)
206 (when new-dirs
207 (let ((new-name (translate-definition-file unmatched-dir
208 (car new-dirs)
209 file-name)))
210 (when (probe-file (directory-namestring new-name))
211 (setf pathname new-name))))))
212 (cond
213 ((and (not always-overwrite-p)
214 (let ((pn (probe-file pathname)))
215 (and pn (ext:file-writable pn))))
216 ;; File exists and is writable so check and see if the user really
217 ;; wants to check it out.
218 (command-case (:prompt
219 (format nil "The file ~A is writable. Overwrite? "
220 (file-namestring pathname))
221 :help
222 "Type one of the following single-character commands:")
223 ((:yes :confirm)
224 "Overwrite the file."
225 (rcs-check-out-file buffer pathname lock))
226 (:no
227 "Don't check it out after all.")
228 ((#\r #\R)
229 "Rename the file before checking it out."
230 (let ((new-pathname (prompt-for-file
231 :prompt "New Filename: "
232 :default (buffer-default-pathname
233 (current-buffer))
234 :must-exist nil)))
235 (rename-file pathname new-pathname)
236 (rcs-check-out-file buffer pathname lock)))))
237 (t
238 (rcs-check-out-file buffer pathname lock)))
239 pathname)
240
241 (defun rcs-check-out-file (buffer pathname lock)
242 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
243 (in-directory pathname
244 (let* ((file (file-namestring pathname))
245 (backup (if (probe-file file)
246 (lisp::pick-backup-name file))))
247 (when backup (rename-file file backup))
248 (do-command "rcsco" `(,@(if lock '("-l")) ,file))
249 (invoke-hook rcs-check-out-file-hook buffer pathname)
250 (when backup (delete-file backup)))))
251
252
253 ;;;; Last Command Output
254
255 (defcommand "RCS Last Command Output" (p)
256 "Print the full output of the last RCS command."
257 "Print the full output of the last RCS command."
258 (declare (ignore p))
259 (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
260 (editor-error "No RCS commands have executed!"))
261 (with-pop-up-display (s :buffer-name "*RCS Command Output*")
262 (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
263 (write-line *last-rcs-command-output-string* s)))
264
265
266 ;;;; Commands for Checking In / Checking Out and Locking / Unlocking
267
268 (defun pick-temp-file (defaults)
269 (let ((index 0))
270 (loop
271 (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
272 (cond ((probe-file name)
273 (incf index))
274 (t
275 (return name)))))))
276
277 (defcommand "RCS Lock Buffer File" (p)
278 "Attempt to lock the file in the current buffer."
279 "Attempt to lock the file in the current buffer."
280 (declare (ignore p))
281 (let ((file (current-buffer-pathname))
282 (buffer (current-buffer))
283 (name (pick-temp-file "/tmp/")))
284 (rcs-lock-file buffer file)
285 (unwind-protect
286 (progn
287 (in-directory file
288 (do-command "rcsco" `("-p" ,(file-namestring file))
289 :output (namestring name)))
290 (when (buffer-different-from-file buffer name)
291 (message
292 "RCS file is different; be sure to merge in your changes."))
293 (setf (buffer-writable buffer) t)
294 (message "Buffer is now writable."))
295 (when (probe-file name)
296 (delete-file name)))))
297
298 (defcommand "RCS Lock File" (p)
299 "Prompt for a file, and attempt to lock it."
300 "Prompt for a file, and attempt to lock it."
301 (declare (ignore p))
302 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
303 :default (buffer-default-pathname
304 (current-buffer))
305 :must-exist nil)))
306
307 (defcommand "RCS Unlock Buffer File" (p)
308 "Unlock the file in the current buffer."
309 "Unlock the file in the current buffer."
310 (declare (ignore p))
311 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
312 (setf (buffer-writable (current-buffer)) nil)
313 (message "Buffer is no longer writable."))
314
315 (defcommand "RCS Unlock File" (p)
316 "Prompt for a file, and attempt to unlock it."
317 "Prompt for a file, and attempt to unlock it."
318 (declare (ignore p))
319 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
320 :default (buffer-default-pathname
321 (current-buffer))
322 :must-exist nil)))
323
324 (defcommand "RCS Check In Buffer File" (p)
325 "Checkin the file in the current buffer. With an argument, do not
326 release the lock."
327 "Checkin the file in the current buffer. With an argument, do not
328 release the lock."
329 (let ((buffer (current-buffer))
330 (pathname (current-buffer-pathname)))
331 (when (buffer-modified buffer)
332 (save-file-command nil))
333 (rcs-check-in-file buffer pathname p)
334 (when (member buffer *buffer-list*)
335 ;; If the buffer has not been deleted, make sure it is up to date
336 ;; with respect to the file.
337 (visit-file-command nil pathname buffer))))
338
339 (defcommand "RCS Check In File" (p)
340 "Prompt for a file, and attempt to check it in. With an argument, do
341 not release the lock."
342 "Prompt for a file, and attempt to check it in. With an argument, do
343 not release the lock."
344 (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
345 :default
346 (buffer-default-pathname
347 (current-buffer))
348 :must-exist nil)
349 p))
350
351 (defcommand "RCS Check Out Buffer File" (p)
352 "Checkout the file in the current buffer. With an argument, lock the
353 file."
354 "Checkout the file in the current buffer. With an argument, lock the
355 file."
356 (let* ((buffer (current-buffer))
357 (pathname (current-buffer-pathname))
358 (point (current-point))
359 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
360 (when (buffer-modified buffer)
361 (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
362 (editor-error "Aborted.")))
363 (setf (buffer-modified buffer) nil)
364 (setf pathname (maybe-rcs-check-out-file buffer pathname p nil))
365 (when p
366 (setf (buffer-writable buffer) t)
367 (message "Buffer is now writable."))
368 (visit-file-command nil pathname)
369 (unless (line-offset point lines)
370 (buffer-end point))))
371
372 (defcommand "RCS Check Out File" (p)
373 "Prompt for a file and attempt to check it out. With an argument,
374 lock the file."
375 "Prompt for a file and attempt to check it out. With an argument,
376 lock the file."
377 (let ((pathname (prompt-for-file :prompt "File to check out: "
378 :default (buffer-default-pathname
379 (current-buffer))
380 :must-exist nil)))
381 (setf pathname (maybe-rcs-check-out-file nil pathname p nil))
382 (find-file-command nil pathname)))
383
384
385 ;;;; Log File
386
387 (defhvar "RCS Log Entry Buffer"
388 "Name of the buffer to put RCS log entries into."
389 :value "RCS Log")
390
391 (defhvar "RCS Log Buffer Hook"
392 "RCS Log Buffer Hook"
393 :value nil)
394
395 (defun get-log-buffer ()
396 (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
397 (unless buffer
398 (setf buffer (make-buffer (value rcs-log-entry-buffer)))
399 (turn-auto-save-off buffer)
400 (invoke-hook rcs-log-buffer-hook buffer))
401 buffer))
402
403 (defcommand "RCS Buffer File Log Entry" (p)
404 "Get the RCS Log for the file in the current buffer in a buffer."
405 "Get the RCS Log for the file in the current buffer in a buffer."
406 (declare (ignore p))
407 (let ((buffer (get-log-buffer))
408 (pathname (current-buffer-pathname)))
409 (delete-region (buffer-region buffer))
410 (message "Extracting log info ...")
411 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
412 (in-directory pathname
413 (do-command "rlog" (list (file-namestring pathname))
414 :output (make-hemlock-output-stream mark))))
415 (change-to-buffer buffer)
416 (buffer-start (current-point))
417 (setf (buffer-modified buffer) nil)))
418
419 (defcommand "RCS File Log Entry" (p)
420 "Prompt for a file and get its RCS log entry in a buffer."
421 "Prompt for a file and get its RCS log entry in a buffer."
422 (declare (ignore p))
423 (let ((file (prompt-for-file :prompt "File to get log of: "
424 :default (buffer-default-pathname
425 (current-buffer))
426 :must-exist nil))
427 (buffer (get-log-buffer)))
428 (delete-region (buffer-region buffer))
429 (message "Extracing log info ...")
430 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
431 (in-directory file
432 (do-command "rlog" (list (file-namestring file))
433 :output (make-hemlock-output-stream mark))))
434 (change-to-buffer buffer)
435 (buffer-start (current-point))
436 (setf (buffer-modified buffer) nil)))
437
438
439 ;;;; Status and Modeline Frobs.
440
441 (defhvar "RCS Status"
442 "RCS status of this buffer. Either nil, :locked, :out-of-date, or
443 :unlocked."
444 :value nil)
445
446 ;;;
447 ;;; Note: This doesn't behave correctly w/r/t to branched files.
448 ;;;
449 (defun rcs-file-status (pathname)
450 (let* ((directory (directory-namestring pathname))
451 (filename (file-namestring pathname))
452 (rcs-file (concatenate 'simple-string directory
453 "RCS/" filename ",v")))
454 (if (probe-file rcs-file)
455 ;; This is an RCS file
456 (let ((probe-file (probe-file pathname)))
457 (cond ((and probe-file (file-writable probe-file))
458 :locked)
459 ((or (not probe-file)
460 (< (file-write-date pathname)
461 (file-write-date rcs-file)))
462 :out-of-date)
463 (t
464 :unlocked))))))
465
466 (defun rcs-update-buffer-status (buffer &optional tn)
467 (unless (hemlock-bound-p 'rcs-status :buffer buffer)
468 (defhvar "RCS Status"
469 "RCS Status of this buffer."
470 :buffer buffer
471 :value nil))
472 (let ((tn (or tn (buffer-pathname buffer))))
473 (setf (variable-value 'rcs-status :buffer buffer)
474 (if tn (rcs-file-status tn))))
475 (hi::update-modelines-for-buffer buffer))
476 ;;;
477 (add-hook read-file-hook 'rcs-update-buffer-status)
478 (add-hook write-file-hook 'rcs-update-buffer-status)
479
480 (defcommand "RCS Update All RCS Status Variables" (p)
481 "Update the ``RCS Status'' variable for all buffers."
482 "Update the ``RCS Status'' variable for all buffers."
483 (declare (ignore p))
484 (dolist (buffer *buffer-list*)
485 (rcs-update-buffer-status buffer))
486 (dolist (window *window-list*)
487 (update-modeline-fields (window-buffer window) window)))
488
489 ;;;
490 ;;; Action Hooks
491 (defun rcs-action-hook (buffer pathname)
492 (cond (buffer
493 (rcs-update-buffer-status buffer))
494 (t
495 (let ((pathname (probe-file pathname)))
496 (when pathname
497 (dolist (buffer *buffer-list*)
498 (let ((buffer-pathname (buffer-pathname buffer)))
499 (when (equal pathname buffer-pathname)
500 (rcs-update-buffer-status buffer)))))))))
501 ;;;
502 (add-hook rcs-check-in-file-hook 'rcs-action-hook)
503 (add-hook rcs-check-out-file-hook 'rcs-action-hook)
504 (add-hook rcs-lock-file-hook 'rcs-action-hook)
505 (add-hook rcs-unlock-file-hook 'rcs-action-hook)
506
507
508 ;;;
509 ;;; RCS Modeline Field
510 (make-modeline-field
511 :name :rcs-status
512 :function #'(lambda (buffer window)
513 (declare (ignore buffer window))
514 (ecase (value rcs-status)
515 (:out-of-date "[OLD] ")
516 (:locked "[LOCKED] ")
517 (:unlocked "[RCS] ")
518 ((nil) ""))))

  ViewVC Help
Powered by ViewVC 1.1.5