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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show 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 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 ;;;
3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.13 1990/03/03 01:03:55 ch Exp $
4 ;;;
5 ;;; Various commands for dealing with RCS under Hemlock.
6 ;;;
7 (in-package "HEMLOCK")
8
9
10 ;;;;
11
12 (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 (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 (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
76 (defhvar "RCS Lock File Hook"
77 "RCS Lock File Hook"
78 :value nil)
79
80 (defun rcs-lock-file (buffer pathname)
81 (message "Locking ~A ..." (namestring pathname))
82 (in-directory pathname
83 (let ((file (file-namestring pathname)))
84 (do-command "rcs" `("-l" ,file))
85 (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 (mach:get-unix-error-msg dev)))))))
92 (invoke-hook rcs-lock-file-hook buffer pathname))
93
94
95 (defhvar "RCS Unlock File Hook"
96 "RCS Unlock File Hook"
97 :value nil)
98
99 (defun rcs-unlock-file (buffer pathname)
100 (message "Unlocking ~A ..." (namestring pathname))
101 (in-directory pathname
102 (do-command "rcs" `("-u" ,(file-namestring pathname))))
103 (invoke-hook rcs-unlock-file-hook buffer pathname))
104
105
106 ;;;; Check In
107
108 (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 (let ((old-buffer (current-buffer))
114 (allow-delete nil)
115 (log-buffer nil))
116 (unwind-protect
117 (when (block in-recursive-edit
118 (do ((i 0 (1+ i)))
119 ((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 (do-recursive-edit)
133
134 (message "Checking in ~A~:[~; keeping the lock~] ..."
135 (namestring pathname) keep-lock)
136 (let ((log-stream (make-hemlock-region-stream
137 (buffer-region log-buffer))))
138 (sub-check-in-file pathname keep-lock log-stream))
139 (invoke-hook rcs-check-in-file-hook buffer pathname)
140 nil)
141 (editor-error "Someone deleted the RCS Log Entry buffer."))
142 (change-to-buffer old-buffer)
143 (setf allow-delete t)
144 (delete-buffer-if-possible log-buffer))))
145
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 ,filename)
154 :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 (mach:unix-utimes filename (list atime 0 mtime 0))
166 (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
173
174 ;;;; Check Out
175
176 (defhvar "RCS Check Out File Hook"
177 "RCS Check Out File Hook"
178 :value nil)
179
180 (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 (defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
185 (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 (let ((check-out-count 0))
189 (macrolet ((frob ()
190 `(progn
191 (rcs-check-out-file buffer pathname lock)
192 (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 (defun rcs-check-out-file (buffer pathname lock)
231 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
232 (in-directory pathname
233 (let ((backup
234 (if (probe-file pathname)
235 (lisp::pick-backup-name (namestring pathname))
236 nil)))
237 (when backup (rename-file pathname backup))
238 (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
239 (invoke-hook rcs-check-out-file-hook buffer pathname)
240 (unless (value rcs-check-out-keep-original-as-backup)
241 (delete-file backup)))))
242
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
253 ;;;; Checking In / Checking Out and Locking / Unlocking
254
255 (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 (rcs-lock-file buffer file)
263 (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 "RCS file is different: be sure to merge in your changes."))
271 (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 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
281 :default (buffer-default-pathname
282 (current-buffer))
283 :must-exist nil)))
284
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 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
290 (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 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
298 :default (buffer-default-pathname
299 (current-buffer))
300 :must-exist nil)))
301
302 (defcommand "RCS Check In Buffer File" (p)
303 "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 (let ((buffer (current-buffer))
308 (pathname (current-buffer-pathname)))
309 (when (buffer-modified buffer)
310 (save-file-command nil))
311 (rcs-check-in-file buffer pathname p)
312 (visit-file-command nil pathname buffer)))
313
314 (defcommand "RCS Check In File" (p)
315 "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 (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 p))
325
326 (defcommand "RCS Check Out Buffer File" (p)
327 "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 (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 (maybe-rcs-check-out-file buffer pathname p nil)
339 (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 "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 (let ((pathname (prompt-for-file :prompt "File to check out: "
353 :default (buffer-default-pathname
354 (current-buffer))
355 :must-exist nil)))
356 (maybe-rcs-check-out-file nil pathname p nil)
357 (find-file-command nil pathname)))
358
359
360 ;;;; Log File
361
362 (defhvar "RCS Log Entry Buffer"
363 "Name of the buffer to put RCS log entries into."
364 :value "RCS Log")
365
366 (defhvar "RCS Log Buffer Hook"
367 "RCS Log Buffer Hook"
368 :value nil)
369
370 (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 (turn-auto-save-off buffer)
375 (invoke-hook rcs-log-buffer-hook buffer))
376 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 (message "Extracting log info ...")
386 (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 "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 (declare (ignore p))
398 (let ((file (prompt-for-file :prompt "File to get log of: "
399 :default (buffer-default-pathname
400 (current-buffer))
401 :must-exist nil))
402 (buffer (get-log-buffer)))
403 (delete-region (buffer-region buffer))
404 (message "Extracing log info ...")
405 (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
413
414 ;;;; Directory Support
415
416 (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 :default (make-pathname
439 :host (pathname-host default)
440 :device (pathname-device default)
441 :directory (pathname-directory default)
442 :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 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