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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26 - (hide annotations)
Wed Feb 19 20:06:17 1992 UTC (22 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.25: +2 -2 lines
Fixed call to UNIX-UTIMES.
1 ch 1.6 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 wlott 1.1 ;;;
3 ram 1.26 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.26 1992/02/19 20:06:17 ram Exp $
4 wlott 1.1 ;;;
5 ch 1.12 ;;; Various commands for dealing with RCS under Hemlock.
6 ch 1.16 ;;;
7     ;;; Written by William Lott and Christopher Hoover.
8 wlott 1.1 ;;;
9     (in-package "HEMLOCK")
10    
11 ch 1.6
12     ;;;;
13 wlott 1.1
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 ch 1.16 (defvar *last-rcs-command-name* nil)
32     (defvar *last-rcs-command-output-string* nil)
33     (defvar *rcs-output-stream* (make-string-output-stream))
34 wlott 1.1
35 ch 1.16 (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 wlott 1.17 use the ``RCS Last Command Output'' command for ~
48     more information" ',command)))
49 ch 1.16 (: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 wlott 1.1
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 ch 1.2 (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 ch 1.7
80     (defhvar "RCS Lock File Hook"
81     "RCS Lock File Hook"
82     :value nil)
83    
84     (defun rcs-lock-file (buffer pathname)
85 ch 1.2 (message "Locking ~A ..." (namestring pathname))
86 wlott 1.1 (in-directory pathname
87     (let ((file (file-namestring pathname)))
88     (do-command "rcs" `("-l" ,file))
89 wlott 1.25 (multiple-value-bind (won dev ino mode) (unix:unix-stat file)
90 ch 1.6 (declare (ignore ino))
91     (cond (won
92 wlott 1.25 (unix:unix-chmod file (logior mode unix:writeown)))
93 ch 1.6 (t
94 wlott 1.25 (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
95     (unix:get-unix-error-msg dev)))))))
96 ch 1.7 (invoke-hook rcs-lock-file-hook buffer pathname))
97 wlott 1.1
98 ch 1.7
99     (defhvar "RCS Unlock File Hook"
100     "RCS Unlock File Hook"
101     :value nil)
102    
103     (defun rcs-unlock-file (buffer pathname)
104 ch 1.2 (message "Unlocking ~A ..." (namestring pathname))
105 wlott 1.1 (in-directory pathname
106 ch 1.7 (do-command "rcs" `("-u" ,(file-namestring pathname))))
107     (invoke-hook rcs-unlock-file-hook buffer pathname))
108 wlott 1.1
109 ch 1.6
110     ;;;; Check In
111    
112 ch 1.7 (defhvar "RCS Check In File Hook"
113     "RCS Check In File Hook"
114     :value nil)
115    
116 wlott 1.18 (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 ch 1.7 (defun rcs-check-in-file (buffer pathname keep-lock)
122 wlott 1.1 (let ((old-buffer (current-buffer))
123     (allow-delete nil)
124 ch 1.7 (log-buffer nil))
125 wlott 1.1 (unwind-protect
126     (when (block in-recursive-edit
127     (do ((i 0 (1+ i)))
128 ch 1.7 ((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 wlott 1.1 (do-recursive-edit)
142    
143 ch 1.13 (message "Checking in ~A~:[~; keeping the lock~] ..."
144     (namestring pathname) keep-lock)
145 ch 1.8 (let ((log-stream (make-hemlock-region-stream
146     (buffer-region log-buffer))))
147 wlott 1.18 (sub-check-in-file pathname buffer keep-lock log-stream))
148 ch 1.7 (invoke-hook rcs-check-in-file-hook buffer pathname)
149 wlott 1.1 nil)
150     (editor-error "Someone deleted the RCS Log Entry buffer."))
151 wlott 1.20 (when (member old-buffer *buffer-list*)
152     (change-to-buffer old-buffer))
153 wlott 1.1 (setf allow-delete t)
154 ch 1.9 (delete-buffer-if-possible log-buffer))))
155 ch 1.8
156 wlott 1.18 (defun sub-check-in-file (pathname buffer keep-lock log-stream)
157 ch 1.8 (let* ((filename (file-namestring pathname))
158     (rcs-filename (concatenate 'simple-string
159 wlott 1.18 "./RCS/" filename ",v"))
160     (keep-working-copy (or keep-lock
161 wlott 1.22 (not (hemlock-bound-p
162     'rcs-keep-around-after-unlocking
163     :buffer buffer))
164 wlott 1.18 (variable-value
165     'rcs-keep-around-after-unlocking
166     :buffer buffer))))
167 ch 1.8 (in-directory pathname
168     (do-command "rcsci" `(,@(if keep-lock '("-l"))
169 ram 1.23 ,@(if keep-working-copy '("-u"))
170 wlott 1.17 ,filename)
171 ch 1.8 :input log-stream)
172 wlott 1.18 (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 wlott 1.25 (unix:unix-stat rcs-filename)
179 wlott 1.18 (declare (ignore mode nlink uid gid rdev size))
180     (cond (dev
181     (multiple-value-bind
182     (wonp errno)
183 ram 1.26 (unix:unix-utimes filename atime 0 mtime 0)
184 wlott 1.18 (unless wonp
185 wlott 1.25 (editor-error "UNIX:UNIX-UTIMES failed: ~A"
186     (unix:get-unix-error-msg errno)))))
187 wlott 1.18 (t
188 wlott 1.25 (editor-error "UNIX:UNIX-STAT failed: ~A"
189     (unix:get-unix-error-msg ino)))))
190 wlott 1.18 (delete-buffer-if-possible buffer)))))
191    
192 wlott 1.1
193 ch 1.6
194     ;;;; Check Out
195    
196 ch 1.7 (defhvar "RCS Check Out File Hook"
197     "RCS Check Out File Hook"
198     :value nil)
199 ch 1.6
200 wlott 1.17 (defvar *translate-file-names-before-locking* nil)
201    
202 ch 1.7 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
203 wlott 1.17 (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 wlott 1.21 (when unmatched-dir
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 wlott 1.17 (cond
213     ((and (not always-overwrite-p)
214 ram 1.24 (let ((pn (probe-file pathname)))
215     (and pn (ext:file-writable pn))))
216 wlott 1.17 ;; 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 ch 1.7
241     (defun rcs-check-out-file (buffer pathname lock)
242 ch 1.13 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
243 wlott 1.1 (in-directory pathname
244 wlott 1.17 (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 ch 1.7 (invoke-hook rcs-check-out-file-hook buffer pathname)
250 ch 1.15 (when backup (delete-file backup)))))
251 wlott 1.1
252 ch 1.6
253 ch 1.16 ;;;; 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 wlott 1.17 ;;;; Commands for Checking In / Checking Out and Locking / Unlocking
267 ch 1.6
268 wlott 1.17 (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 wlott 1.1 (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 ch 1.7 (rcs-lock-file buffer file)
285 wlott 1.1 (unwind-protect
286     (progn
287     (in-directory file
288 ch 1.16 (do-command "rcsco" `("-p" ,(file-namestring file))
289 wlott 1.1 :output (namestring name)))
290     (when (buffer-different-from-file buffer name)
291     (message
292 ch 1.16 "RCS file is different; be sure to merge in your changes."))
293 wlott 1.1 (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 ch 1.7 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
303     :default (buffer-default-pathname
304     (current-buffer))
305     :must-exist nil)))
306 wlott 1.1
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 ch 1.7 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
312 wlott 1.1 (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 ch 1.7 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
320     :default (buffer-default-pathname
321     (current-buffer))
322     :must-exist nil)))
323 wlott 1.1
324     (defcommand "RCS Check In Buffer File" (p)
325 ch 1.6 "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 wlott 1.1 (let ((buffer (current-buffer))
330     (pathname (current-buffer-pathname)))
331     (when (buffer-modified buffer)
332     (save-file-command nil))
333 ch 1.7 (rcs-check-in-file buffer pathname p)
334 wlott 1.19 (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 wlott 1.1
339     (defcommand "RCS Check In File" (p)
340 ch 1.6 "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 ch 1.7 (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 wlott 1.1 p))
350    
351     (defcommand "RCS Check Out Buffer File" (p)
352 ch 1.6 "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 wlott 1.1 (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 wlott 1.17 (setf pathname (maybe-rcs-check-out-file buffer pathname p nil))
365 wlott 1.1 (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 ch 1.6 "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 wlott 1.1 (let ((pathname (prompt-for-file :prompt "File to check out: "
378 ch 1.2 :default (buffer-default-pathname
379     (current-buffer))
380 wlott 1.1 :must-exist nil)))
381 wlott 1.17 (setf pathname (maybe-rcs-check-out-file nil pathname p nil))
382 wlott 1.1 (find-file-command nil pathname)))
383    
384 ch 1.6
385     ;;;; Log File
386    
387 wlott 1.1 (defhvar "RCS Log Entry Buffer"
388     "Name of the buffer to put RCS log entries into."
389     :value "RCS Log")
390    
391 ch 1.7 (defhvar "RCS Log Buffer Hook"
392     "RCS Log Buffer Hook"
393     :value nil)
394    
395 wlott 1.1 (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 ch 1.7 (turn-auto-save-off buffer)
400     (invoke-hook rcs-log-buffer-hook buffer))
401 wlott 1.1 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 ch 1.2 (message "Extracting log info ...")
411 wlott 1.1 (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 ch 1.2 "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 wlott 1.1 (declare (ignore p))
423     (let ((file (prompt-for-file :prompt "File to get log of: "
424 ch 1.2 :default (buffer-default-pathname
425     (current-buffer))
426 wlott 1.1 :must-exist nil))
427     (buffer (get-log-buffer)))
428     (delete-region (buffer-region buffer))
429 ch 1.2 (message "Extracing log info ...")
430 wlott 1.1 (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 ch 1.16
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 ram 1.24 (cond ((and probe-file (file-writable probe-file))
458 ch 1.16 :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