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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (hide annotations)
Thu Nov 7 21:22:38 1991 UTC (22 years, 5 months ago) by wlott
Branch: MAIN
Changes since 1.16: +62 -148 lines
Removed all the directory updating stuff, 'cause it didn't work and
rcsupdate does the job much better.  Added noise to check in and check out
to possibly use definition translation stuff on the file so that you don't
have to duplicate the entire source tree in your work area.
1 ch 1.6 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 wlott 1.1 ;;;
3 wlott 1.17 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.17 1991/11/07 21:22:38 wlott 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 ch 1.6 (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 ch 1.7 (mach:get-unix-error-msg dev)))))))
96     (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     (defun rcs-check-in-file (buffer pathname keep-lock)
117 wlott 1.1 (let ((old-buffer (current-buffer))
118     (allow-delete nil)
119 ch 1.7 (log-buffer nil))
120 wlott 1.1 (unwind-protect
121     (when (block in-recursive-edit
122     (do ((i 0 (1+ i)))
123 ch 1.7 ((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 wlott 1.1 (do-recursive-edit)
137    
138 ch 1.13 (message "Checking in ~A~:[~; keeping the lock~] ..."
139     (namestring pathname) keep-lock)
140 ch 1.8 (let ((log-stream (make-hemlock-region-stream
141     (buffer-region log-buffer))))
142     (sub-check-in-file pathname keep-lock log-stream))
143 ch 1.7 (invoke-hook rcs-check-in-file-hook buffer pathname)
144 wlott 1.1 nil)
145     (editor-error "Someone deleted the RCS Log Entry buffer."))
146     (change-to-buffer old-buffer)
147     (setf allow-delete t)
148 ch 1.9 (delete-buffer-if-possible log-buffer))))
149 ch 1.8
150 wlott 1.17 (defvar *keep-around-unlocked-files* t)
151    
152 ch 1.8 (defun sub-check-in-file (pathname keep-lock log-stream)
153     (let* ((filename (file-namestring pathname))
154     (rcs-filename (concatenate 'simple-string
155     "./RCS/" filename ",v")))
156     (in-directory pathname
157     (do-command "rcsci" `(,@(if keep-lock '("-l"))
158 wlott 1.17 ,@(if (or keep-lock *keep-around-unlocked-files*)
159     "-u")
160     ,filename)
161 ch 1.8 :input log-stream)
162     ;;
163     ;; Set the times on the user's file to be equivalent to that of
164     ;; the rcs file.
165     (multiple-value-bind
166     (dev ino mode nlink uid gid rdev size atime mtime)
167     (mach:unix-stat rcs-filename)
168     (declare (ignore mode nlink uid gid rdev size))
169     (cond (dev
170     (multiple-value-bind
171     (wonp errno)
172 ch 1.11 (mach:unix-utimes filename (list atime 0 mtime 0))
173 ch 1.8 (unless wonp
174     (editor-error "MACH:UNIX-UTIMES failed: ~A"
175     (mach:get-unix-error-msg errno)))))
176     (t
177     (editor-error "MACH:UNIX-STAT failed: ~A"
178     (mach:get-unix-error-msg ino))))))))
179 wlott 1.1
180 ch 1.6
181     ;;;; Check Out
182    
183 ch 1.7 (defhvar "RCS Check Out File Hook"
184     "RCS Check Out File Hook"
185     :value nil)
186 ch 1.6
187 wlott 1.17 (defvar *translate-file-names-before-locking* nil)
188    
189 ch 1.7 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
190 wlott 1.17 (when (and lock *translate-file-names-before-locking*)
191     (multiple-value-bind (unmatched-dir new-dirs file-name)
192     (maybe-translate-definition-file pathname)
193     (let ((new-name (translate-definition-file unmatched-dir
194     (car new-dirs)
195     file-name)))
196     (when (probe-file (directory-namestring new-name))
197     (setf pathname new-name)))))
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     (rcs-check-out-file buffer pathname lock))
211     (:no
212     "Don't check it out after all.")
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     (rcs-check-out-file buffer pathname lock)))))
222     (t
223     (rcs-check-out-file buffer pathname lock)))
224     pathname)
225 ch 1.7
226     (defun rcs-check-out-file (buffer pathname lock)
227 ch 1.13 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
228 wlott 1.1 (in-directory pathname
229 wlott 1.17 (let* ((file (file-namestring pathname))
230     (backup (if (probe-file file)
231     (lisp::pick-backup-name file))))
232     (when backup (rename-file file backup))
233     (do-command "rcsco" `(,@(if lock '("-l")) ,file))
234 ch 1.7 (invoke-hook rcs-check-out-file-hook buffer pathname)
235 ch 1.15 (when backup (delete-file backup)))))
236 wlott 1.1
237 ch 1.6
238 ch 1.16 ;;;; Last Command Output
239    
240     (defcommand "RCS Last Command Output" (p)
241     "Print the full output of the last RCS command."
242     "Print the full output of the last RCS command."
243     (declare (ignore p))
244     (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
245     (editor-error "No RCS commands have executed!"))
246     (with-pop-up-display (s :buffer-name "*RCS Command Output*")
247     (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
248     (write-line *last-rcs-command-output-string* s)))
249    
250    
251 wlott 1.17 ;;;; Commands for Checking In / Checking Out and Locking / Unlocking
252 ch 1.6
253 wlott 1.17 (defun pick-temp-file (defaults)
254     (let ((index 0))
255     (loop
256     (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
257     (cond ((probe-file name)
258     (incf index))
259     (t
260     (return name)))))))
261    
262 wlott 1.1 (defcommand "RCS Lock Buffer File" (p)
263     "Attempt to lock the file in the current buffer."
264     "Attempt to lock the file in the current buffer."
265     (declare (ignore p))
266     (let ((file (current-buffer-pathname))
267     (buffer (current-buffer))
268     (name (pick-temp-file "/tmp/")))
269 ch 1.7 (rcs-lock-file buffer file)
270 wlott 1.1 (unwind-protect
271     (progn
272     (in-directory file
273 ch 1.16 (do-command "rcsco" `("-p" ,(file-namestring file))
274 wlott 1.1 :output (namestring name)))
275     (when (buffer-different-from-file buffer name)
276     (message
277 ch 1.16 "RCS file is different; be sure to merge in your changes."))
278 wlott 1.1 (setf (buffer-writable buffer) t)
279     (message "Buffer is now writable."))
280     (when (probe-file name)
281     (delete-file name)))))
282    
283     (defcommand "RCS Lock File" (p)
284     "Prompt for a file, and attempt to lock it."
285     "Prompt for a file, and attempt to lock it."
286     (declare (ignore p))
287 ch 1.7 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
288     :default (buffer-default-pathname
289     (current-buffer))
290     :must-exist nil)))
291 wlott 1.1
292     (defcommand "RCS Unlock Buffer File" (p)
293     "Unlock the file in the current buffer."
294     "Unlock the file in the current buffer."
295     (declare (ignore p))
296 ch 1.7 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
297 wlott 1.1 (setf (buffer-writable (current-buffer)) nil)
298     (message "Buffer is no longer writable."))
299    
300     (defcommand "RCS Unlock File" (p)
301     "Prompt for a file, and attempt to unlock it."
302     "Prompt for a file, and attempt to unlock it."
303     (declare (ignore p))
304 ch 1.7 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
305     :default (buffer-default-pathname
306     (current-buffer))
307     :must-exist nil)))
308 wlott 1.1
309     (defcommand "RCS Check In Buffer File" (p)
310 ch 1.6 "Checkin the file in the current buffer. With an argument, do not
311     release the lock."
312     "Checkin the file in the current buffer. With an argument, do not
313     release the lock."
314 wlott 1.1 (let ((buffer (current-buffer))
315     (pathname (current-buffer-pathname)))
316     (when (buffer-modified buffer)
317     (save-file-command nil))
318 ch 1.7 (rcs-check-in-file buffer pathname p)
319 wlott 1.1 (visit-file-command nil pathname buffer)))
320    
321     (defcommand "RCS Check In File" (p)
322 ch 1.6 "Prompt for a file, and attempt to check it in. With an argument, do
323     not release the lock."
324     "Prompt for a file, and attempt to check it in. With an argument, do
325     not release the lock."
326 ch 1.7 (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
327     :default
328     (buffer-default-pathname
329     (current-buffer))
330     :must-exist nil)
331 wlott 1.1 p))
332    
333     (defcommand "RCS Check Out Buffer File" (p)
334 ch 1.6 "Checkout the file in the current buffer. With an argument, lock the
335     file."
336     "Checkout the file in the current buffer. With an argument, lock the
337     file."
338 wlott 1.1 (let* ((buffer (current-buffer))
339     (pathname (current-buffer-pathname))
340     (point (current-point))
341     (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
342     (when (buffer-modified buffer)
343     (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
344     (editor-error "Aborted.")))
345     (setf (buffer-modified buffer) nil)
346 wlott 1.17 (setf pathname (maybe-rcs-check-out-file buffer pathname p nil))
347 wlott 1.1 (when p
348     (setf (buffer-writable buffer) t)
349     (message "Buffer is now writable."))
350     (visit-file-command nil pathname)
351     (unless (line-offset point lines)
352     (buffer-end point))))
353    
354     (defcommand "RCS Check Out File" (p)
355 ch 1.6 "Prompt for a file and attempt to check it out. With an argument,
356     lock the file."
357     "Prompt for a file and attempt to check it out. With an argument,
358     lock the file."
359 wlott 1.1 (let ((pathname (prompt-for-file :prompt "File to check out: "
360 ch 1.2 :default (buffer-default-pathname
361     (current-buffer))
362 wlott 1.1 :must-exist nil)))
363 wlott 1.17 (setf pathname (maybe-rcs-check-out-file nil pathname p nil))
364 wlott 1.1 (find-file-command nil pathname)))
365    
366 ch 1.6
367     ;;;; Log File
368    
369 wlott 1.1 (defhvar "RCS Log Entry Buffer"
370     "Name of the buffer to put RCS log entries into."
371     :value "RCS Log")
372    
373 ch 1.7 (defhvar "RCS Log Buffer Hook"
374     "RCS Log Buffer Hook"
375     :value nil)
376    
377 wlott 1.1 (defun get-log-buffer ()
378     (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
379     (unless buffer
380     (setf buffer (make-buffer (value rcs-log-entry-buffer)))
381 ch 1.7 (turn-auto-save-off buffer)
382     (invoke-hook rcs-log-buffer-hook buffer))
383 wlott 1.1 buffer))
384    
385     (defcommand "RCS Buffer File Log Entry" (p)
386     "Get the RCS Log for the file in the current buffer in a buffer."
387     "Get the RCS Log for the file in the current buffer in a buffer."
388     (declare (ignore p))
389     (let ((buffer (get-log-buffer))
390     (pathname (current-buffer-pathname)))
391     (delete-region (buffer-region buffer))
392 ch 1.2 (message "Extracting log info ...")
393 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
394     (in-directory pathname
395     (do-command "rlog" (list (file-namestring pathname))
396     :output (make-hemlock-output-stream mark))))
397     (change-to-buffer buffer)
398     (buffer-start (current-point))
399     (setf (buffer-modified buffer) nil)))
400    
401     (defcommand "RCS File Log Entry" (p)
402 ch 1.2 "Prompt for a file and get its RCS log entry in a buffer."
403     "Prompt for a file and get its RCS log entry in a buffer."
404 wlott 1.1 (declare (ignore p))
405     (let ((file (prompt-for-file :prompt "File to get log of: "
406 ch 1.2 :default (buffer-default-pathname
407     (current-buffer))
408 wlott 1.1 :must-exist nil))
409     (buffer (get-log-buffer)))
410     (delete-region (buffer-region buffer))
411 ch 1.2 (message "Extracing log info ...")
412 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
413     (in-directory file
414     (do-command "rlog" (list (file-namestring file))
415     :output (make-hemlock-output-stream mark))))
416     (change-to-buffer buffer)
417     (buffer-start (current-point))
418     (setf (buffer-modified buffer) nil)))
419 ch 1.16
420    
421     ;;;; Status and Modeline Frobs.
422    
423     (defhvar "RCS Status"
424     "RCS status of this buffer. Either nil, :locked, :out-of-date, or
425     :unlocked."
426     :value nil)
427    
428     ;;;
429     ;;; Note: This doesn't behave correctly w/r/t to branched files.
430     ;;;
431     (defun rcs-file-status (pathname)
432     (let* ((directory (directory-namestring pathname))
433     (filename (file-namestring pathname))
434     (rcs-file (concatenate 'simple-string directory
435     "RCS/" filename ",v")))
436     (if (probe-file rcs-file)
437     ;; This is an RCS file
438     (let ((probe-file (probe-file pathname)))
439     (cond ((and probe-file (file-writable pathname))
440     :locked)
441     ((or (not probe-file)
442     (< (file-write-date pathname)
443     (file-write-date rcs-file)))
444     :out-of-date)
445     (t
446     :unlocked))))))
447    
448     (defun rcs-update-buffer-status (buffer &optional tn)
449     (unless (hemlock-bound-p 'rcs-status :buffer buffer)
450     (defhvar "RCS Status"
451     "RCS Status of this buffer."
452     :buffer buffer
453     :value nil))
454     (let ((tn (or tn (buffer-pathname buffer))))
455     (setf (variable-value 'rcs-status :buffer buffer)
456     (if tn (rcs-file-status tn))))
457     (hi::update-modelines-for-buffer buffer))
458     ;;;
459     (add-hook read-file-hook 'rcs-update-buffer-status)
460     (add-hook write-file-hook 'rcs-update-buffer-status)
461    
462     (defcommand "RCS Update All RCS Status Variables" (p)
463     "Update the ``RCS Status'' variable for all buffers."
464     "Update the ``RCS Status'' variable for all buffers."
465     (declare (ignore p))
466     (dolist (buffer *buffer-list*)
467     (rcs-update-buffer-status buffer))
468     (dolist (window *window-list*)
469     (update-modeline-fields (window-buffer window) window)))
470    
471     ;;;
472     ;;; Action Hooks
473     (defun rcs-action-hook (buffer pathname)
474     (cond (buffer
475     (rcs-update-buffer-status buffer))
476     (t
477     (let ((pathname (probe-file pathname)))
478     (when pathname
479     (dolist (buffer *buffer-list*)
480     (let ((buffer-pathname (buffer-pathname buffer)))
481     (when (equal pathname buffer-pathname)
482     (rcs-update-buffer-status buffer)))))))))
483     ;;;
484     (add-hook rcs-check-in-file-hook 'rcs-action-hook)
485     (add-hook rcs-check-out-file-hook 'rcs-action-hook)
486     (add-hook rcs-lock-file-hook 'rcs-action-hook)
487     (add-hook rcs-unlock-file-hook 'rcs-action-hook)
488    
489    
490     ;;;
491     ;;; RCS Modeline Field
492     (make-modeline-field
493     :name :rcs-status
494     :function #'(lambda (buffer window)
495     (declare (ignore buffer window))
496     (ecase (value rcs-status)
497     (:out-of-date "[OLD] ")
498     (:locked "[LOCKED] ")
499     (:unlocked "[RCS] ")
500     ((nil) ""))))

  ViewVC Help
Powered by ViewVC 1.1.5