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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Fri Feb 9 19:10:08 1990 UTC (24 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.2: +78 -5 lines
Wrote ``RCS Update Directory'' which prompts for a directory and updates
all the RCS files in it.
1 wlott 1.1 ;;; -*- Package: HEMLOCK -*-
2     ;;;
3 wlott 1.3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.3 1990/02/09 19:10:08 wlott Exp $
4 wlott 1.1 ;;;
5     ;;; Various commands for dealing with RCS under hemlock.
6     ;;;
7    
8     (in-package "HEMLOCK")
9    
10    
11     (defun current-buffer-pathname ()
12     (let ((pathname (buffer-pathname (current-buffer))))
13     (unless pathname
14     (editor-error "The buffer has no pathname."))
15     pathname))
16    
17    
18     (defmacro in-directory (directory &body forms)
19     (let ((cwd (gensym)))
20     `(let ((,cwd (ext:default-directory)))
21     (unwind-protect
22     (progn
23     (setf (ext:default-directory) (directory-namestring ,directory))
24     ,@forms)
25     (setf (ext:default-directory) ,cwd)))))
26    
27    
28     (defvar *error-stream* (make-string-output-stream))
29    
30     (defmacro do-command (&rest args)
31     (let ((proc (gensym)))
32     `(progn
33     (get-output-stream-string *error-stream*)
34     (let ((,proc (ext:run-program ,@args :error *error-stream*)))
35     (case (ext:process-status ,proc)
36     (:exited
37     (unless (zerop (ext:process-exit-code ,proc))
38     (editor-error "~A" (get-output-stream-string *error-stream*))))
39     (:signaled
40     (editor-error "~A killed with signal ~A ~@[core dumped]"
41     ',(car args)
42     (ext:process-exit-code ,proc)
43     (ext:process-core-dumped ,proc)))
44     (t
45     (editor-error "~S still alive?" ,proc)))))))
46    
47     (defun buffer-different-from-file (buffer filename)
48     (with-open-file (file filename)
49     (do ((buffer-line (mark-line (buffer-start-mark buffer))
50     (line-next buffer-line))
51     (file-line (read-line file nil nil)
52     (read-line file nil nil)))
53     ((and (or (null buffer-line)
54     (zerop (line-length buffer-line)))
55     (null file-line))
56     nil)
57     (when (or (null buffer-line)
58     (null file-line)
59     (string/= (line-string buffer-line) file-line))
60     (return t)))))
61    
62 ch 1.2 (defun turn-auto-save-off (buffer)
63     (setf (buffer-minor-mode buffer "Save") nil)
64     ;;
65     ;; William's personal hack
66     (when (getstring "Ckp" *mode-names*)
67     (setf (buffer-minor-mode buffer "Ckp") nil)))
68    
69 wlott 1.1 (defun rcs-lock-file (pathname)
70 ch 1.2 (message "Locking ~A ..." (namestring pathname))
71 wlott 1.1 (in-directory pathname
72     (let ((file (file-namestring pathname)))
73     (do-command "rcs" `("-l" ,file))
74     (multiple-value-bind
75     (won dev ino mode)
76     (mach:unix-stat file)
77     (declare (ignore dev ino))
78     (when won
79     (mach:unix-chmod file (logior mode mach:writeown)))))))
80    
81     (defun rcs-unlock-file (pathname)
82 ch 1.2 (message "Unlocking ~A ..." (namestring pathname))
83 wlott 1.1 (in-directory pathname
84     (do-command "rcs" `("-u" ,(file-namestring pathname)))))
85    
86     (defun rcs-check-in-file (pathname keep-lock)
87     (let ((old-buffer (current-buffer))
88     (allow-delete nil)
89     (buffer nil))
90     (unwind-protect
91     (when (block in-recursive-edit
92     (do ((i 0 (1+ i)))
93     ((not (null buffer)))
94     (setf buffer
95     (make-buffer (format nil "RCS Log Entry ~D for ~S"
96     i (file-namestring pathname))
97     :modes '("Text")
98     :delete-hook
99     (list #'(lambda (buffer)
100     (declare (ignore buffer))
101     (unless allow-delete
102     (return-from in-recursive-edit
103     t)))))))
104 ch 1.2 (turn-auto-save-off buffer)
105 wlott 1.1 (change-to-buffer buffer)
106     (do-recursive-edit)
107    
108 ch 1.2 (message "Checking in ~A ..." (namestring pathname))
109 wlott 1.1 (in-directory pathname
110     (do-command "rcsci" `(,@(if keep-lock '("-l"))
111     ,(file-namestring pathname))
112     :input (make-hemlock-region-stream
113     (buffer-region buffer))))
114     nil)
115     (editor-error "Someone deleted the RCS Log Entry buffer."))
116     (change-to-buffer old-buffer)
117     (setf allow-delete t)
118     (delete-buffer buffer))))
119    
120     (defun rcs-check-out-file (pathname lock)
121 ch 1.2 (message "Checking out ~A ..." (namestring pathname))
122 wlott 1.1 (in-directory pathname
123 wlott 1.3 (let ((backup
124     (if (probe-file pathname)
125     (lisp::pick-backup-name (namestring pathname))
126     nil)))
127     (when backup
128     (rename-file pathname backup))
129 wlott 1.1 (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
130 wlott 1.3 (when backup
131     (delete-file backup)))))
132 wlott 1.1
133    
134    
135     (defun pick-temp-file (defaults)
136     (let ((index 0))
137     (loop
138     (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
139     (cond ((probe-file name)
140     (incf index))
141     (t
142     (return name)))))))
143    
144     (defcommand "RCS Lock Buffer File" (p)
145     "Attempt to lock the file in the current buffer."
146     "Attempt to lock the file in the current buffer."
147     (declare (ignore p))
148     (let ((file (current-buffer-pathname))
149     (buffer (current-buffer))
150     (name (pick-temp-file "/tmp/")))
151     (rcs-lock-file file)
152     (unwind-protect
153     (progn
154     (in-directory file
155     (do-command "rcsco" `("-p" ,(file-namestring file))
156     :output (namestring name)))
157     (when (buffer-different-from-file buffer name)
158     (message
159 ch 1.2 "RCS file is different: be sure to merge in your changes."))
160 wlott 1.1 (setf (buffer-writable buffer) t)
161     (message "Buffer is now writable."))
162     (when (probe-file name)
163     (delete-file name)))))
164    
165     (defcommand "RCS Lock File" (p)
166     "Prompt for a file, and attempt to lock it."
167     "Prompt for a file, and attempt to lock it."
168     (declare (ignore p))
169     (rcs-lock-file (prompt-for-file :prompt "File to lock: "
170 ch 1.2 :default (buffer-default-pathname
171     (current-buffer))
172 wlott 1.1 :must-exist nil)))
173    
174     (defcommand "RCS Unlock Buffer File" (p)
175     "Unlock the file in the current buffer."
176     "Unlock the file in the current buffer."
177     (declare (ignore p))
178     (rcs-unlock-file (current-buffer-pathname))
179     (setf (buffer-writable (current-buffer)) nil)
180     (message "Buffer is no longer writable."))
181    
182     (defcommand "RCS Unlock File" (p)
183     "Prompt for a file, and attempt to unlock it."
184     "Prompt for a file, and attempt to unlock it."
185     (declare (ignore p))
186     (rcs-unlock-file (prompt-for-file :prompt "File to unlock: "
187 ch 1.2 :default (buffer-default-pathname
188     (current-buffer))
189 wlott 1.1 :must-exist nil)))
190    
191     (defcommand "RCS Check In Buffer File" (p)
192     "Checkin the file in the current buffer. With an argument, do not release
193     the lock."
194     "Checkin the file in the current buffer. With an argument, do not release
195     the lock."
196     (let ((buffer (current-buffer))
197     (pathname (current-buffer-pathname)))
198     (when (buffer-modified buffer)
199     (save-file-command nil))
200     (rcs-check-in-file pathname p)
201     (visit-file-command nil pathname buffer)))
202    
203     (defcommand "RCS Check In File" (p)
204     "Prompt for a file, and attempt to check it in. With an argument, do not
205     release the lock."
206     "Prompt for a file, and attempt to check it in. With an argument, do not
207     release the lock."
208     (rcs-check-in-file (prompt-for-file :prompt "File to lock: "
209     :default
210 ch 1.2 (buffer-default-pathname
211     (current-buffer))
212 wlott 1.1 :must-exist nil)
213     p))
214    
215     (defcommand "RCS Check Out Buffer File" (p)
216     "Checkout the file in the current buffer. With an argument, lock the file."
217     "Checkout the file in the current buffer. With an argument, lock the file."
218     (let* ((buffer (current-buffer))
219     (pathname (current-buffer-pathname))
220     (point (current-point))
221     (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
222     (when (buffer-modified buffer)
223     (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
224     (editor-error "Aborted.")))
225     (rcs-check-out-file pathname p)
226     (setf (buffer-modified buffer) nil)
227     (when p
228     (setf (buffer-writable buffer) t)
229     (message "Buffer is now writable."))
230     (visit-file-command nil pathname)
231     (unless (line-offset point lines)
232     (buffer-end point))))
233    
234     (defcommand "RCS Check Out File" (p)
235     "Prompt for a file and attempt to check it out. With an argument, lock the
236     file."
237     "Prompt for a file and attempt to check it out. With an argument, lock the
238     file."
239     (let ((pathname (prompt-for-file :prompt "File to check out: "
240 ch 1.2 :default (buffer-default-pathname
241     (current-buffer))
242 wlott 1.1 :must-exist nil)))
243     (rcs-check-out-file pathname p)
244     (find-file-command nil pathname)))
245    
246     (defhvar "RCS Log Entry Buffer"
247     "Name of the buffer to put RCS log entries into."
248     :value "RCS Log")
249    
250     (defun get-log-buffer ()
251     (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
252     (unless buffer
253     (setf buffer (make-buffer (value rcs-log-entry-buffer)))
254 ch 1.2 (turn-auto-save-off buffer))
255 wlott 1.1 buffer))
256    
257     (defcommand "RCS Buffer File Log Entry" (p)
258     "Get the RCS Log for the file in the current buffer in a buffer."
259     "Get the RCS Log for the file in the current buffer in a buffer."
260     (declare (ignore p))
261     (let ((buffer (get-log-buffer))
262     (pathname (current-buffer-pathname)))
263     (delete-region (buffer-region buffer))
264 ch 1.2 (message "Extracting log info ...")
265 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
266     (in-directory pathname
267     (do-command "rlog" (list (file-namestring pathname))
268     :output (make-hemlock-output-stream mark))))
269     (change-to-buffer buffer)
270     (buffer-start (current-point))
271     (setf (buffer-modified buffer) nil)))
272    
273     (defcommand "RCS File Log Entry" (p)
274 ch 1.2 "Prompt for a file and get its RCS log entry in a buffer."
275     "Prompt for a file and get its RCS log entry in a buffer."
276 wlott 1.1 (declare (ignore p))
277     (let ((file (prompt-for-file :prompt "File to get log of: "
278 ch 1.2 :default (buffer-default-pathname
279     (current-buffer))
280 wlott 1.1 :must-exist nil))
281     (buffer (get-log-buffer)))
282     (delete-region (buffer-region buffer))
283 ch 1.2 (message "Extracing log info ...")
284 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
285     (in-directory file
286     (do-command "rlog" (list (file-namestring file))
287     :output (make-hemlock-output-stream mark))))
288     (change-to-buffer buffer)
289     (buffer-start (current-point))
290     (setf (buffer-modified buffer) nil)))
291 wlott 1.3
292    
293     (defcommand "RCS Update Directory" (p)
294     "Prompt for a directory and check out all files that are older than the
295     corresponding RCS file. With an argument, never ask about overwriting
296     writable files."
297     "Prompt for a directory and check out all files that are older than the
298     corresponding RCS file. With an argument, never ask about overwriting
299     writable files."
300     (let* ((def (buffer-default-pathname (current-buffer)))
301     (dir (prompt-for-file :prompt "Directory to update: "
302     :default (make-pathname
303     :host (pathname-host def)
304     :device (pathname-device def)
305     :directory (pathname-directory def)
306     :defaults nil)
307     :must-exist nil)))
308     (unless (directoryp dir)
309     (let ((with-slash (parse-namestring (concatenate 'simple-string
310     (namestring dir)
311     "/"))))
312     (unless (directoryp with-slash)
313     (editor-error "~S is not a directory" (namestring dir)))
314     (setf dir with-slash)))
315     (let ((rcsdir
316     (make-pathname :host (pathname-host dir)
317     :device (pathname-device dir)
318     :directory (concatenate 'simple-vector
319     (pathname-directory dir)
320     (vector "RCS"))))
321     (did-any nil))
322     (unless (directoryp rcsdir)
323     (editor-error "Could not find the RCS directory."))
324     (dolist (rcsfile (directory rcsdir))
325     (let ((rcsname (file-namestring rcsfile)))
326     (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
327     (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
328     (file (merge-pathnames (parse-namestring name)
329     dir)))
330     (when (< (file-write-date file) (file-write-date rcsfile))
331     (multiple-value-bind
332     (won dev inode mode)
333     (mach:unix-stat (namestring file))
334     (declare (ignore dev inode))
335     (when (and won (not (zerop (logand mode mach:writeown))))
336     (cond ((or p
337     (not (prompt-for-y-or-n
338     :prompt
339     (format nil
340     "~S is writable, overwrite? "
341     (namestring file))
342     :default nil
343     :default-string "n")))
344     (let ((private
345     (merge-pathnames (concatenate
346     'simple-string
347     (file-namestring file)
348     ".private")
349     file)))
350     (message "Renaming ~S to ~S"
351     (namestring file)
352     (namestring private))
353     (rename-file file private)))
354     (t
355     (delete-file file))))
356     (setf did-any t)
357     (rcs-check-out-file file nil)))))))
358     (unless did-any
359     (message "No files are out of date.")))))

  ViewVC Help
Powered by ViewVC 1.1.5