/[cmucl]/src/hemlock/auto-save.lisp
ViewVC logotype

Contents of /src/hemlock/auto-save.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Mon Oct 31 04:50:12 1994 UTC (19 years, 5 months 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.4: +1 -3 lines
Fix headed boilerplate.
1 ;;; -*- Package: Hemlock; Log: hemlock.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/auto-save.lisp,v 1.5 1994/10/31 04:50:12 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Auto-Save Mode
13 ;;; Written by Christopher Hoover
14 ;;;
15
16 (in-package "HEMLOCK")
17
18
19 ;;;; Per Buffer State Information
20
21 ;;;
22 ;;; The auto-save-state structure is used to store the state information for
23 ;;; a particular buffer in "Save" mode, namely the buffer-signature at the last
24 ;;; key stroke, the buffer-signature at the time of the last checkpoint, a count
25 ;;; of the number of destructive keystrokes which have occured since the time of
26 ;;; the last checkpoint, and the pathname used to write the last checkpoint. It
27 ;;; is generally kept in a buffer-local hvar called "Auto Save State".
28 ;;;
29 (defstruct (auto-save-state
30 (:conc-name save-state-)
31 (:print-function print-auto-save-state))
32 "Per buffer state for auto-save"
33 (buffer nil) ; buffer this state is for; for printing
34 (key-signature 0 :type fixnum) ; buffer-signature at last keystroke
35 (last-ckp-signature 0 :type fixnum) ; buffer-signature at last checkpoint
36 (key-count 0 :type fixnum) ; # destructive keystrokes since ckp
37 (pathname nil)) ; pathname used to write last ckp file
38
39 (defun print-auto-save-state (auto-save-state stream depth)
40 (declare (ignore depth))
41 (format stream "#<Auto Save Buffer State for buffer ~A>"
42 (buffer-name (save-state-buffer auto-save-state))))
43
44
45 ;;; GET-AUTO-SAVE-STATE tries to get the auto-save-state for the buffer. If
46 ;;; the buffer is not in "Save" mode then this function returns NIL.
47 ;;;
48 (defun get-auto-save-state (buffer)
49 (if (hemlock-bound-p 'auto-save-state :buffer buffer)
50 (variable-value 'auto-save-state :buffer buffer)))
51
52 ;;; RESET-AUTO-SAVE-STATE resets the auto-save-state of the buffer making it
53 ;;; look as if the buffer was just checkpointed. This is in fact how
54 ;;; checkpoint-buffer updates the state. If the buffer is not in "Save" mode
55 ;;; this function punts the attempt and does nothing.
56 ;;;
57 (defun reset-auto-save-state (buffer)
58 (let ((state (get-auto-save-state buffer)))
59 (when state
60 (let ((signature (buffer-signature buffer)))
61 (setf (save-state-key-signature state)
62 signature)
63 (setf (save-state-last-ckp-signature state)
64 signature)
65 (setf (save-state-key-count state)
66 0)))))
67
68
69
70 ;;;; Checkpoint Pathname Interface/Internal Routines
71
72 ;;; GET-CHECKPOINT-PATHNAME -- Interface
73 ;;;
74 ;;; Returns the pathname of the checkpoint file for the specified
75 ;;; buffer; Returns NIL if no checkpoints have been written thus
76 ;;; far or if the buffer isn't in "Save" mode.
77 ;;;
78 (defun get-checkpoint-pathname (buffer)
79 "Returns the pathname of the checkpoint file for the specified buffer.
80 If no checkpoints have been written thus far, or if the buffer is not in
81 \"Save\" mode, return nil."
82 (let ((state (get-auto-save-state buffer)))
83 (if state
84 (save-state-pathname state))))
85
86 ;;; MAKE-UNIQUE-SAVE-PATHNAME is used as the default value for "Auto Save
87 ;;; Pathname Hook" and is mentioned in the User's manual, so it gets a doc
88 ;;; doc string.
89 ;;;
90 (defun make-unique-save-pathname (buffer)
91 "Returns a pathname for a non-existing file in DEFAULT-DIRECTORY. Uses
92 GENSYM to for a file name: save-GENSYM.CKP."
93 (declare (ignore buffer))
94 (let ((def-dir (default-directory)))
95 (loop
96 (let* ((sym (gensym))
97 (f (merge-pathnames (format nil "save-~A.CKP" sym) def-dir)))
98 (unless (probe-file f)
99 (return f))))))
100
101 (defhvar "Auto Save Pathname Hook"
102 "This hook is called by Auto Save to get a checkpoint pathname when there
103 is no pathname associated with a buffer. If this value is NIL, then
104 \"Save\" mode is turned off in the buffer. Otherwise, the function
105 will be called. It should take a buffer as its argument and return either
106 NIL or a pathname. If NIL is returned, then \"Save\" mode is turned off
107 in the buffer; else the pathname returned is used as the checkpoint
108 pathname for the buffer."
109 :value #'make-unique-save-pathname)
110
111
112 ;;; MAKE-BUFFER-CKP-PATHNAME attempts to form a pathname by using the buffer's
113 ;;; associated pathname (from buffer-pathname). If there isn't a pathname
114 ;;; associated with the buffer, the function returns nil. Otherwise, it uses
115 ;;; the "Auto Save Filename Pattern" and FORMAT to make the checkpoint
116 ;;; pathname.
117 ;;;
118 (defun make-buffer-ckp-pathname (buffer)
119 (let ((buffer-pn (buffer-pathname buffer)))
120 (if buffer-pn
121 (pathname (format nil
122 (value auto-save-filename-pattern)
123 (directory-namestring buffer-pn)
124 (file-namestring buffer-pn))))))
125
126
127
128 ;;;; Buffer-level Checkpoint Routines
129
130 ;;;
131 ;;; write-checkpoint-file -- Internal
132 ;;;
133 ;;; Does the low-level write of the checkpoint. Returns T if it succeeds
134 ;;; and NIL if it fails. Echoes winnage or lossage to the luser.
135 ;;;
136 (defun write-checkpoint-file (pathname buffer)
137 (let ((ns (namestring pathname)))
138 (cond ((file-writable pathname)
139 (message "Saving ~A" ns)
140 (handler-case (progn
141 (write-file (buffer-region buffer) pathname
142 :keep-backup nil
143 :access #o600) ;read/write by owner.
144 t)
145 (error (condition)
146 (loud-message "Auto Save failure: ~A" condition)
147 nil)))
148 (t
149 (message "Can't write ~A" ns)
150 nil))))
151
152
153 ;;;
154 ;;; To save, or not to save... and to save as what?
155 ;;;
156 ;;; First, make-buffer-ckp-pathname is called. It will return either NIL or
157 ;;; a pathname formed by using buffer-pathname in conjunction with the hvar
158 ;;; "Auto Save Filename Pattern". If there isn't an associated pathname or
159 ;;; make-buffer-ckp-pathname returns NIL, then we use the pathname we used
160 ;;; the last time we checkpointed the buffer. If we've never checkpointed
161 ;;; the buffer, then we check "Auto Save Pathname Hook". If it is NIL then
162 ;;; we turn Save mode off for the buffer, else we funcall the function on
163 ;;; the hook with the buffer as an argument. The function on the hook should
164 ;;; return either NIL or a pathname. If it returns NIL, we toggle Save mode
165 ;;; off for the buffer; otherwise, we use the pathname it returned.
166 ;;;
167
168 ;;;
169 ;;; checkpoint-buffer -- Internal
170 ;;;
171 ;;; This functions takes a buffer as its argument and attempts to write a
172 ;;; checkpoint for that buffer. See the notes at the beginning of this page
173 ;;; for how it determines what pathname to use as the checkpoint pathname.
174 ;;; Note that a checkpoint is not necessarily written -- instead "Save"
175 ;;; mode may be turned off for the buffer.
176 ;;;
177 (defun checkpoint-buffer (buffer)
178 (let* ((state (get-auto-save-state buffer))
179 (buffer-ckp-pn (make-buffer-ckp-pathname buffer))
180 (last-pathname (save-state-pathname state)))
181 (cond (buffer-ckp-pn
182 (when (write-checkpoint-file buffer-ckp-pn buffer)
183 (reset-auto-save-state buffer)
184 (setf (save-state-pathname state) buffer-ckp-pn)
185 (when (and last-pathname
186 (not (equal last-pathname buffer-ckp-pn))
187 (probe-file last-pathname))
188 (delete-file last-pathname))))
189 (last-pathname
190 (when (write-checkpoint-file last-pathname buffer)
191 (reset-auto-save-state buffer)))
192 (t
193 (let* ((save-pn-hook (value auto-save-pathname-hook))
194 (new-pn (if save-pn-hook
195 (funcall save-pn-hook buffer))))
196 (cond ((or (not new-pn)
197 (zerop (length
198 (the simple-string (namestring new-pn)))))
199 (setf (buffer-minor-mode buffer "Save") nil))
200 (t
201 (when (write-checkpoint-file new-pn buffer)
202 (reset-auto-save-state buffer)
203 (setf (save-state-pathname state) new-pn)))))))))
204
205 ;;;
206 ;;; checkpoint-all-buffers -- Internal
207 ;;;
208 ;;; This function looks through the buffer list and checkpoints
209 ;;; each buffer that is in "Save" mode that has been modified since
210 ;;; its last checkpoint.
211 ;;;
212 (defun checkpoint-all-buffers (elapsed-time)
213 (declare (ignore elapsed-time))
214 (dolist (buffer *buffer-list*)
215 (let ((state (get-auto-save-state buffer)))
216 (when (and state
217 (buffer-modified buffer)
218 (not (eql
219 (save-state-last-ckp-signature state)
220 (buffer-signature buffer))))
221 (checkpoint-buffer buffer)))))
222
223
224 ;;;; Random Hooks: cleanup, buffer-modified, change-save-freq.
225
226 ;;;
227 ;;; cleanup-checkpoint -- Internal
228 ;;;
229 ;;; Cleans up checkpoint file for a given buffer if Auto Save Cleanup
230 ;;; Checkpoints is non-NIL. This is called via "Write File Hook"
231 ;;;
232 (defun cleanup-checkpoint (buffer)
233 (let ((ckp-pathname (get-checkpoint-pathname buffer)))
234 (when (and (value auto-save-cleanup-checkpoints)
235 ckp-pathname
236 (probe-file ckp-pathname))
237 (delete-file ckp-pathname))))
238
239 (add-hook write-file-hook 'cleanup-checkpoint)
240
241 ;;;
242 ;;; notice-buffer-modified -- Internal
243 ;;;
244 ;;; This function is called on "Buffer Modified Hook" to reset
245 ;;; the Auto Save state. It makes the buffer look like it has just
246 ;;; been checkpointed.
247 ;;;
248 (defun notice-buffer-modified (buffer flag)
249 ;; we care only when the flag has gone to false
250 (when (not flag)
251 (reset-auto-save-state buffer)))
252
253 (add-hook buffer-modified-hook 'notice-buffer-modified)
254
255 ;;;
256 ;;; change-save-frequency -- Internal
257 ;;;
258 ;;; This keeps us scheduled at the proper interval. It is stuck on
259 ;;; the hook list for the hvar "Auto Save Checkpoint Frequency" and
260 ;;; is therefore called whenever this value is set.
261 ;;;
262 (defun change-save-frequency (name kind where new-value)
263 (declare (ignore name kind where))
264 (setq new-value (truncate new-value))
265 (remove-scheduled-event 'checkpoint-all-buffers)
266 (when (and new-value
267 (plusp new-value))
268 (schedule-event new-value 'checkpoint-all-buffers t)))
269
270
271 ;;; "Save" mode is in "Default Modes", so turn it off in these modes.
272 ;;;
273
274 (defun interactive-modes (buffer on)
275 (when on (setf (buffer-minor-mode buffer "Save") nil)))
276
277 (add-hook typescript-mode-hook 'interactive-modes)
278 (add-hook eval-mode-hook 'interactive-modes)
279
280
281
282 ;;;; Key Count Routine for Input Hook
283
284 ;;;
285 ;;; auto-save-count-keys -- Internal
286 ;;;
287 ;;; This function sits on the Input Hook to eat cycles. If the current
288 ;;; buffer is not in Save mode or if the current buffer is the echo area
289 ;;; buffer, it does nothing. Otherwise, we check to see if we have exceeded
290 ;;; the key count threshold (and write a checkpoint if we have) and we
291 ;;; increment the key count for the buffer.
292 ;;;
293 (defun auto-save-count-keys ()
294 (declare (optimize speed))
295 (let ((buffer (current-buffer)))
296 (unless (eq buffer *echo-area-buffer*)
297 (let ((state (value auto-save-state))
298 (threshold (value auto-save-key-count-threshold)))
299 (when (and state threshold)
300 (let ((signature (buffer-signature buffer)))
301 (declare (fixnum signature))
302 (when (not (eql signature
303 (save-state-key-signature state)))
304 ;; see if we exceeded threshold last time...
305 (when (>= (save-state-key-count state)
306 (the fixnum threshold))
307 (checkpoint-buffer buffer))
308 ;; update state
309 (setf (save-state-key-signature state) signature)
310 (incf (save-state-key-count state)))))))))
311
312 (add-hook input-hook 'auto-save-count-keys)
313
314
315 ;;;; Save Mode Hemlock Variables
316
317 ;;;
318 ;;; Hemlock variables/parameters for Auto-Save Mode
319 ;;;
320
321 (defhvar "Auto Save Filename Pattern"
322 "This control-string is used with format to make the filename of the
323 checkpoint file. Format is called with two arguments, the first
324 being the directory namestring and the second being the file
325 namestring of the default buffer pathname."
326 :value "~A~A.CKP")
327
328 (defhvar "Auto Save Key Count Threshold"
329 "This value is the number of destructive/modifying keystrokes that will
330 automatically trigger an checkpoint. This value may be NIL to turn this
331 feature off."
332 :value 256)
333
334 (defhvar "Auto Save Cleanup Checkpoints"
335 "This variable controls whether or not \"Save\" mode will delete the
336 checkpoint file for a buffer after it is saved. If this value is
337 non-NIL then cleanup will occur."
338 :value t)
339
340 (defhvar "Auto Save Checkpoint Frequency"
341 "All modified buffers (in \"Save\" mode) will be checkpointed after this
342 amount of time (in seconds). This value may be NIL (or non-positive)
343 to turn this feature off."
344 :value (* 2 60)
345 :hooks '(change-save-frequency))
346
347 (defhvar "Auto Save State"
348 "Shadow magic. This variable is seen when in buffers that are not
349 in \"Save\" mode. Do not change this value or you will lose."
350 :value nil)
351
352
353 ;;;; "Save" mode
354
355 (defcommand "Auto Save Mode" (p)
356 "If the argument is zero or negative, turn \"Save\" mode off. If it
357 is positive turn \"Save\" mode on. If there is no argument, toggle
358 \"Save\" mode in the current buffer. When in \"Save\" mode, files
359 are automatically checkpointed every \"Auto Save Checkpoint Frequency\"
360 seconds or every \"Auto Save Key Count Threshold\" destructive
361 keystrokes. If there is a pathname associated with the buffer, the
362 filename used for the checkpoint file is controlled by the hvar \"Auto
363 Save Filename Pattern\". Otherwise, the hook \"Auto Save Pathname Hook\"
364 is used to generate a checkpoint pathname. If the buffer's pathname
365 changes between checkpoints, the checkpoint file will be written under
366 the new name and the old checkpoint file will be deleted if it exists.
367 When a buffer is written out, the checkpoint will be deleted if the
368 hvar \"Auto Save Cleanup Checkpoints\" is non-NIL."
369 "Turn on, turn off, or toggle \"Save\" mode in the current buffer."
370 (setf (buffer-minor-mode (current-buffer) "Save")
371 (if p
372 (plusp p)
373 (not (buffer-minor-mode (current-buffer) "Save")))))
374
375 (defun setup-auto-save-mode (buffer)
376 (let* ((signature (buffer-signature buffer))
377 (state (make-auto-save-state
378 :buffer buffer
379 :key-signature (the fixnum signature)
380 :last-ckp-signature (the fixnum signature))))
381 ;; shadow the global value with a variable which will
382 ;; contain our per buffer state information
383 (defhvar "Auto Save State"
384 "This is the \"Save\" mode state information for this buffer."
385 :buffer buffer
386 :value state)))
387
388 (defun cleanup-auto-save-mode (buffer)
389 (delete-variable 'auto-save-state
390 :buffer buffer))
391
392 (defmode "Save"
393 :setup-function 'setup-auto-save-mode
394 :cleanup-function 'cleanup-auto-save-mode)

  ViewVC Help
Powered by ViewVC 1.1.5