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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Fri Feb 9 21:20:32 1990 UTC (24 years, 2 months ago) by wlott
Branch: MAIN
Changes since 1.4: +8 -6 lines
Fixed bug in RCS update directory that caused it to flame out when the
local file did not already exist.
1 wlott 1.1 ;;; -*- Package: HEMLOCK -*-
2     ;;;
3 wlott 1.5 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.5 1990/02/09 21:20:32 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 wlott 1.4 "-u"
112 wlott 1.1 ,(file-namestring pathname))
113     :input (make-hemlock-region-stream
114     (buffer-region buffer))))
115     nil)
116     (editor-error "Someone deleted the RCS Log Entry buffer."))
117     (change-to-buffer old-buffer)
118     (setf allow-delete t)
119     (delete-buffer buffer))))
120    
121     (defun rcs-check-out-file (pathname lock)
122 ch 1.2 (message "Checking out ~A ..." (namestring pathname))
123 wlott 1.1 (in-directory pathname
124 wlott 1.3 (let ((backup
125     (if (probe-file pathname)
126     (lisp::pick-backup-name (namestring pathname))
127     nil)))
128     (when backup
129     (rename-file pathname backup))
130 wlott 1.1 (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
131 wlott 1.3 (when backup
132     (delete-file backup)))))
133 wlott 1.1
134    
135    
136     (defun pick-temp-file (defaults)
137     (let ((index 0))
138     (loop
139     (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
140     (cond ((probe-file name)
141     (incf index))
142     (t
143     (return name)))))))
144    
145     (defcommand "RCS Lock Buffer File" (p)
146     "Attempt to lock the file in the current buffer."
147     "Attempt to lock the file in the current buffer."
148     (declare (ignore p))
149     (let ((file (current-buffer-pathname))
150     (buffer (current-buffer))
151     (name (pick-temp-file "/tmp/")))
152     (rcs-lock-file file)
153     (unwind-protect
154     (progn
155     (in-directory file
156     (do-command "rcsco" `("-p" ,(file-namestring file))
157     :output (namestring name)))
158     (when (buffer-different-from-file buffer name)
159     (message
160 ch 1.2 "RCS file is different: be sure to merge in your changes."))
161 wlott 1.1 (setf (buffer-writable buffer) t)
162     (message "Buffer is now writable."))
163     (when (probe-file name)
164     (delete-file name)))))
165    
166     (defcommand "RCS Lock File" (p)
167     "Prompt for a file, and attempt to lock it."
168     "Prompt for a file, and attempt to lock it."
169     (declare (ignore p))
170     (rcs-lock-file (prompt-for-file :prompt "File to lock: "
171 ch 1.2 :default (buffer-default-pathname
172     (current-buffer))
173 wlott 1.1 :must-exist nil)))
174    
175     (defcommand "RCS Unlock Buffer File" (p)
176     "Unlock the file in the current buffer."
177     "Unlock the file in the current buffer."
178     (declare (ignore p))
179     (rcs-unlock-file (current-buffer-pathname))
180     (setf (buffer-writable (current-buffer)) nil)
181     (message "Buffer is no longer writable."))
182    
183     (defcommand "RCS Unlock File" (p)
184     "Prompt for a file, and attempt to unlock it."
185     "Prompt for a file, and attempt to unlock it."
186     (declare (ignore p))
187     (rcs-unlock-file (prompt-for-file :prompt "File to unlock: "
188 ch 1.2 :default (buffer-default-pathname
189     (current-buffer))
190 wlott 1.1 :must-exist nil)))
191    
192     (defcommand "RCS Check In Buffer File" (p)
193     "Checkin the file in the current buffer. With an argument, do not release
194     the lock."
195     "Checkin the file in the current buffer. With an argument, do not release
196     the lock."
197     (let ((buffer (current-buffer))
198     (pathname (current-buffer-pathname)))
199     (when (buffer-modified buffer)
200     (save-file-command nil))
201     (rcs-check-in-file pathname p)
202     (visit-file-command nil pathname buffer)))
203    
204     (defcommand "RCS Check In File" (p)
205     "Prompt for a file, and attempt to check it in. With an argument, do not
206     release the lock."
207     "Prompt for a file, and attempt to check it in. With an argument, do not
208     release the lock."
209     (rcs-check-in-file (prompt-for-file :prompt "File to lock: "
210     :default
211 ch 1.2 (buffer-default-pathname
212     (current-buffer))
213 wlott 1.1 :must-exist nil)
214     p))
215    
216     (defcommand "RCS Check Out Buffer File" (p)
217     "Checkout the file in the current buffer. With an argument, lock the file."
218     "Checkout the file in the current buffer. With an argument, lock the file."
219     (let* ((buffer (current-buffer))
220     (pathname (current-buffer-pathname))
221     (point (current-point))
222     (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
223     (when (buffer-modified buffer)
224     (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
225     (editor-error "Aborted.")))
226     (rcs-check-out-file pathname p)
227     (setf (buffer-modified buffer) nil)
228     (when p
229     (setf (buffer-writable buffer) t)
230     (message "Buffer is now writable."))
231     (visit-file-command nil pathname)
232     (unless (line-offset point lines)
233     (buffer-end point))))
234    
235     (defcommand "RCS Check Out File" (p)
236     "Prompt for a file and attempt to check it out. With an argument, lock the
237     file."
238     "Prompt for a file and attempt to check it out. With an argument, lock the
239     file."
240     (let ((pathname (prompt-for-file :prompt "File to check out: "
241 ch 1.2 :default (buffer-default-pathname
242     (current-buffer))
243 wlott 1.1 :must-exist nil)))
244     (rcs-check-out-file pathname p)
245     (find-file-command nil pathname)))
246    
247     (defhvar "RCS Log Entry Buffer"
248     "Name of the buffer to put RCS log entries into."
249     :value "RCS Log")
250    
251     (defun get-log-buffer ()
252     (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
253     (unless buffer
254     (setf buffer (make-buffer (value rcs-log-entry-buffer)))
255 ch 1.2 (turn-auto-save-off buffer))
256 wlott 1.1 buffer))
257    
258     (defcommand "RCS Buffer File Log Entry" (p)
259     "Get the RCS Log for the file in the current buffer in a buffer."
260     "Get the RCS Log for the file in the current buffer in a buffer."
261     (declare (ignore p))
262     (let ((buffer (get-log-buffer))
263     (pathname (current-buffer-pathname)))
264     (delete-region (buffer-region buffer))
265 ch 1.2 (message "Extracting log info ...")
266 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
267     (in-directory pathname
268     (do-command "rlog" (list (file-namestring pathname))
269     :output (make-hemlock-output-stream mark))))
270     (change-to-buffer buffer)
271     (buffer-start (current-point))
272     (setf (buffer-modified buffer) nil)))
273    
274     (defcommand "RCS File Log Entry" (p)
275 ch 1.2 "Prompt for a file and get its RCS log entry in a buffer."
276     "Prompt for a file and get its RCS log entry in a buffer."
277 wlott 1.1 (declare (ignore p))
278     (let ((file (prompt-for-file :prompt "File to get log of: "
279 ch 1.2 :default (buffer-default-pathname
280     (current-buffer))
281 wlott 1.1 :must-exist nil))
282     (buffer (get-log-buffer)))
283     (delete-region (buffer-region buffer))
284 ch 1.2 (message "Extracing log info ...")
285 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
286     (in-directory file
287     (do-command "rlog" (list (file-namestring file))
288     :output (make-hemlock-output-stream mark))))
289     (change-to-buffer buffer)
290     (buffer-start (current-point))
291     (setf (buffer-modified buffer) nil)))
292 wlott 1.3
293    
294     (defcommand "RCS Update Directory" (p)
295     "Prompt for a directory and check out all files that are older than the
296     corresponding RCS file. With an argument, never ask about overwriting
297     writable files."
298     "Prompt for a directory and check out all files that are older than the
299     corresponding RCS file. With an argument, never ask about overwriting
300     writable files."
301     (let* ((def (buffer-default-pathname (current-buffer)))
302     (dir (prompt-for-file :prompt "Directory to update: "
303     :default (make-pathname
304     :host (pathname-host def)
305     :device (pathname-device def)
306     :directory (pathname-directory def)
307     :defaults nil)
308     :must-exist nil)))
309     (unless (directoryp dir)
310     (let ((with-slash (parse-namestring (concatenate 'simple-string
311     (namestring dir)
312     "/"))))
313     (unless (directoryp with-slash)
314     (editor-error "~S is not a directory" (namestring dir)))
315     (setf dir with-slash)))
316     (let ((rcsdir
317     (make-pathname :host (pathname-host dir)
318     :device (pathname-device dir)
319     :directory (concatenate 'simple-vector
320     (pathname-directory dir)
321     (vector "RCS"))))
322 wlott 1.5 (count 0))
323 wlott 1.3 (unless (directoryp rcsdir)
324     (editor-error "Could not find the RCS directory."))
325     (dolist (rcsfile (directory rcsdir))
326     (let ((rcsname (file-namestring rcsfile)))
327     (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
328     (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
329     (file (merge-pathnames (parse-namestring name)
330     dir)))
331 wlott 1.5 (when (and (probe-file file)
332     (< (file-write-date file) (file-write-date rcsfile)))
333 wlott 1.3 (multiple-value-bind
334     (won dev inode mode)
335     (mach:unix-stat (namestring file))
336     (declare (ignore dev inode))
337     (when (and won (not (zerop (logand mode mach:writeown))))
338     (cond ((or p
339     (not (prompt-for-y-or-n
340     :prompt
341     (format nil
342     "~S is writable, overwrite? "
343     (namestring file))
344     :default nil
345     :default-string "n")))
346     (let ((private
347     (merge-pathnames (concatenate
348     'simple-string
349     (file-namestring file)
350     ".private")
351     file)))
352     (message "Renaming ~S to ~S"
353     (namestring file)
354     (namestring private))
355     (rename-file file private)))
356     (t
357     (delete-file file))))
358 wlott 1.5 (incf count)
359 wlott 1.3 (rcs-check-out-file file nil)))))))
360 wlott 1.5 (if (zerop count)
361     (message "No files are out of date.")
362     (message "Checked out ~D file~:P" count)))))

  ViewVC Help
Powered by ViewVC 1.1.5