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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (hide annotations)
Sat Mar 3 01:03:55 1990 UTC (24 years, 1 month ago) by ch
Branch: MAIN
Changes since 1.12: +4 -3 lines
Frobbed a few messages to be more descriptive.
1 ch 1.6 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 wlott 1.1 ;;;
3 ch 1.13 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.13 1990/03/03 01:03:55 ch Exp $
4 wlott 1.1 ;;;
5 ch 1.12 ;;; Various commands for dealing with RCS under Hemlock.
6 wlott 1.1 ;;;
7     (in-package "HEMLOCK")
8    
9 ch 1.6
10     ;;;;
11 wlott 1.1
12 ch 1.6 (defhvar "RCS Check Out Keep Original As Backup"
13     "If non-NIL, all comamnds which perform an RCS check out will rename
14     any existing original file to a backup filename."
15     :value nil)
16    
17 wlott 1.1 (defun current-buffer-pathname ()
18     (let ((pathname (buffer-pathname (current-buffer))))
19     (unless pathname
20     (editor-error "The buffer has no pathname."))
21     pathname))
22    
23    
24     (defmacro in-directory (directory &body forms)
25     (let ((cwd (gensym)))
26     `(let ((,cwd (ext:default-directory)))
27     (unwind-protect
28     (progn
29     (setf (ext:default-directory) (directory-namestring ,directory))
30     ,@forms)
31     (setf (ext:default-directory) ,cwd)))))
32    
33    
34     (defvar *error-stream* (make-string-output-stream))
35    
36     (defmacro do-command (&rest args)
37     (let ((proc (gensym)))
38     `(progn
39     (get-output-stream-string *error-stream*)
40     (let ((,proc (ext:run-program ,@args :error *error-stream*)))
41     (case (ext:process-status ,proc)
42     (:exited
43     (unless (zerop (ext:process-exit-code ,proc))
44     (editor-error "~A" (get-output-stream-string *error-stream*))))
45     (:signaled
46     (editor-error "~A killed with signal ~A ~@[core dumped]"
47     ',(car args)
48     (ext:process-exit-code ,proc)
49     (ext:process-core-dumped ,proc)))
50     (t
51     (editor-error "~S still alive?" ,proc)))))))
52    
53     (defun buffer-different-from-file (buffer filename)
54     (with-open-file (file filename)
55     (do ((buffer-line (mark-line (buffer-start-mark buffer))
56     (line-next buffer-line))
57     (file-line (read-line file nil nil)
58     (read-line file nil nil)))
59     ((and (or (null buffer-line)
60     (zerop (line-length buffer-line)))
61     (null file-line))
62     nil)
63     (when (or (null buffer-line)
64     (null file-line)
65     (string/= (line-string buffer-line) file-line))
66     (return t)))))
67    
68 ch 1.2 (defun turn-auto-save-off (buffer)
69     (setf (buffer-minor-mode buffer "Save") nil)
70     ;;
71     ;; William's personal hack
72     (when (getstring "Ckp" *mode-names*)
73     (setf (buffer-minor-mode buffer "Ckp") nil)))
74    
75 ch 1.7
76     (defhvar "RCS Lock File Hook"
77     "RCS Lock File Hook"
78     :value nil)
79    
80     (defun rcs-lock-file (buffer pathname)
81 ch 1.2 (message "Locking ~A ..." (namestring pathname))
82 wlott 1.1 (in-directory pathname
83     (let ((file (file-namestring pathname)))
84     (do-command "rcs" `("-l" ,file))
85 ch 1.6 (multiple-value-bind (won dev ino mode) (mach:unix-stat file)
86     (declare (ignore ino))
87     (cond (won
88     (mach:unix-chmod file (logior mode mach:writeown)))
89     (t
90     (editor-error "MACH:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
91 ch 1.7 (mach:get-unix-error-msg dev)))))))
92     (invoke-hook rcs-lock-file-hook buffer pathname))
93 wlott 1.1
94 ch 1.7
95     (defhvar "RCS Unlock File Hook"
96     "RCS Unlock File Hook"
97     :value nil)
98    
99     (defun rcs-unlock-file (buffer pathname)
100 ch 1.2 (message "Unlocking ~A ..." (namestring pathname))
101 wlott 1.1 (in-directory pathname
102 ch 1.7 (do-command "rcs" `("-u" ,(file-namestring pathname))))
103     (invoke-hook rcs-unlock-file-hook buffer pathname))
104 wlott 1.1
105 ch 1.6
106     ;;;; Check In
107    
108 ch 1.7 (defhvar "RCS Check In File Hook"
109     "RCS Check In File Hook"
110     :value nil)
111    
112     (defun rcs-check-in-file (buffer pathname keep-lock)
113 wlott 1.1 (let ((old-buffer (current-buffer))
114     (allow-delete nil)
115 ch 1.7 (log-buffer nil))
116 wlott 1.1 (unwind-protect
117     (when (block in-recursive-edit
118     (do ((i 0 (1+ i)))
119 ch 1.7 ((not (null log-buffer)))
120     (setf log-buffer
121     (make-buffer
122     (format nil "RCS Log Entry ~D for ~S" i
123     (file-namestring pathname))
124     :modes '("Text")
125     :delete-hook
126     (list #'(lambda (buffer)
127     (declare (ignore buffer))
128     (unless allow-delete
129     (return-from in-recursive-edit t)))))))
130     (turn-auto-save-off log-buffer)
131     (change-to-buffer log-buffer)
132 wlott 1.1 (do-recursive-edit)
133    
134 ch 1.13 (message "Checking in ~A~:[~; keeping the lock~] ..."
135     (namestring pathname) keep-lock)
136 ch 1.8 (let ((log-stream (make-hemlock-region-stream
137     (buffer-region log-buffer))))
138     (sub-check-in-file pathname keep-lock log-stream))
139 ch 1.7 (invoke-hook rcs-check-in-file-hook buffer pathname)
140 wlott 1.1 nil)
141     (editor-error "Someone deleted the RCS Log Entry buffer."))
142     (change-to-buffer old-buffer)
143     (setf allow-delete t)
144 ch 1.9 (delete-buffer-if-possible log-buffer))))
145 ch 1.8
146     (defun sub-check-in-file (pathname keep-lock log-stream)
147     (let* ((filename (file-namestring pathname))
148     (rcs-filename (concatenate 'simple-string
149     "./RCS/" filename ",v")))
150     (in-directory pathname
151     (do-command "rcsci" `(,@(if keep-lock '("-l"))
152     "-u"
153 ch 1.12 ,filename)
154 ch 1.8 :input log-stream)
155     ;;
156     ;; Set the times on the user's file to be equivalent to that of
157     ;; the rcs file.
158     (multiple-value-bind
159     (dev ino mode nlink uid gid rdev size atime mtime)
160     (mach:unix-stat rcs-filename)
161     (declare (ignore mode nlink uid gid rdev size))
162     (cond (dev
163     (multiple-value-bind
164     (wonp errno)
165 ch 1.11 (mach:unix-utimes filename (list atime 0 mtime 0))
166 ch 1.8 (unless wonp
167     (editor-error "MACH:UNIX-UTIMES failed: ~A"
168     (mach:get-unix-error-msg errno)))))
169     (t
170     (editor-error "MACH:UNIX-STAT failed: ~A"
171     (mach:get-unix-error-msg ino))))))))
172 wlott 1.1
173 ch 1.6
174     ;;;; Check Out
175    
176 ch 1.7 (defhvar "RCS Check Out File Hook"
177     "RCS Check Out File Hook"
178     :value nil)
179 ch 1.6
180 ch 1.7 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
181     (sub-maybe-rcs-check-out-files buffer (list pathname)
182     lock always-overwrite-p))
183    
184 ch 1.6 (defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
185 ch 1.7 (sub-maybe-rcs-check-out-files nil pathnames lock always-overwrite-p))
186    
187     (defun sub-maybe-rcs-check-out-files (buffer pathnames lock always-overwrite-p)
188 ch 1.6 (let ((check-out-count 0))
189     (macrolet ((frob ()
190     `(progn
191 ch 1.7 (rcs-check-out-file buffer pathname lock)
192 ch 1.6 (incf check-out-count))))
193     (dolist (pathname pathnames)
194     (cond
195     ((and (not always-overwrite-p)
196     (probe-file pathname) (ext:file-writable pathname))
197     ;; File exists and is writable so check and see if the user really
198     ;; wants to check it out.
199     (command-case (:prompt
200     (format nil "The file ~A is writable. Overwrite? "
201     (file-namestring pathname))
202     :help
203     "Type one of the following single-character commands:")
204     ((:yes :confirm)
205     "Overwrite the file."
206     (frob))
207     (:no
208     "Skip checking out this file.")
209     ((#\r #\R)
210     "Rename the file before checking it out."
211     (let ((new-pathname (prompt-for-file
212     :prompt "New Filename: "
213     :default (buffer-default-pathname
214     (current-buffer))
215     :must-exist nil)))
216     (rename-file pathname new-pathname)
217     (frob)))
218     (:do-all
219     "Overwrite this file and all remaining files."
220     (setf always-overwrite-p t)
221     (frob))
222     (:do-once
223     "Overwrite this file and then exit."
224     (frob)
225     (return))))
226     (t
227     (frob)))))
228     check-out-count))
229    
230 ch 1.7 (defun rcs-check-out-file (buffer pathname lock)
231 ch 1.13 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
232 wlott 1.1 (in-directory pathname
233 wlott 1.3 (let ((backup
234     (if (probe-file pathname)
235     (lisp::pick-backup-name (namestring pathname))
236     nil)))
237 ch 1.6 (when backup (rename-file pathname backup))
238 wlott 1.1 (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
239 ch 1.7 (invoke-hook rcs-check-out-file-hook buffer pathname)
240 ch 1.6 (unless (value rcs-check-out-keep-original-as-backup)
241 wlott 1.3 (delete-file backup)))))
242 wlott 1.1
243     (defun pick-temp-file (defaults)
244     (let ((index 0))
245     (loop
246     (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
247     (cond ((probe-file name)
248     (incf index))
249     (t
250     (return name)))))))
251    
252 ch 1.6
253     ;;;; Checking In / Checking Out and Locking / Unlocking
254    
255 wlott 1.1 (defcommand "RCS Lock Buffer File" (p)
256     "Attempt to lock the file in the current buffer."
257     "Attempt to lock the file in the current buffer."
258     (declare (ignore p))
259     (let ((file (current-buffer-pathname))
260     (buffer (current-buffer))
261     (name (pick-temp-file "/tmp/")))
262 ch 1.7 (rcs-lock-file buffer file)
263 wlott 1.1 (unwind-protect
264     (progn
265     (in-directory file
266     (do-command "rcsco" `("-p" ,(file-namestring file))
267     :output (namestring name)))
268     (when (buffer-different-from-file buffer name)
269     (message
270 ch 1.2 "RCS file is different: be sure to merge in your changes."))
271 wlott 1.1 (setf (buffer-writable buffer) t)
272     (message "Buffer is now writable."))
273     (when (probe-file name)
274     (delete-file name)))))
275    
276     (defcommand "RCS Lock File" (p)
277     "Prompt for a file, and attempt to lock it."
278     "Prompt for a file, and attempt to lock it."
279     (declare (ignore p))
280 ch 1.7 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
281     :default (buffer-default-pathname
282     (current-buffer))
283     :must-exist nil)))
284 wlott 1.1
285     (defcommand "RCS Unlock Buffer File" (p)
286     "Unlock the file in the current buffer."
287     "Unlock the file in the current buffer."
288     (declare (ignore p))
289 ch 1.7 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
290 wlott 1.1 (setf (buffer-writable (current-buffer)) nil)
291     (message "Buffer is no longer writable."))
292    
293     (defcommand "RCS Unlock File" (p)
294     "Prompt for a file, and attempt to unlock it."
295     "Prompt for a file, and attempt to unlock it."
296     (declare (ignore p))
297 ch 1.7 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
298     :default (buffer-default-pathname
299     (current-buffer))
300     :must-exist nil)))
301 wlott 1.1
302     (defcommand "RCS Check In Buffer File" (p)
303 ch 1.6 "Checkin the file in the current buffer. With an argument, do not
304     release the lock."
305     "Checkin the file in the current buffer. With an argument, do not
306     release the lock."
307 wlott 1.1 (let ((buffer (current-buffer))
308     (pathname (current-buffer-pathname)))
309     (when (buffer-modified buffer)
310     (save-file-command nil))
311 ch 1.7 (rcs-check-in-file buffer pathname p)
312 wlott 1.1 (visit-file-command nil pathname buffer)))
313    
314     (defcommand "RCS Check In File" (p)
315 ch 1.6 "Prompt for a file, and attempt to check it in. With an argument, do
316     not release the lock."
317     "Prompt for a file, and attempt to check it in. With an argument, do
318     not release the lock."
319 ch 1.7 (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
320     :default
321     (buffer-default-pathname
322     (current-buffer))
323     :must-exist nil)
324 wlott 1.1 p))
325    
326     (defcommand "RCS Check Out Buffer File" (p)
327 ch 1.6 "Checkout the file in the current buffer. With an argument, lock the
328     file."
329     "Checkout the file in the current buffer. With an argument, lock the
330     file."
331 wlott 1.1 (let* ((buffer (current-buffer))
332     (pathname (current-buffer-pathname))
333     (point (current-point))
334     (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
335     (when (buffer-modified buffer)
336     (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
337     (editor-error "Aborted.")))
338 ch 1.7 (maybe-rcs-check-out-file buffer pathname p nil)
339 wlott 1.1 (setf (buffer-modified buffer) nil)
340     (when p
341     (setf (buffer-writable buffer) t)
342     (message "Buffer is now writable."))
343     (visit-file-command nil pathname)
344     (unless (line-offset point lines)
345     (buffer-end point))))
346    
347     (defcommand "RCS Check Out File" (p)
348 ch 1.6 "Prompt for a file and attempt to check it out. With an argument,
349     lock the file."
350     "Prompt for a file and attempt to check it out. With an argument,
351     lock the file."
352 wlott 1.1 (let ((pathname (prompt-for-file :prompt "File to check out: "
353 ch 1.2 :default (buffer-default-pathname
354     (current-buffer))
355 wlott 1.1 :must-exist nil)))
356 ch 1.7 (maybe-rcs-check-out-file nil pathname p nil)
357 wlott 1.1 (find-file-command nil pathname)))
358    
359 ch 1.6
360     ;;;; Log File
361    
362 wlott 1.1 (defhvar "RCS Log Entry Buffer"
363     "Name of the buffer to put RCS log entries into."
364     :value "RCS Log")
365    
366 ch 1.7 (defhvar "RCS Log Buffer Hook"
367     "RCS Log Buffer Hook"
368     :value nil)
369    
370 wlott 1.1 (defun get-log-buffer ()
371     (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
372     (unless buffer
373     (setf buffer (make-buffer (value rcs-log-entry-buffer)))
374 ch 1.7 (turn-auto-save-off buffer)
375     (invoke-hook rcs-log-buffer-hook buffer))
376 wlott 1.1 buffer))
377    
378     (defcommand "RCS Buffer File Log Entry" (p)
379     "Get the RCS Log for the file in the current buffer in a buffer."
380     "Get the RCS Log for the file in the current buffer in a buffer."
381     (declare (ignore p))
382     (let ((buffer (get-log-buffer))
383     (pathname (current-buffer-pathname)))
384     (delete-region (buffer-region buffer))
385 ch 1.2 (message "Extracting log info ...")
386 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
387     (in-directory pathname
388     (do-command "rlog" (list (file-namestring pathname))
389     :output (make-hemlock-output-stream mark))))
390     (change-to-buffer buffer)
391     (buffer-start (current-point))
392     (setf (buffer-modified buffer) nil)))
393    
394     (defcommand "RCS File Log Entry" (p)
395 ch 1.2 "Prompt for a file and get its RCS log entry in a buffer."
396     "Prompt for a file and get its RCS log entry in a buffer."
397 wlott 1.1 (declare (ignore p))
398     (let ((file (prompt-for-file :prompt "File to get log of: "
399 ch 1.2 :default (buffer-default-pathname
400     (current-buffer))
401 wlott 1.1 :must-exist nil))
402     (buffer (get-log-buffer)))
403     (delete-region (buffer-region buffer))
404 ch 1.2 (message "Extracing log info ...")
405 wlott 1.1 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
406     (in-directory file
407     (do-command "rlog" (list (file-namestring file))
408     :output (make-hemlock-output-stream mark))))
409     (change-to-buffer buffer)
410     (buffer-start (current-point))
411     (setf (buffer-modified buffer) nil)))
412 wlott 1.3
413 ch 1.6
414     ;;;; Directory Support
415 wlott 1.3
416 ch 1.6 (defun list-out-of-date-files (dir)
417     (let ((rcsdir (make-pathname :host (pathname-host dir)
418     :device (pathname-device dir)
419     :directory (concatenate 'simple-vector
420     (pathname-directory dir)
421     (vector "RCS"))))
422     (out-of-date-files nil))
423     (unless (directoryp rcsdir)
424     (editor-error "Could not find the RCS directory."))
425     (dolist (rcsfile (directory rcsdir))
426     (let ((rcsname (file-namestring rcsfile)))
427     (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
428     (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
429     (file (merge-pathnames (parse-namestring name) dir)))
430     (unless (and (probe-file file)
431     (>= (file-write-date file) (file-write-date rcsfile)))
432     (push file out-of-date-files))))))
433     out-of-date-files))
434    
435     (defun rcs-prompt-for-directory (prompt)
436     (let* ((default (buffer-default-pathname (current-buffer)))
437     (dir (prompt-for-file :prompt prompt
438 wlott 1.3 :default (make-pathname
439 ch 1.6 :host (pathname-host default)
440     :device (pathname-device default)
441     :directory (pathname-directory default)
442 wlott 1.3 :defaults nil)
443     :must-exist nil)))
444     (unless (directoryp dir)
445     (let ((with-slash (parse-namestring (concatenate 'simple-string
446     (namestring dir)
447     "/"))))
448     (unless (directoryp with-slash)
449     (editor-error "~S is not a directory" (namestring dir)))
450     (setf dir with-slash)))
451 ch 1.6 dir))
452    
453     (defcommand "RCS Update Directory" (p)
454     "Prompt for a directory and check out all files that are older than
455     their corresponding RCS files. With an argument, never ask about
456     overwriting writable files."
457     "Prompt for a directory and check out all files that are older than
458     the corresponding RCS file. With an argument, never ask about
459     overwriting writable files."
460     (let* ((directory (rcs-prompt-for-directory "Directory to update: "))
461     (out-of-date-files (list-out-of-date-files directory))
462     (n-out-of-date (length out-of-date-files)))
463     (cond ((zerop n-out-of-date)
464     (message "All RCS files in ~A are up to date."
465     (namestring directory)))
466     (t
467     (let ((n-checked-out
468     (maybe-rcs-check-out-files out-of-date-files nil p)))
469     (message "Number of files out of date: ~D; ~
470     number of files checked out: ~D"
471     n-out-of-date n-checked-out)))))))
472    
473     (defcommand "RCS List Out Of Date Files" (p)
474     "Prompt for a directory and list all of the files that are older than
475     their corresponding RCS files."
476     "Prompt for a directory and list all of the files that are older than
477     their corresponding RCS files."
478     (declare (ignore p))
479     (let* ((directory (rcs-prompt-for-directory "Directory: "))
480     (out-of-date-files (list-out-of-date-files directory)))
481     (cond ((null out-of-date-files)
482     (message "All RCS files in ~A are up to date."
483     (namestring directory)))
484     (t
485     (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*")
486     (format s "Directory: ~A~%~%" (namestring directory))
487     (dolist (file out-of-date-files)
488     (format s "~A~%" (file-namestring file))))))))

  ViewVC Help
Powered by ViewVC 1.1.5