/[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 - (hide 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 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     ;;;
7     (ext:file-comment
8 ram 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/hemlock/auto-save.lisp,v 1.5 1994/10/31 04:50:12 ram Rel $")
9 ram 1.2 ;;;
10 ram 1.1 ;;; **********************************************************************
11     ;;;
12     ;;; Auto-Save Mode
13     ;;; Written by Christopher Hoover
14     ;;;
15    
16 ram 1.4 (in-package "HEMLOCK")
17 ram 1.1
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 wlott 1.3 (key-signature 0 :type fixnum) ; buffer-signature at last keystroke
35 ram 1.1 (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