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

  ViewVC Help
Powered by ViewVC 1.1.5