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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.16 - (show annotations)
Wed May 30 16:27:22 1990 UTC (23 years, 10 months ago) by ch
Branch: MAIN
Changes since 1.15: +124 -20 lines
Added RCS Status support and modeline cruft.

Changed error handling.  Added ``RCS Last Command Output'' command to see
the last command's output.
1 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 ;;;
3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.16 1990/05/30 16:27:22 ch 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 more ~
48 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 (defun rcs-check-in-file (buffer pathname keep-lock)
117 (let ((old-buffer (current-buffer))
118 (allow-delete nil)
119 (log-buffer nil))
120 (unwind-protect
121 (when (block in-recursive-edit
122 (do ((i 0 (1+ i)))
123 ((not (null log-buffer)))
124 (setf log-buffer
125 (make-buffer
126 (format nil "RCS Log Entry ~D for ~S" i
127 (file-namestring pathname))
128 :modes '("Text")
129 :delete-hook
130 (list #'(lambda (buffer)
131 (declare (ignore buffer))
132 (unless allow-delete
133 (return-from in-recursive-edit t)))))))
134 (turn-auto-save-off log-buffer)
135 (change-to-buffer log-buffer)
136 (do-recursive-edit)
137
138 (message "Checking in ~A~:[~; keeping the lock~] ..."
139 (namestring pathname) keep-lock)
140 (let ((log-stream (make-hemlock-region-stream
141 (buffer-region log-buffer))))
142 (sub-check-in-file pathname keep-lock log-stream))
143 (invoke-hook rcs-check-in-file-hook buffer pathname)
144 nil)
145 (editor-error "Someone deleted the RCS Log Entry buffer."))
146 (change-to-buffer old-buffer)
147 (setf allow-delete t)
148 (delete-buffer-if-possible log-buffer))))
149
150 (defun sub-check-in-file (pathname keep-lock log-stream)
151 (let* ((filename (file-namestring pathname))
152 (rcs-filename (concatenate 'simple-string
153 "./RCS/" filename ",v")))
154 (in-directory pathname
155 (do-command "rcsci" `(,@(if keep-lock '("-l"))
156 "-u"
157 ,filename)
158 :input log-stream)
159 ;;
160 ;; Set the times on the user's file to be equivalent to that of
161 ;; the rcs file.
162 (multiple-value-bind
163 (dev ino mode nlink uid gid rdev size atime mtime)
164 (mach:unix-stat rcs-filename)
165 (declare (ignore mode nlink uid gid rdev size))
166 (cond (dev
167 (multiple-value-bind
168 (wonp errno)
169 (mach:unix-utimes filename (list atime 0 mtime 0))
170 (unless wonp
171 (editor-error "MACH:UNIX-UTIMES failed: ~A"
172 (mach:get-unix-error-msg errno)))))
173 (t
174 (editor-error "MACH:UNIX-STAT failed: ~A"
175 (mach:get-unix-error-msg ino))))))))
176
177
178 ;;;; Check Out
179
180 (defhvar "RCS Check Out File Hook"
181 "RCS Check Out File Hook"
182 :value nil)
183
184 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
185 (sub-maybe-rcs-check-out-files buffer (list pathname)
186 lock always-overwrite-p))
187
188 (defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
189 (sub-maybe-rcs-check-out-files nil pathnames lock always-overwrite-p))
190
191 (defun sub-maybe-rcs-check-out-files (buffer pathnames lock always-overwrite-p)
192 (let ((check-out-count 0))
193 (macrolet ((frob ()
194 `(progn
195 (rcs-check-out-file buffer pathname lock)
196 (incf check-out-count))))
197 (dolist (pathname pathnames)
198 (cond
199 ((and (not always-overwrite-p)
200 (probe-file pathname) (ext:file-writable pathname))
201 ;; File exists and is writable so check and see if the user really
202 ;; wants to check it out.
203 (command-case (:prompt
204 (format nil "The file ~A is writable. Overwrite? "
205 (file-namestring pathname))
206 :help
207 "Type one of the following single-character commands:")
208 ((:yes :confirm)
209 "Overwrite the file."
210 (frob))
211 (:no
212 "Skip checking out this file.")
213 ((#\r #\R)
214 "Rename the file before checking it out."
215 (let ((new-pathname (prompt-for-file
216 :prompt "New Filename: "
217 :default (buffer-default-pathname
218 (current-buffer))
219 :must-exist nil)))
220 (rename-file pathname new-pathname)
221 (frob)))
222 (:do-all
223 "Overwrite this file and all remaining files."
224 (setf always-overwrite-p t)
225 (frob))
226 (:do-once
227 "Overwrite this file and then exit."
228 (frob)
229 (return))))
230 (t
231 (frob)))))
232 check-out-count))
233
234 (defun rcs-check-out-file (buffer pathname lock)
235 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
236 (in-directory pathname
237 (let ((backup
238 (if (probe-file pathname)
239 (lisp::pick-backup-name (namestring pathname))
240 nil)))
241 (when backup (rename-file pathname backup))
242 (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
243 (invoke-hook rcs-check-out-file-hook buffer pathname)
244 (when backup (delete-file backup)))))
245
246 (defun pick-temp-file (defaults)
247 (let ((index 0))
248 (loop
249 (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
250 (cond ((probe-file name)
251 (incf index))
252 (t
253 (return name)))))))
254
255
256 ;;;; Last Command Output
257
258 (defcommand "RCS Last Command Output" (p)
259 "Print the full output of the last RCS command."
260 "Print the full output of the last RCS command."
261 (declare (ignore p))
262 (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
263 (editor-error "No RCS commands have executed!"))
264 (with-pop-up-display (s :buffer-name "*RCS Command Output*")
265 (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
266 (write-line *last-rcs-command-output-string* s)))
267
268
269 ;;;; Checking In / Checking Out and Locking / Unlocking
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 (maybe-rcs-check-out-file buffer pathname p nil)
355 (setf (buffer-modified buffer) 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 (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 ;;;; Directory Support
431
432 (defun list-out-of-date-files (dir)
433 (let ((rcsdir (make-pathname :host (pathname-host dir)
434 :device (pathname-device dir)
435 :directory (concatenate 'simple-vector
436 (pathname-directory dir)
437 (vector "RCS"))))
438 (out-of-date-files nil))
439 (unless (directoryp rcsdir)
440 (editor-error "Could not find the RCS directory."))
441 (dolist (rcsfile (directory rcsdir))
442 (let ((rcsname (file-namestring rcsfile)))
443 (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
444 (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
445 (file (merge-pathnames (parse-namestring name) dir)))
446 (unless (and (probe-file file)
447 (>= (file-write-date file) (file-write-date rcsfile)))
448 (push file out-of-date-files))))))
449 out-of-date-files))
450
451 (defun rcs-prompt-for-directory (prompt)
452 (let* ((default (buffer-default-pathname (current-buffer)))
453 (dir (prompt-for-file :prompt prompt
454 :default (make-pathname
455 :host (pathname-host default)
456 :device (pathname-device default)
457 :directory (pathname-directory default)
458 :defaults nil)
459 :must-exist nil)))
460 (unless (directoryp dir)
461 (let ((with-slash (parse-namestring (concatenate 'simple-string
462 (namestring dir)
463 "/"))))
464 (unless (directoryp with-slash)
465 (editor-error "~S is not a directory" (namestring dir)))
466 (setf dir with-slash)))
467 dir))
468
469 (defcommand "RCS Update Directory" (p)
470 "Prompt for a directory and check out all files that are older than
471 their corresponding RCS files. With an argument, never ask about
472 overwriting writable files."
473 "Prompt for a directory and check out all files that are older than
474 the corresponding RCS file. With an argument, never ask about
475 overwriting writable files."
476 (let* ((directory (rcs-prompt-for-directory "Directory to update: "))
477 (out-of-date-files (list-out-of-date-files directory))
478 (n-out-of-date (length out-of-date-files)))
479 (cond ((zerop n-out-of-date)
480 (message "All RCS files in ~A are up to date."
481 (namestring directory)))
482 (t
483 (let ((n-checked-out
484 (maybe-rcs-check-out-files out-of-date-files nil p)))
485 (message "Number of files out of date: ~D; ~
486 number of files checked out: ~D"
487 n-out-of-date n-checked-out)))))))
488
489 (defcommand "RCS List Out Of Date Files" (p)
490 "Prompt for a directory and list all of the files that are older than
491 their corresponding RCS files."
492 "Prompt for a directory and list all of the files that are older than
493 their corresponding RCS files."
494 (declare (ignore p))
495 (let* ((directory (rcs-prompt-for-directory "Directory: "))
496 (out-of-date-files (list-out-of-date-files directory)))
497 (cond ((null out-of-date-files)
498 (message "All RCS files in ~A are up to date."
499 (namestring directory)))
500 (t
501 (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*")
502 (format s "Directory: ~A~%~%" (namestring directory))
503 (dolist (file out-of-date-files)
504 (format s "~A~%" (file-namestring file))))))))
505
506
507 ;;;; Status and Modeline Frobs.
508
509 (defhvar "RCS Status"
510 "RCS status of this buffer. Either nil, :locked, :out-of-date, or
511 :unlocked."
512 :value nil)
513
514 ;;;
515 ;;; Note: This doesn't behave correctly w/r/t to branched files.
516 ;;;
517 (defun rcs-file-status (pathname)
518 (let* ((directory (directory-namestring pathname))
519 (filename (file-namestring pathname))
520 (rcs-file (concatenate 'simple-string directory
521 "RCS/" filename ",v")))
522 (if (probe-file rcs-file)
523 ;; This is an RCS file
524 (let ((probe-file (probe-file pathname)))
525 (cond ((and probe-file (file-writable pathname))
526 :locked)
527 ((or (not probe-file)
528 (< (file-write-date pathname)
529 (file-write-date rcs-file)))
530 :out-of-date)
531 (t
532 :unlocked))))))
533
534 (defun rcs-update-buffer-status (buffer &optional tn)
535 (unless (hemlock-bound-p 'rcs-status :buffer buffer)
536 (defhvar "RCS Status"
537 "RCS Status of this buffer."
538 :buffer buffer
539 :value nil))
540 (let ((tn (or tn (buffer-pathname buffer))))
541 (setf (variable-value 'rcs-status :buffer buffer)
542 (if tn (rcs-file-status tn))))
543 (hi::update-modelines-for-buffer buffer))
544 ;;;
545 (add-hook read-file-hook 'rcs-update-buffer-status)
546 (add-hook write-file-hook 'rcs-update-buffer-status)
547
548 (defcommand "RCS Update All RCS Status Variables" (p)
549 "Update the ``RCS Status'' variable for all buffers."
550 "Update the ``RCS Status'' variable for all buffers."
551 (declare (ignore p))
552 (dolist (buffer *buffer-list*)
553 (rcs-update-buffer-status buffer))
554 (dolist (window *window-list*)
555 (update-modeline-fields (window-buffer window) window)))
556
557 ;;;
558 ;;; Action Hooks
559 (defun rcs-action-hook (buffer pathname)
560 (cond (buffer
561 (rcs-update-buffer-status buffer))
562 (t
563 (let ((pathname (probe-file pathname)))
564 (when pathname
565 (dolist (buffer *buffer-list*)
566 (let ((buffer-pathname (buffer-pathname buffer)))
567 (when (equal pathname buffer-pathname)
568 (rcs-update-buffer-status buffer)))))))))
569 ;;;
570 (add-hook rcs-check-in-file-hook 'rcs-action-hook)
571 (add-hook rcs-check-out-file-hook 'rcs-action-hook)
572 (add-hook rcs-lock-file-hook 'rcs-action-hook)
573 (add-hook rcs-unlock-file-hook 'rcs-action-hook)
574
575
576 ;;;
577 ;;; RCS Modeline Field
578 (make-modeline-field
579 :name :rcs-status
580 :function #'(lambda (buffer window)
581 (declare (ignore buffer window))
582 (ecase (value rcs-status)
583 (:out-of-date "[OLD] ")
584 (:locked "[LOCKED] ")
585 (:unlocked "[RCS] ")
586 ((nil) ""))))

  ViewVC Help
Powered by ViewVC 1.1.5