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

Contents of /src/hemlock/rcs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Fri Mar 24 13:06:58 1995 UTC (19 years ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.28: +2 -1 lines
Don't try to set write date on systems w/o times.
1 ;;; -*- Package: HEMLOCK; Mode: Lisp -*-
2 ;;;
3 ;;; $Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/rcs.lisp,v 1.29 1995/03/24 13:06:58 ram Rel $
4 ;;;
5 ;;; Various commands for dealing with RCS under Hemlock.
6 ;;;
7 ;;; Written by William Lott and Christopher Hoover.
8 ;;;
9 (in-package "HEMLOCK")
10
11
12 ;;;;
13
14 (defun current-buffer-pathname ()
15 (let ((pathname (buffer-pathname (current-buffer))))
16 (unless pathname
17 (editor-error "The buffer has no pathname."))
18 pathname))
19
20
21 (defmacro in-directory (directory &body forms)
22 (let ((cwd (gensym)))
23 `(let ((,cwd (ext:default-directory)))
24 (unwind-protect
25 (progn
26 (setf (ext:default-directory) (directory-namestring ,directory))
27 ,@forms)
28 (setf (ext:default-directory) ,cwd)))))
29
30
31 (defvar *last-rcs-command-name* nil)
32 (defvar *last-rcs-command-output-string* nil)
33 (defvar *rcs-output-stream* (make-string-output-stream))
34
35 (defmacro do-command (command &rest args)
36 `(progn
37 (setf *last-rcs-command-name* ',command)
38 (get-output-stream-string *rcs-output-stream*)
39 (let ((process (ext:run-program ',command ,@args
40 :error *rcs-output-stream*)))
41 (setf *last-rcs-command-output-string*
42 (get-output-stream-string *rcs-output-stream*))
43 (case (ext:process-status process)
44 (:exited
45 (unless (zerop (ext:process-exit-code process))
46 (editor-error "~A aborted with an error; ~
47 use the ``RCS Last Command Output'' command for ~
48 more information" ',command)))
49 (:signaled
50 (editor-error "~A killed with signal ~A~@[ (core dumped)]."
51 ',command
52 (ext:process-exit-code process)
53 (ext:process-core-dumped process)))
54 (t
55 (editor-error "~S still alive?" process))))))
56
57 (defun buffer-different-from-file (buffer filename)
58 (with-open-file (file filename)
59 (do ((buffer-line (mark-line (buffer-start-mark buffer))
60 (line-next buffer-line))
61 (file-line (read-line file nil nil)
62 (read-line file nil nil)))
63 ((and (or (null buffer-line)
64 (zerop (line-length buffer-line)))
65 (null file-line))
66 nil)
67 (when (or (null buffer-line)
68 (null file-line)
69 (string/= (line-string buffer-line) file-line))
70 (return t)))))
71
72 (defun turn-auto-save-off (buffer)
73 (setf (buffer-minor-mode buffer "Save") nil)
74 ;;
75 ;; William's personal hack
76 (when (getstring "Ckp" *mode-names*)
77 (setf (buffer-minor-mode buffer "Ckp") nil)))
78
79
80 (defhvar "RCS Lock File Hook"
81 "RCS Lock File Hook"
82 :value nil)
83
84 (defun rcs-lock-file (buffer pathname)
85 (message "Locking ~A ..." (namestring pathname))
86 (in-directory pathname
87 (let ((file (file-namestring pathname)))
88 (do-command "rcs" `("-l" ,file))
89 (multiple-value-bind (won dev ino mode) (unix:unix-stat file)
90 (declare (ignore ino))
91 (cond (won
92 (unix:unix-chmod file (logior mode unix:writeown)))
93 (t
94 (editor-error "UNIX:UNIX-STAT lost in RCS-LOCK-FILE: ~A"
95 (unix:get-unix-error-msg dev)))))))
96 (invoke-hook rcs-lock-file-hook buffer pathname))
97
98
99 (defhvar "RCS Unlock File Hook"
100 "RCS Unlock File Hook"
101 :value nil)
102
103 (defun rcs-unlock-file (buffer pathname)
104 (message "Unlocking ~A ..." (namestring pathname))
105 (in-directory pathname
106 (do-command "rcs" `("-u" ,(file-namestring pathname))))
107 (invoke-hook rcs-unlock-file-hook buffer pathname))
108
109
110 ;;;; Check In
111
112 (defhvar "RCS Check In File Hook"
113 "RCS Check In File Hook"
114 :value nil)
115
116 (defhvar "RCS Keep Around After Unlocking"
117 "If non-NIL (the default) keep the working file around after unlocking it.
118 When NIL, the working file and buffer are deleted."
119 :value t)
120
121 (defun rcs-check-in-file (buffer pathname keep-lock)
122 (let ((old-buffer (current-buffer))
123 (allow-delete nil)
124 (log-buffer nil))
125 (unwind-protect
126 (when (block in-recursive-edit
127 (do ((i 0 (1+ i)))
128 ((not (null log-buffer)))
129 (setf log-buffer
130 (make-buffer
131 (format nil "RCS Log Entry ~D for ~S" i
132 (file-namestring pathname))
133 :modes '("Text")
134 :delete-hook
135 (list #'(lambda (buffer)
136 (declare (ignore buffer))
137 (unless allow-delete
138 (return-from in-recursive-edit t)))))))
139 (turn-auto-save-off log-buffer)
140 (change-to-buffer log-buffer)
141 (do-recursive-edit)
142
143 (message "Checking in ~A~:[~; keeping the lock~] ..."
144 (namestring pathname) keep-lock)
145 (let ((log-stream (make-hemlock-region-stream
146 (buffer-region log-buffer))))
147 (sub-check-in-file pathname buffer keep-lock log-stream))
148 (invoke-hook rcs-check-in-file-hook buffer pathname)
149 nil)
150 (editor-error "Someone deleted the RCS Log Entry buffer."))
151 (when (member old-buffer *buffer-list*)
152 (change-to-buffer old-buffer))
153 (setf allow-delete t)
154 (delete-buffer-if-possible log-buffer))))
155
156 (defun sub-check-in-file (pathname buffer keep-lock log-stream)
157 (let* ((filename (file-namestring pathname))
158 (rcs-filename (concatenate 'simple-string
159 "./RCS/" filename ",v"))
160 (keep-working-copy (or keep-lock
161 (not (hemlock-bound-p
162 'rcs-keep-around-after-unlocking
163 :buffer buffer))
164 (variable-value
165 'rcs-keep-around-after-unlocking
166 :buffer buffer))))
167 (in-directory pathname
168 (do-command "ci" `(,@(if keep-lock '("-l"))
169 ,@(if keep-working-copy '("-u"))
170 ,filename)
171 :input log-stream)
172 (if keep-working-copy
173 ;;
174 ;; Set the times on the user's file to be equivalent to that of
175 ;; the rcs file.
176 #-(or hpux svr4)
177 (multiple-value-bind
178 (dev ino mode nlink uid gid rdev size atime mtime)
179 (unix:unix-stat rcs-filename)
180 (declare (ignore mode nlink uid gid rdev size))
181 (cond (dev
182 (multiple-value-bind
183 (wonp errno)
184 (unix:unix-utimes filename atime 0 mtime 0)
185 (unless wonp
186 (editor-error "UNIX:UNIX-UTIMES failed: ~A"
187 (unix:get-unix-error-msg errno)))))
188 (t
189 (editor-error "UNIX:UNIX-STAT failed: ~A"
190 (unix:get-unix-error-msg ino)))))
191 (delete-buffer-if-possible buffer)))))
192
193
194
195 ;;;; Check Out
196
197 (defhvar "RCS Check Out File Hook"
198 "RCS Check Out File Hook"
199 :value nil)
200
201 (defvar *translate-file-names-before-locking* nil)
202
203 (defun maybe-rcs-check-out-file (buffer pathname lock always-overwrite-p)
204 (when (and lock *translate-file-names-before-locking*)
205 (multiple-value-bind (unmatched-dir new-dirs file-name)
206 (maybe-translate-definition-file pathname)
207 (when new-dirs
208 (let ((new-name (translate-definition-file unmatched-dir
209 (car new-dirs)
210 file-name)))
211 (when (probe-file (directory-namestring new-name))
212 (setf pathname new-name))))))
213 (cond
214 ((and (not always-overwrite-p)
215 (let ((pn (probe-file pathname)))
216 (and pn (ext:file-writable pn))))
217 ;; File exists and is writable so check and see if the user really
218 ;; wants to check it out.
219 (command-case (:prompt
220 (format nil "The file ~A is writable. Overwrite? "
221 (file-namestring pathname))
222 :help
223 "Type one of the following single-character commands:")
224 ((:yes :confirm)
225 "Overwrite the file."
226 (rcs-check-out-file buffer pathname lock))
227 (:no
228 "Don't check it out after all.")
229 ((#\r #\R)
230 "Rename the file before checking it out."
231 (let ((new-pathname (prompt-for-file
232 :prompt "New Filename: "
233 :default (buffer-default-pathname
234 (current-buffer))
235 :must-exist nil)))
236 (rename-file pathname new-pathname)
237 (rcs-check-out-file buffer pathname lock)))))
238 (t
239 (rcs-check-out-file buffer pathname lock)))
240 pathname)
241
242 (defun rcs-check-out-file (buffer pathname lock)
243 (message "Checking out ~A~:[~; with a lock~] ..." (namestring pathname) lock)
244 (in-directory pathname
245 (let* ((file (file-namestring pathname))
246 (backup (if (probe-file file)
247 (lisp::pick-backup-name file))))
248 (when backup (rename-file file backup))
249 (do-command "co" `(,@(if lock '("-l")) ,file))
250 (invoke-hook rcs-check-out-file-hook buffer pathname)
251 (when backup (delete-file backup)))))
252
253
254 ;;;; Last Command Output
255
256 (defcommand "RCS Last Command Output" (p)
257 "Print the full output of the last RCS command."
258 "Print the full output of the last RCS command."
259 (declare (ignore p))
260 (unless (and *last-rcs-command-name* *last-rcs-command-output-string*)
261 (editor-error "No RCS commands have executed!"))
262 (with-pop-up-display (s :buffer-name "*RCS Command Output*")
263 (format s "Output from ``~A'':~%~%" *last-rcs-command-name*)
264 (write-line *last-rcs-command-output-string* s)))
265
266
267 ;;;; Commands for Checking In / Checking Out and Locking / Unlocking
268
269 (defun pick-temp-file (defaults)
270 (let ((index 0))
271 (loop
272 (let ((name (merge-pathnames (format nil ",rcstmp-~D" index) defaults)))
273 (cond ((probe-file name)
274 (incf index))
275 (t
276 (return name)))))))
277
278 (defcommand "RCS Lock Buffer File" (p)
279 "Attempt to lock the file in the current buffer."
280 "Attempt to lock the file in the current buffer."
281 (declare (ignore p))
282 (let ((file (current-buffer-pathname))
283 (buffer (current-buffer))
284 (name (pick-temp-file "/tmp/")))
285 (rcs-lock-file buffer file)
286 (unwind-protect
287 (progn
288 (in-directory file
289 (do-command "co" `("-p" ,(file-namestring file))
290 :output (namestring name)))
291 (when (buffer-different-from-file buffer name)
292 (message
293 "RCS file is different; be sure to merge in your changes."))
294 (setf (buffer-writable buffer) t)
295 (message "Buffer is now writable."))
296 (when (probe-file name)
297 (delete-file name)))))
298
299 (defcommand "RCS Lock File" (p)
300 "Prompt for a file, and attempt to lock it."
301 "Prompt for a file, and attempt to lock it."
302 (declare (ignore p))
303 (rcs-lock-file nil (prompt-for-file :prompt "File to lock: "
304 :default (buffer-default-pathname
305 (current-buffer))
306 :must-exist nil)))
307
308 (defcommand "RCS Unlock Buffer File" (p)
309 "Unlock the file in the current buffer."
310 "Unlock the file in the current buffer."
311 (declare (ignore p))
312 (rcs-unlock-file (current-buffer) (current-buffer-pathname))
313 (setf (buffer-writable (current-buffer)) nil)
314 (message "Buffer is no longer writable."))
315
316 (defcommand "RCS Unlock File" (p)
317 "Prompt for a file, and attempt to unlock it."
318 "Prompt for a file, and attempt to unlock it."
319 (declare (ignore p))
320 (rcs-unlock-file nil (prompt-for-file :prompt "File to unlock: "
321 :default (buffer-default-pathname
322 (current-buffer))
323 :must-exist nil)))
324
325 (defcommand "RCS Check In Buffer File" (p)
326 "Checkin the file in the current buffer. With an argument, do not
327 release the lock."
328 "Checkin the file in the current buffer. With an argument, do not
329 release the lock."
330 (let ((buffer (current-buffer))
331 (pathname (current-buffer-pathname)))
332 (when (buffer-modified buffer)
333 (save-file-command nil))
334 (rcs-check-in-file buffer pathname p)
335 (when (member buffer *buffer-list*)
336 ;; If the buffer has not been deleted, make sure it is up to date
337 ;; with respect to the file.
338 (visit-file-command nil pathname buffer))))
339
340 (defcommand "RCS Check In File" (p)
341 "Prompt for a file, and attempt to check it in. With an argument, do
342 not release the lock."
343 "Prompt for a file, and attempt to check it in. With an argument, do
344 not release the lock."
345 (rcs-check-in-file nil (prompt-for-file :prompt "File to lock: "
346 :default
347 (buffer-default-pathname
348 (current-buffer))
349 :must-exist nil)
350 p))
351
352 (defcommand "RCS Check Out Buffer File" (p)
353 "Checkout the file in the current buffer. With an argument, lock the
354 file."
355 "Checkout the file in the current buffer. With an argument, lock the
356 file."
357 (let* ((buffer (current-buffer))
358 (pathname (current-buffer-pathname))
359 (point (current-point))
360 (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
361 (when (buffer-modified buffer)
362 (when (not (prompt-for-y-or-n :prompt "Buffer is modified, overwrite? "))
363 (editor-error "Aborted.")))
364 (setf (buffer-modified buffer) nil)
365 (setf pathname (maybe-rcs-check-out-file buffer pathname p nil))
366 (when p
367 (setf (buffer-writable buffer) t)
368 (message "Buffer is now writable."))
369 (visit-file-command nil pathname)
370 (unless (line-offset point lines)
371 (buffer-end point))))
372
373 (defcommand "RCS Check Out File" (p)
374 "Prompt for a file and attempt to check it out. With an argument,
375 lock the file."
376 "Prompt for a file and attempt to check it out. With an argument,
377 lock the file."
378 (let ((pathname (prompt-for-file :prompt "File to check out: "
379 :default (buffer-default-pathname
380 (current-buffer))
381 :must-exist nil)))
382 (setf pathname (maybe-rcs-check-out-file nil pathname p nil))
383 (find-file-command nil pathname)))
384
385
386 ;;;; Log File
387
388 (defhvar "RCS Log Entry Buffer"
389 "Name of the buffer to put RCS log entries into."
390 :value "RCS Log")
391
392 (defhvar "RCS Log Buffer Hook"
393 "RCS Log Buffer Hook"
394 :value nil)
395
396 (defun get-log-buffer ()
397 (let ((buffer (getstring (value rcs-log-entry-buffer) *buffer-names*)))
398 (unless buffer
399 (setf buffer (make-buffer (value rcs-log-entry-buffer)))
400 (turn-auto-save-off buffer)
401 (invoke-hook rcs-log-buffer-hook buffer))
402 buffer))
403
404 (defcommand "RCS Buffer File Log Entry" (p)
405 "Get the RCS Log for the file in the current buffer in a buffer."
406 "Get the RCS Log for the file in the current buffer in a buffer."
407 (declare (ignore p))
408 (let ((buffer (get-log-buffer))
409 (pathname (current-buffer-pathname)))
410 (delete-region (buffer-region buffer))
411 (message "Extracting log info ...")
412 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
413 (in-directory pathname
414 (do-command "rlog" (list (file-namestring pathname))
415 :output (make-hemlock-output-stream mark))))
416 (change-to-buffer buffer)
417 (buffer-start (current-point))
418 (setf (buffer-modified buffer) nil)))
419
420 (defcommand "RCS File Log Entry" (p)
421 "Prompt for a file and get its RCS log entry in a buffer."
422 "Prompt for a file and get its RCS log entry in a buffer."
423 (declare (ignore p))
424 (let ((file (prompt-for-file :prompt "File to get log of: "
425 :default (buffer-default-pathname
426 (current-buffer))
427 :must-exist nil))
428 (buffer (get-log-buffer)))
429 (delete-region (buffer-region buffer))
430 (message "Extracing log info ...")
431 (with-mark ((mark (buffer-start-mark buffer) :left-inserting))
432 (in-directory file
433 (do-command "rlog" (list (file-namestring file))
434 :output (make-hemlock-output-stream mark))))
435 (change-to-buffer buffer)
436 (buffer-start (current-point))
437 (setf (buffer-modified buffer) nil)))
438
439
440 ;;;; Status and Modeline Frobs.
441
442 (defhvar "RCS Status"
443 "RCS status of this buffer. Either nil, :locked, :out-of-date, or
444 :unlocked."
445 :value nil)
446
447 ;;;
448 ;;; Note: This doesn't behave correctly w/r/t to branched files.
449 ;;;
450 (defun rcs-file-status (pathname)
451 (let* ((directory (directory-namestring pathname))
452 (filename (file-namestring pathname))
453 (rcs-file (concatenate 'simple-string directory
454 "RCS/" filename ",v")))
455 (if (probe-file rcs-file)
456 ;; This is an RCS file
457 (let ((probe-file (probe-file pathname)))
458 (cond ((and probe-file (file-writable probe-file))
459 :locked)
460 ((or (not probe-file)
461 (< (file-write-date pathname)
462 (file-write-date rcs-file)))
463 :out-of-date)
464 (t
465 :unlocked))))))
466
467 (defun rcs-update-buffer-status (buffer &optional tn)
468 (unless (hemlock-bound-p 'rcs-status :buffer buffer)
469 (defhvar "RCS Status"
470 "RCS Status of this buffer."
471 :buffer buffer
472 :value nil))
473 (let ((tn (or tn (buffer-pathname buffer))))
474 (setf (variable-value 'rcs-status :buffer buffer)
475 (if tn (rcs-file-status tn))))
476 (hi::update-modelines-for-buffer buffer))
477 ;;;
478 (add-hook read-file-hook 'rcs-update-buffer-status)
479 (add-hook write-file-hook 'rcs-update-buffer-status)
480
481 (defcommand "RCS Update All RCS Status Variables" (p)
482 "Update the ``RCS Status'' variable for all buffers."
483 "Update the ``RCS Status'' variable for all buffers."
484 (declare (ignore p))
485 (dolist (buffer *buffer-list*)
486 (rcs-update-buffer-status buffer))
487 (dolist (window *window-list*)
488 (update-modeline-fields (window-buffer window) window)))
489
490 ;;;
491 ;;; Action Hooks
492 (defun rcs-action-hook (buffer pathname)
493 (cond (buffer
494 (rcs-update-buffer-status buffer))
495 (t
496 (let ((pathname (probe-file pathname)))
497 (when pathname
498 (dolist (buffer *buffer-list*)
499 (let ((buffer-pathname (buffer-pathname buffer)))
500 (when (equal pathname buffer-pathname)
501 (rcs-update-buffer-status buffer)))))))))
502 ;;;
503 (add-hook rcs-check-in-file-hook 'rcs-action-hook)
504 (add-hook rcs-check-out-file-hook 'rcs-action-hook)
505 (add-hook rcs-lock-file-hook 'rcs-action-hook)
506 (add-hook rcs-unlock-file-hook 'rcs-action-hook)
507
508
509 ;;;
510 ;;; RCS Modeline Field
511 (make-modeline-field
512 :name :rcs-status
513 :function #'(lambda (buffer window)
514 (declare (ignore buffer window))
515 (ecase (value rcs-status)
516 (:out-of-date "[OLD] ")
517 (:locked "[LOCKED] ")
518 (:unlocked "[RCS] ")
519 ((nil) ""))))

  ViewVC Help
Powered by ViewVC 1.1.5