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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Sat Mar 3 00:40:10 1990 UTC (24 years, 1 month ago) by ch
Branch: MAIN
Changes since 1.10: +2 -2 lines
Fixed a silly bug in check in utimes(2) code.
1 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 ;;;
3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.11 1990/03/03 00:40:10 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 ..." (namestring pathname))
135 (let ((log-stream (make-hemlock-region-stream
136 (buffer-region log-buffer))))
137 (sub-check-in-file pathname keep-lock log-stream))
138 (invoke-hook rcs-check-in-file-hook buffer pathname)
139 nil)
140 (editor-error "Someone deleted the RCS Log Entry buffer."))
141 (change-to-buffer old-buffer)
142 (setf allow-delete t)
143 (delete-buffer-if-possible log-buffer))))
144
145 (defun sub-check-in-file (pathname keep-lock log-stream)
146 (let* ((filename (file-namestring pathname))
147 (rcs-filename (concatenate 'simple-string
148 "./RCS/" filename ",v")))
149 (in-directory pathname
150 (do-command "rcsci" `(,@(if keep-lock '("-l"))
151 "-u"
152 ,(file-namestring pathname))
153 :input log-stream)
154 ;;
155 ;; Set the times on the user's file to be equivalent to that of
156 ;; the rcs file.
157 (multiple-value-bind
158 (dev ino mode nlink uid gid rdev size atime mtime)
159 (mach:unix-stat rcs-filename)
160 (declare (ignore mode nlink uid gid rdev size))
161 (cond (dev
162 (multiple-value-bind
163 (wonp errno)
164 (mach:unix-utimes filename (list atime 0 mtime 0))
165 (unless wonp
166 (editor-error "MACH:UNIX-UTIMES failed: ~A"
167 (mach:get-unix-error-msg errno)))))
168 (t
169 (editor-error "MACH:UNIX-STAT failed: ~A"
170 (mach:get-unix-error-msg ino))))))))
171
172
173 ;;;; Check Out
174
175 (defhvar "RCS Check Out File Hook"
176 "RCS Check Out File Hook"
177 :value nil)
178
179 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
180 (sub-maybe-rcs-check-out-files buffer (list pathname)
181 lock always-overwrite-p))
182
183 (defun maybe-rcs-check-out-files (pathnames lock always-overwrite-p)
184 (sub-maybe-rcs-check-out-files nil pathnames lock always-overwrite-p))
185
186 (defun sub-maybe-rcs-check-out-files (buffer pathnames lock always-overwrite-p)
187 (let ((check-out-count 0))
188 (macrolet ((frob ()
189 `(progn
190 (rcs-check-out-file buffer pathname lock)
191 (incf check-out-count))))
192 (dolist (pathname pathnames)
193 (cond
194 ((and (not always-overwrite-p)
195 (probe-file pathname) (ext:file-writable pathname))
196 ;; File exists and is writable so check and see if the user really
197 ;; wants to check it out.
198 (command-case (:prompt
199 (format nil "The file ~A is writable. Overwrite? "
200 (file-namestring pathname))
201 :help
202 "Type one of the following single-character commands:")
203 ((:yes :confirm)
204 "Overwrite the file."
205 (frob))
206 (:no
207 "Skip checking out this file.")
208 ((#\r #\R)
209 "Rename the file before checking it out."
210 (let ((new-pathname (prompt-for-file
211 :prompt "New Filename: "
212 :default (buffer-default-pathname
213 (current-buffer))
214 :must-exist nil)))
215 (rename-file pathname new-pathname)
216 (frob)))
217 (:do-all
218 "Overwrite this file and all remaining files."
219 (setf always-overwrite-p t)
220 (frob))
221 (:do-once
222 "Overwrite this file and then exit."
223 (frob)
224 (return))))
225 (t
226 (frob)))))
227 check-out-count))
228
229 (defun rcs-check-out-file (buffer pathname lock)
230 (message "Checking out ~A ..." (namestring pathname))
231 (in-directory pathname
232 (let ((backup
233 (if (probe-file pathname)
234 (lisp::pick-backup-name (namestring pathname))
235 nil)))
236 (when backup (rename-file pathname backup))
237 (do-command "rcsco" `(,@(if lock '("-l")) ,(file-namestring pathname)))
238 (invoke-hook rcs-check-out-file-hook buffer pathname)
239 (unless (value rcs-check-out-keep-original-as-backup)
240 (delete-file backup)))))
241
242 (defun pick-temp-file (defaults)
243 (let ((index 0))
244 (loop
245 (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
246 (cond ((probe-file name)
247 (incf index))
248 (t
249 (return name)))))))
250
251
252 ;;;; Checking In / Checking Out and Locking / Unlocking
253
254 (defcommand "RCS Lock Buffer File" (p)
255 "Attempt to lock the file in the current buffer."
256 "Attempt to lock the file in the current buffer."
257 (declare (ignore p))
258 (let ((file (current-buffer-pathname))
259 (buffer (current-buffer))
260 (name (pick-temp-file "/tmp/")))
261 (rcs-lock-file buffer file)
262 (unwind-protect
263 (progn
264 (in-directory file
265 (do-command "rcsco" `("-p" ,(file-namestring file))
266 :output (namestring name)))
267 (when (buffer-different-from-file buffer name)
268 (message
269 "RCS file is different: be sure to merge in your changes."))
270 (setf (buffer-writable buffer) t)
271 (message "Buffer is now writable."))
272 (when (probe-file name)
273 (delete-file name)))))
274
275 (defcommand "RCS Lock File" (p)
276 "Prompt for a file, and attempt to lock it."
277 "Prompt for a file, and attempt to lock it."
278 (declare (ignore p))
279 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
280 :default (buffer-default-pathname
281 (current-buffer))
282 :must-exist nil)))
283
284 (defcommand "RCS Unlock Buffer File" (p)
285 "Unlock the file in the current buffer."
286 "Unlock the file in the current buffer."
287 (declare (ignore p))
288 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
289 (setf (buffer-writable (current-buffer)) nil)
290 (message "Buffer is no longer writable."))
291
292 (defcommand "RCS Unlock File" (p)
293 "Prompt for a file, and attempt to unlock it."
294 "Prompt for a file, and attempt to unlock it."
295 (declare (ignore p))
296 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
297 :default (buffer-default-pathname
298 (current-buffer))
299 :must-exist nil)))
300
301 (defcommand "RCS Check In Buffer File" (p)
302 "Checkin the file in the current buffer. With an argument, do not
303 release the lock."
304 "Checkin the file in the current buffer. With an argument, do not
305 release the lock."
306 (let ((buffer (current-buffer))
307 (pathname (current-buffer-pathname)))
308 (when (buffer-modified buffer)
309 (save-file-command nil))
310 (rcs-check-in-file buffer pathname p)
311 (visit-file-command nil pathname buffer)))
312
313 (defcommand "RCS Check In File" (p)
314 "Prompt for a file, and attempt to check it in. With an argument, do
315 not release the lock."
316 "Prompt for a file, and attempt to check it in. With an argument, do
317 not release the lock."
318 (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
319 :default
320 (buffer-default-pathname
321 (current-buffer))
322 :must-exist nil)
323 p))
324
325 (defcommand "RCS Check Out Buffer File" (p)
326 "Checkout the file in the current buffer. With an argument, lock the
327 file."
328 "Checkout the file in the current buffer. With an argument, lock the
329 file."
330 (let* ((buffer (current-buffer))
331 (pathname (current-buffer-pathname))
332 (point (current-point))
333 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
334 (when (buffer-modified buffer)
335 (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
336 (editor-error "Aborted.")))
337 (maybe-rcs-check-out-file buffer pathname p nil)
338 (setf (buffer-modified buffer) nil)
339 (when p
340 (setf (buffer-writable buffer) t)
341 (message "Buffer is now writable."))
342 (visit-file-command nil pathname)
343 (unless (line-offset point lines)
344 (buffer-end point))))
345
346 (defcommand "RCS Check Out File" (p)
347 "Prompt for a file and attempt to check it out. With an argument,
348 lock the file."
349 "Prompt for a file and attempt to check it out. With an argument,
350 lock the file."
351 (let ((pathname (prompt-for-file :prompt "File to check out: "
352 :default (buffer-default-pathname
353 (current-buffer))
354 :must-exist nil)))
355 (maybe-rcs-check-out-file nil pathname p nil)
356 (find-file-command nil pathname)))
357
358
359 ;;;; Log File
360
361 (defhvar "RCS Log Entry Buffer"
362 "Name of the buffer to put RCS log entries into."
363 :value "RCS Log")
364
365 (defhvar "RCS Log Buffer Hook"
366 "RCS Log Buffer Hook"
367 :value nil)
368
369 (defun get-log-buffer ()
370 (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
371 (unless buffer
372 (setf buffer (make-buffer (value rcs-log-entry-buffer)))
373 (turn-auto-save-off buffer)
374 (invoke-hook rcs-log-buffer-hook buffer))
375 buffer))
376
377 (defcommand "RCS Buffer File Log Entry" (p)
378 "Get the RCS Log for the file in the current buffer in a buffer."
379 "Get the RCS Log for the file in the current buffer in a buffer."
380 (declare (ignore p))
381 (let ((buffer (get-log-buffer))
382 (pathname (current-buffer-pathname)))
383 (delete-region (buffer-region buffer))
384 (message "Extracting log info ...")
385 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
386 (in-directory pathname
387 (do-command "rlog" (list (file-namestring pathname))
388 :output (make-hemlock-output-stream mark))))
389 (change-to-buffer buffer)
390 (buffer-start (current-point))
391 (setf (buffer-modified buffer) nil)))
392
393 (defcommand "RCS File Log Entry" (p)
394 "Prompt for a file and get its RCS log entry in a buffer."
395 "Prompt for a file and get its RCS log entry in a buffer."
396 (declare (ignore p))
397 (let ((file (prompt-for-file :prompt "File to get log of: "
398 :default (buffer-default-pathname
399 (current-buffer))
400 :must-exist nil))
401 (buffer (get-log-buffer)))
402 (delete-region (buffer-region buffer))
403 (message "Extracing log info ...")
404 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
405 (in-directory file
406 (do-command "rlog" (list (file-namestring file))
407 :output (make-hemlock-output-stream mark))))
408 (change-to-buffer buffer)
409 (buffer-start (current-point))
410 (setf (buffer-modified buffer) nil)))
411
412
413 ;;;; Directory Support
414
415 (defun list-out-of-date-files (dir)
416 (let ((rcsdir (make-pathname :host (pathname-host dir)
417 :device (pathname-device dir)
418 :directory (concatenate 'simple-vector
419 (pathname-directory dir)
420 (vector "RCS"))))
421 (out-of-date-files nil))
422 (unless (directoryp rcsdir)
423 (editor-error "Could not find the RCS directory."))
424 (dolist (rcsfile (directory rcsdir))
425 (let ((rcsname (file-namestring rcsfile)))
426 (when (string= rcsname ",v" :start1 (- (length rcsname) 2))
427 (let* ((name (subseq rcsname 0 (- (length rcsname) 2)))
428 (file (merge-pathnames (parse-namestring name) dir)))
429 (unless (and (probe-file file)
430 (>= (file-write-date file) (file-write-date rcsfile)))
431 (push file out-of-date-files))))))
432 out-of-date-files))
433
434 (defun rcs-prompt-for-directory (prompt)
435 (let* ((default (buffer-default-pathname (current-buffer)))
436 (dir (prompt-for-file :prompt prompt
437 :default (make-pathname
438 :host (pathname-host default)
439 :device (pathname-device default)
440 :directory (pathname-directory default)
441 :defaults nil)
442 :must-exist nil)))
443 (unless (directoryp dir)
444 (let ((with-slash (parse-namestring (concatenate 'simple-string
445 (namestring dir)
446 "/"))))
447 (unless (directoryp with-slash)
448 (editor-error "~S is not a directory" (namestring dir)))
449 (setf dir with-slash)))
450 dir))
451
452 (defcommand "RCS Update Directory" (p)
453 "Prompt for a directory and check out all files that are older than
454 their corresponding RCS files. With an argument, never ask about
455 overwriting writable files."
456 "Prompt for a directory and check out all files that are older than
457 the corresponding RCS file. With an argument, never ask about
458 overwriting writable files."
459 (let* ((directory (rcs-prompt-for-directory "Directory to update: "))
460 (out-of-date-files (list-out-of-date-files directory))
461 (n-out-of-date (length out-of-date-files)))
462 (cond ((zerop n-out-of-date)
463 (message "All RCS files in ~A are up to date."
464 (namestring directory)))
465 (t
466 (let ((n-checked-out
467 (maybe-rcs-check-out-files out-of-date-files nil p)))
468 (message "Number of files out of date: ~D; ~
469 number of files checked out: ~D"
470 n-out-of-date n-checked-out)))))))
471
472 (defcommand "RCS List Out Of Date Files" (p)
473 "Prompt for a directory and list all of the files that are older than
474 their corresponding RCS files."
475 "Prompt for a directory and list all of the files that are older than
476 their corresponding RCS files."
477 (declare (ignore p))
478 (let* ((directory (rcs-prompt-for-directory "Directory: "))
479 (out-of-date-files (list-out-of-date-files directory)))
480 (cond ((null out-of-date-files)
481 (message "All RCS files in ~A are up to date."
482 (namestring directory)))
483 (t
484 (with-pop-up-display (s :buffer-name "*RCS Out of Date Files*")
485 (format s "Directory: ~A~%~%" (namestring directory))
486 (dolist (file out-of-date-files)
487 (format s "~A~%" (file-namestring file))))))))

  ViewVC Help
Powered by ViewVC 1.1.5