|
70
|
1 ;;; Interval timers for XEmacs
|
|
|
2 ;;; Copyright (C) 1988, 1991, 1993 Kyle E. Jones
|
|
|
3 ;;; Modified 5 Feb 91 by Jamie Zawinski <jwz@lucid.com> for Lucid Emacs
|
|
|
4 ;;; And again, 15 Dec 93.
|
|
30
|
5 ;;;
|
|
70
|
6 ;; This file is part of XEmacs.
|
|
|
7
|
|
|
8 ;; XEmacs is free software; you can redistribute it and/or modify it
|
|
|
9 ;; under the terms of the GNU General Public License as published by
|
|
|
10 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
|
11 ;; any later version.
|
|
|
12
|
|
|
13 ;; XEmacs is distributed in the hope that it will be useful, but
|
|
|
14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
|
16 ;; General Public License for more details.
|
|
26
|
17
|
|
70
|
18 ;; You should have received a copy of the GNU General Public License
|
|
|
19 ;; along with XEmacs; see the file COPYING. If not, write to the
|
|
|
20 ;; Free Software Foundation, 59 Temple Place - Suite 330,
|
|
|
21 ;; Boston, MA 02111-1307, USA.
|
|
|
22
|
|
|
23 ;;; Synched up with: Not in FSF.
|
|
|
24
|
|
|
25 ;;;
|
|
|
26 ;;; Send bug reports to kyle@uunet.uu.net.
|
|
0
|
27
|
|
70
|
28 ;; The original v18 version of this file worked by having an external program
|
|
|
29 ;; wake up once a second to generate an interrupt for emacs; then an emacs
|
|
|
30 ;; process filter was used to schedule timers.
|
|
|
31 ;;
|
|
|
32 ;; This version works by associating with each timer a "timeout" object,
|
|
|
33 ;; since the XEmacs/Lucid Emacs event loop has the concept of timers built
|
|
|
34 ;; in to it. There is no single scheduler function; instead, each timer
|
|
|
35 ;; re-sets itself as it is invoked.
|
|
|
36
|
|
|
37 ;; `itimer' feature means Emacs-Lisp programers get:
|
|
|
38 ;; itimerp, itimer-value, itimer-restart, itimer-function,
|
|
|
39 ;; set-itimer-value, set-itimer-restart, set-itimer-function
|
|
|
40 ;; get-itimer, start-itimer, read-itimer, delete-itimer
|
|
0
|
41 ;;
|
|
|
42 ;; Interactive users get these commands:
|
|
70
|
43 ;; edit-itimers, list-itimers, start-itimer
|
|
0
|
44 ;;
|
|
|
45 ;; See the doc strings of these functions for more information.
|
|
|
46
|
|
70
|
47 (defvar itimer-version "1.00"
|
|
0
|
48 "Version number of the itimer package.")
|
|
|
49
|
|
|
50 (defvar itimer-list nil
|
|
|
51 "List of all active itimers.")
|
|
|
52
|
|
70
|
53 ;; not needed in XEmacs
|
|
|
54 ;(defvar itimer-process nil
|
|
|
55 ; "Process that drives all itimers.")
|
|
0
|
56
|
|
70
|
57 ;; This value is maintained internally; it does not determine itimer
|
|
|
58 ;; granularity. Itimer granularity is 1 second, plus delays due to
|
|
|
59 ;; system and Emacs internal activity that delay dealing with process
|
|
|
60 ;; output.
|
|
|
61 ;; not needed in XEmacs
|
|
|
62 ;(defvar itimer-process-next-wakeup 1
|
|
|
63 ; "Itimer process will wakeup to service running itimers within this
|
|
|
64 ;many seconds.")
|
|
0
|
65
|
|
|
66 (defvar itimer-edit-map nil
|
|
|
67 "Keymap used when in Itimer Edit mode.")
|
|
|
68
|
|
|
69 (if itimer-edit-map
|
|
|
70 ()
|
|
|
71 (setq itimer-edit-map (make-sparse-keymap))
|
|
|
72 (define-key itimer-edit-map "s" 'itimer-edit-set-field)
|
|
|
73 (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer)
|
|
|
74 (define-key itimer-edit-map "q" 'itimer-edit-quit)
|
|
|
75 (define-key itimer-edit-map "\t" 'itimer-edit-next-field)
|
|
|
76 (define-key itimer-edit-map " " 'next-line)
|
|
|
77 (define-key itimer-edit-map "n" 'next-line)
|
|
|
78 (define-key itimer-edit-map "p" 'previous-line)
|
|
|
79 (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field)
|
|
|
80 (define-key itimer-edit-map "x" 'start-itimer)
|
|
|
81 (define-key itimer-edit-map "?" 'itimer-edit-help))
|
|
|
82
|
|
|
83 (defvar itimer-edit-start-marker nil)
|
|
|
84
|
|
|
85 ;; macros must come first... or byte-compile'd code will throw back its
|
|
|
86 ;; head and scream.
|
|
|
87
|
|
70
|
88 (defmacro itimer-decf (variable)
|
|
0
|
89 (list 'setq variable (list '1- variable)))
|
|
|
90
|
|
70
|
91 (defmacro itimer-incf (variable)
|
|
0
|
92 (list 'setq variable (list '1+ variable)))
|
|
|
93
|
|
|
94 (defmacro itimer-signum (n)
|
|
|
95 (list 'if (list '> n 0) 1
|
|
|
96 (list 'if (list 'zerop n) 0 -1)))
|
|
|
97
|
|
|
98 ;; Itimer access functions should behave as if they were subrs. These
|
|
|
99 ;; macros are used to check the arguments to the itimer functions and
|
|
|
100 ;; signal errors appropriately if the arguments are not valid.
|
|
|
101
|
|
|
102 (defmacro check-itimer (var)
|
|
|
103 "If VAR is not bound to an itimer, signal wrong-type-argument.
|
|
|
104 This is a macro."
|
|
|
105 (list 'setq var
|
|
|
106 (list 'if (list 'itimerp var) var
|
|
|
107 (list 'signal ''wrong-type-argument
|
|
|
108 (list 'list ''itimerp var)))))
|
|
|
109
|
|
|
110 (defmacro check-itimer-coerce-string (var)
|
|
|
111 "If VAR is not bound to a string, look up the itimer that it names and
|
|
|
112 bind VAR to it. Otherwise if VAR is not bound to an itimer, signal
|
|
|
113 wrong-type-argument. This is a macro."
|
|
|
114 (list 'setq var
|
|
|
115 (list 'cond
|
|
|
116 (list (list 'itimerp var) var)
|
|
|
117 (list (list 'stringp var) (list 'get-itimer var))
|
|
|
118 (list t (list 'signal ''wrong-type-argument
|
|
|
119 (list 'list ''string-or-itimer-p var))))))
|
|
|
120
|
|
70
|
121 (defmacro itimer-check-natnum (var)
|
|
|
122 "If VAR is not bound to a non-negative number, signal wrong-type-argument.
|
|
0
|
123 This is a macro."
|
|
|
124 (list 'setq var
|
|
70
|
125 (list 'if (list 'natnump var) var
|
|
0
|
126 (list 'signal ''wrong-type-argument
|
|
70
|
127 (list 'list ''natnump var)))))
|
|
0
|
128
|
|
70
|
129 (defmacro itimer-check-string (var)
|
|
0
|
130 "If VAR is not bound to a string, signal wrong-type-argument.
|
|
|
131 This is a macro."
|
|
|
132 (list 'setq var
|
|
|
133 (list 'if (list 'stringp var) var
|
|
|
134 (list 'signal ''wrong-type-argument
|
|
|
135 (list 'list ''stringp var)))))
|
|
|
136
|
|
|
137 ;; Functions to access and modify itimer attributes.
|
|
|
138
|
|
|
139 (defun itimerp (obj)
|
|
|
140 "Returns non-nil iff OBJ is an itimer."
|
|
70
|
141 (and (consp obj) (stringp (car obj)) (eq (length obj)
|
|
|
142 5 ; for XEmacs
|
|
|
143 ;4 ; original version
|
|
|
144 )))
|
|
36
|
145
|
|
0
|
146 (defun itimer-name (itimer)
|
|
|
147 "Returns the name of ITIMER."
|
|
|
148 (check-itimer itimer)
|
|
|
149 (car itimer))
|
|
|
150
|
|
|
151 (defun itimer-value (itimer)
|
|
|
152 "Returns the number of seconds until ITIMER expires."
|
|
|
153 (check-itimer itimer)
|
|
|
154 (nth 1 itimer))
|
|
|
155
|
|
|
156 (defun itimer-restart (itimer)
|
|
|
157 "Returns the value to which ITIMER will be set at restart.
|
|
|
158 nil is returned if this itimer doesn't restart."
|
|
|
159 (check-itimer itimer)
|
|
|
160 (nth 2 itimer))
|
|
|
161
|
|
|
162 (defun itimer-function (itimer)
|
|
|
163 "Returns the function of ITIMER.
|
|
|
164 This function is called each time ITIMER expires."
|
|
|
165 (check-itimer itimer)
|
|
|
166 (nth 3 itimer))
|
|
|
167
|
|
70
|
168 ;; XEmacs-specific
|
|
|
169 (defun itimer-id (itimer)
|
|
|
170 "Returns the timeout-id of ITIMER."
|
|
0
|
171 (check-itimer itimer)
|
|
|
172 (nth 4 itimer))
|
|
|
173
|
|
70
|
174 (defun set-itimer-value (itimer value
|
|
|
175 ;; XEmacs doesn't need this
|
|
|
176 ;; &optional nowakeup
|
|
|
177 )
|
|
0
|
178 "Set the timeout value of ITIMER to be VALUE.
|
|
|
179 Itimer will expire is this many seconds.
|
|
|
180 Returns VALUE."
|
|
70
|
181 ;; Optional third arg NOWAKEUP non-nil means do not wakeup the itimer
|
|
|
182 ;; process to recompute a correct wakeup time, even if it means this
|
|
|
183 ;; itimer will expire late. itimer-process-filter uses this option.
|
|
|
184 ;; This is not meant for ordinary usage, which is why it is not
|
|
|
185 ;; mentioned in the doc string.
|
|
0
|
186 (check-itimer itimer)
|
|
70
|
187 (itimer-check-natnum value)
|
|
0
|
188 (let ((inhibit-quit t))
|
|
70
|
189
|
|
|
190 ; ;; If we're allowed to wakeup the itimer process,
|
|
|
191 ; ;; and the itimer process's next wakeup needs to be recomputed,
|
|
|
192 ; ;; and the itimer is running, then we wakeup the itimer process.
|
|
|
193 ; (or (and (not nowakeup) (< value itimer-process-next-wakeup)
|
|
|
194 ; (get-itimer (itimer-name itimer))
|
|
|
195 ; (progn (itimer-process-wakeup)
|
|
|
196 ; (setcar (cdr itimer) value)
|
|
|
197 ; (itimer-process-wakeup)))
|
|
|
198 ; (setcar (cdr itimer) value))
|
|
|
199
|
|
|
200 ;; the XEmacs way:
|
|
|
201 (if (itimer-id itimer)
|
|
|
202 (deactivate-itimer itimer))
|
|
|
203 (setcar (cdr itimer) value)
|
|
|
204 (activate-itimer itimer)
|
|
|
205
|
|
26
|
206 value))
|
|
0
|
207
|
|
|
208 (defun set-itimer-restart (itimer restart)
|
|
|
209 "Set the restart value of ITIMER to be RESTART.
|
|
|
210 If RESTART is nil, ITIMER will not restart when it expires.
|
|
|
211 Returns RESTART."
|
|
|
212 (check-itimer itimer)
|
|
70
|
213 (if restart (itimer-check-natnum restart))
|
|
|
214 (and restart (< restart 1) (signal 'args-out-of-range (list restart)))
|
|
|
215 ;; (setcar (cdr (cdr itimer)) restart)
|
|
|
216 ;; the XEmacs way
|
|
|
217 (let ((was-active (itimer-id itimer))
|
|
|
218 (inhibit-quit t))
|
|
|
219 (if was-active
|
|
|
220 (deactivate-itimer itimer))
|
|
|
221 (setcar (cdr (cdr itimer)) restart)
|
|
|
222 (if was-active
|
|
|
223 (progn
|
|
|
224 (setcar (cdr itimer) restart)
|
|
|
225 (if restart
|
|
|
226 (activate-itimer itimer)))))
|
|
|
227 restart)
|
|
0
|
228
|
|
|
229 (defun set-itimer-function (itimer function)
|
|
|
230 "Set the function of ITIMER to be FUNCTION.
|
|
|
231 FUNCTION will be called when itimer expires.
|
|
|
232 Returns FUNCTION."
|
|
|
233 (check-itimer itimer)
|
|
70
|
234 (setcar (cdr (cdr (cdr itimer))) function))
|
|
30
|
235
|
|
70
|
236 ;; XEmacs-specific
|
|
|
237 (defun set-itimer-id (itimer id)
|
|
0
|
238 (check-itimer itimer)
|
|
70
|
239 (setcar (cdr (cdr (cdr (cdr itimer)))) id))
|
|
0
|
240
|
|
|
241 (defun get-itimer (name)
|
|
|
242 "Return itimer named NAME, or nil if there is none."
|
|
70
|
243 (itimer-check-string name)
|
|
0
|
244 (assoc name itimer-list))
|
|
|
245
|
|
|
246 (defun read-itimer (prompt &optional initial-input)
|
|
|
247 "Read the name of an itimer from the minibuffer and return the itimer
|
|
|
248 associated with that name. The user is prompted with PROMPT.
|
|
|
249 Optional second arg INITIAL-INPUT non-nil is inserted into the
|
|
|
250 minibuffer as initial user input."
|
|
|
251 (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input)))
|
|
|
252
|
|
|
253 (defun delete-itimer (itimer)
|
|
|
254 "Deletes ITIMER. ITIMER may be an itimer or the name of one."
|
|
|
255 (check-itimer-coerce-string itimer)
|
|
70
|
256 (deactivate-itimer itimer) ;; for XEmacs
|
|
0
|
257 (setq itimer-list (delq itimer itimer-list)))
|
|
|
258
|
|
70
|
259 ;jwz: this is preloaded so don't ;;;###autoload
|
|
|
260 (defun start-itimer (name function value &optional restart)
|
|
0
|
261 "Start an itimer.
|
|
70
|
262 Args are NAME, FUNCTION, VALUE &optional RESTART.
|
|
0
|
263 NAME is an identifier for the itimer. It must be a string. If an itimer
|
|
|
264 already exists with this name, NAME will be modified slightly to until
|
|
|
265 it is unique.
|
|
70
|
266 FUNCTION should be a function (or symbol naming one) of no arguments. It
|
|
|
267 will be called each time the itimer expires. The function can access
|
|
|
268 itimer that invoked it through the variable `current-itimer'.
|
|
0
|
269 VALUE is the number of seconds until this itimer expires.
|
|
|
270 Optional fourth arg RESTART non-nil means that this itimer should be
|
|
|
271 restarted automatically after its function is called. Normally an itimer
|
|
|
272 is deleted at expiration after its function has returned.
|
|
|
273 If non-nil RESTART should be a number indicating the value at which the
|
|
|
274 itimer should be set at restart time.
|
|
|
275 Returns the newly created itimer."
|
|
|
276 (interactive
|
|
|
277 (list (completing-read "Start itimer: " itimer-list)
|
|
|
278 (read (completing-read "Itimer function: " obarray 'fboundp))
|
|
|
279 (let (value)
|
|
70
|
280 (while (not (natnump value))
|
|
0
|
281 (setq value (read-from-minibuffer "Itimer value: " nil nil t)))
|
|
|
282 value)
|
|
|
283 (let ((restart t))
|
|
70
|
284 (while (and restart (not (natnump restart)))
|
|
|
285 (setq restart (read-from-minibuffer "Itimer restart: " nil nil t)))
|
|
|
286 restart)))
|
|
|
287 (itimer-check-string name)
|
|
|
288 (itimer-check-natnum value)
|
|
|
289 (if restart (itimer-check-natnum restart))
|
|
0
|
290 ;; Make proposed itimer name unique if it's not already.
|
|
|
291 (let ((oname name)
|
|
|
292 (num 2))
|
|
|
293 (while (get-itimer name)
|
|
|
294 (setq name (concat oname "<" num ">"))
|
|
70
|
295 (itimer-incf num)))
|
|
|
296 ; ;; If there's no itimer process, start one now.
|
|
|
297 ; ;; Otherwise wake up the itimer process so that seconds slept before
|
|
|
298 ; ;; the new itimer is created won't be counted against it.
|
|
|
299 ; (if itimer-process
|
|
|
300 ; (itimer-process-wakeup)
|
|
|
301 ; (itimer-process-start))
|
|
0
|
302 (let ((inhibit-quit t))
|
|
|
303 ;; add the itimer to the global list
|
|
70
|
304 (setq itimer-list
|
|
|
305 (cons (list name value restart function nil) ; extra slot for XEmacs
|
|
|
306 itimer-list))
|
|
|
307 ; ;; If the itimer process is scheduled to wake up too late for the itimer
|
|
|
308 ; ;; we wake it up to calculate a correct wakeup value giving consideration
|
|
|
309 ; ;; to the newly added itimer.
|
|
|
310 ; (if (< value itimer-process-next-wakeup)
|
|
|
311 ; (itimer-process-wakeup)))
|
|
|
312 ;; for XEmacs
|
|
|
313 (activate-itimer (car itimer-list))
|
|
|
314 )
|
|
|
315 (car itimer-list))
|
|
0
|
316
|
|
|
317 ;; User level functions to list and modify existing itimers.
|
|
|
318 ;; Itimer Edit major mode, and the editing commands thereof.
|
|
|
319
|
|
|
320 (defun list-itimers ()
|
|
|
321 "Pop up a buffer containing a list of all itimers.
|
|
|
322 The major mode of the buffer is Itimer Edit mode. This major mode provides
|
|
|
323 commands to manipulate itimers; see the documentation for
|
|
|
324 `itimer-edit-mode' for more information."
|
|
|
325 (interactive)
|
|
|
326 (let* ((buf (get-buffer-create "*Itimer List*"))
|
|
|
327 (opoint (point))
|
|
|
328 (standard-output buf)
|
|
|
329 (itimers (reverse itimer-list)))
|
|
|
330 (set-buffer buf)
|
|
|
331 (itimer-edit-mode)
|
|
|
332 (setq buffer-read-only nil)
|
|
|
333 (erase-buffer)
|
|
70
|
334 (insert "Name Value Restart Function\n"
|
|
|
335 "---- ----- ------- --------")
|
|
0
|
336 (if (null itimer-edit-start-marker)
|
|
|
337 (setq itimer-edit-start-marker (point)))
|
|
|
338 (while itimers
|
|
|
339 (newline 1)
|
|
|
340 (prin1 (itimer-name (car itimers)))
|
|
|
341 (tab-to-tab-stop)
|
|
70
|
342 (prin1 (itimer-value (car itimers)))
|
|
0
|
343 (tab-to-tab-stop)
|
|
70
|
344 (prin1 (itimer-restart (car itimers)))
|
|
0
|
345 (tab-to-tab-stop)
|
|
70
|
346 (prin1 (itimer-function (car itimers)))
|
|
0
|
347 (setq itimers (cdr itimers)))
|
|
|
348 ;; restore point
|
|
|
349 (goto-char opoint)
|
|
|
350 (if (< (point) itimer-edit-start-marker)
|
|
|
351 (goto-char itimer-edit-start-marker))
|
|
|
352 (setq buffer-read-only t)
|
|
|
353 (display-buffer buf)))
|
|
|
354
|
|
|
355 (defun edit-itimers ()
|
|
|
356 "Display a list of all itimers and select it for editing.
|
|
|
357 The major mode of the buffer containing the listing is Itimer Edit mode.
|
|
|
358 This major mode provides commands to manipulate itimers; see the documentation
|
|
|
359 for `itimer-edit-mode' for more information."
|
|
|
360 (interactive)
|
|
|
361 ;; since user is editing, make sure displayed data is reasonably up-to-date
|
|
70
|
362 ; (if itimer-process
|
|
|
363 ; (itimer-process-wakeup))
|
|
0
|
364 (list-itimers)
|
|
|
365 (select-window (get-buffer-window "*Itimer List*"))
|
|
|
366 (goto-char itimer-edit-start-marker)
|
|
|
367 (if itimer-list
|
|
|
368 (progn
|
|
|
369 (forward-sexp 2)
|
|
|
370 (backward-sexp)))
|
|
|
371 (message "type q to quit, ? for help"))
|
|
|
372
|
|
|
373 ;; no point in making this interactive.
|
|
|
374 (defun itimer-edit-mode ()
|
|
|
375 "Major mode for manipulating itimers.
|
|
70
|
376 Atrributes of running itimers are changed by moving the cursor to the
|
|
0
|
377 desired field and typing `s' to set that field. The field will then be
|
|
|
378 set to the value read from the minibuffer.
|
|
|
379
|
|
|
380 Commands:
|
|
|
381 TAB move forward a field
|
|
|
382 DEL move backward a field
|
|
|
383 s set a field
|
|
|
384 d delete the selected itimer
|
|
|
385 x start a new itimer
|
|
|
386 ? help"
|
|
|
387 (kill-all-local-variables)
|
|
|
388 (make-local-variable 'tab-stop-list)
|
|
|
389 (setq major-mode 'itimer-edit-mode
|
|
|
390 mode-name "Itimer Edit"
|
|
|
391 truncate-lines t
|
|
70
|
392 tab-stop-list '(22 32 42))
|
|
0
|
393 (abbrev-mode 0)
|
|
|
394 (auto-fill-mode 0)
|
|
70
|
395 (buffer-disable-undo (current-buffer))
|
|
0
|
396 (use-local-map itimer-edit-map)
|
|
70
|
397 (and lisp-mode-syntax-table (set-syntax-table lisp-mode-syntax-table)))
|
|
0
|
398
|
|
|
399 (put 'itimer-edit-mode 'mode-class 'special)
|
|
|
400
|
|
|
401 (defun itimer-edit-help ()
|
|
|
402 "Help function for Itimer Edit."
|
|
|
403 (interactive)
|
|
|
404 (if (eq last-command 'itimer-edit-help)
|
|
|
405 (describe-mode)
|
|
|
406 (message "TAB, DEL select fields, (s)et field, (d)elete itimer (type ? for more help)")))
|
|
|
407
|
|
|
408 (defun itimer-edit-quit ()
|
|
|
409 "End Itimer Edit."
|
|
|
410 (interactive)
|
|
|
411 (bury-buffer (current-buffer))
|
|
|
412 (if (one-window-p t)
|
|
|
413 (switch-to-buffer (other-buffer (current-buffer)))
|
|
|
414 (delete-window)))
|
|
|
415
|
|
|
416 (defun itimer-edit-set-field ()
|
|
|
417 (interactive)
|
|
|
418 ;; First two lines in list buffer are headers.
|
|
|
419 ;; Cry out against the luser who attempts to change a field there.
|
|
|
420 (if (<= (point) itimer-edit-start-marker)
|
|
|
421 (error ""))
|
|
|
422 ;; field-value must be initialized to be something other than a
|
|
|
423 ;; number, symbol, or list.
|
|
|
424 (let (itimer field (field-value ""))
|
|
|
425 (setq itimer (save-excursion
|
|
|
426 ;; read the name of the itimer from the beginning of
|
|
|
427 ;; the current line.
|
|
|
428 (beginning-of-line)
|
|
|
429 (get-itimer (read (current-buffer))))
|
|
|
430 field (save-excursion
|
|
|
431 (itimer-edit-beginning-of-field)
|
|
|
432 (let ((opoint (point))
|
|
|
433 (n 0))
|
|
|
434 ;; count the number of sexprs until we reach the cursor
|
|
|
435 ;; and use this info to determine which field the user
|
|
|
436 ;; wants to modify.
|
|
|
437 (beginning-of-line)
|
|
70
|
438 (while (and (>= opoint (point)) (< n 4))
|
|
0
|
439 (forward-sexp 2)
|
|
|
440 (backward-sexp)
|
|
70
|
441 (itimer-incf n))
|
|
0
|
442 (cond ((eq n 1) (error "Cannot change itimer name."))
|
|
|
443 ((eq n 2) 'value)
|
|
|
444 ((eq n 3) 'restart)
|
|
70
|
445 ((eq n 4) 'function)))))
|
|
0
|
446 (cond ((eq field 'value)
|
|
70
|
447 ;; XEmacs: rewritten for I18N3 snarfing
|
|
|
448 (while (not (natnump field-value))
|
|
|
449 (setq field-value (read-from-minibuffer "Set itimer value: "
|
|
|
450 nil nil t))))
|
|
0
|
451 ((eq field 'restart)
|
|
70
|
452 (while (and field-value (not (natnump field-value)))
|
|
|
453 (setq field-value (read-from-minibuffer "Set itimer restart: "
|
|
|
454 nil nil t))))
|
|
0
|
455 ((eq field 'function)
|
|
70
|
456 (while (not (or (and (symbolp field-value) (fboundp field-value))
|
|
|
457 (and (consp field-value)
|
|
|
458 (memq (car field-value) '(lambda macro)))))
|
|
|
459 (setq field-value
|
|
|
460 (read (completing-read "Set itimer function: "
|
|
|
461 obarray 'fboundp nil))))))
|
|
0
|
462 ;; set the itimer field
|
|
|
463 (funcall (intern (concat "set-itimer-" (symbol-name field)))
|
|
|
464 itimer field-value)
|
|
|
465 ;; move to beginning of field to be changed
|
|
|
466 (itimer-edit-beginning-of-field)
|
|
|
467 ;; modify the list buffer to reflect the change.
|
|
|
468 (let (buffer-read-only kill-ring)
|
|
|
469 (kill-sexp 1)
|
|
|
470 (kill-region (point) (progn (skip-chars-forward " \t") (point)))
|
|
|
471 (prin1 field-value (current-buffer))
|
|
|
472 (if (not (eolp))
|
|
|
473 (tab-to-tab-stop))
|
|
|
474 (backward-sexp))))
|
|
|
475
|
|
|
476 (defun itimer-edit-delete-itimer ()
|
|
|
477 (interactive)
|
|
|
478 ;; First two lines in list buffer are headers.
|
|
|
479 ;; Cry out against the luser who attempts to change a field there.
|
|
|
480 (if (<= (point) itimer-edit-start-marker)
|
|
|
481 (error ""))
|
|
|
482 (delete-itimer
|
|
|
483 (read-itimer "Delete itimer: "
|
|
|
484 (save-excursion (beginning-of-line) (read (current-buffer)))))
|
|
|
485 ;; update list information
|
|
|
486 (list-itimers))
|
|
|
487
|
|
|
488 (defun itimer-edit-next-field (count)
|
|
|
489 (interactive "p")
|
|
|
490 (itimer-edit-beginning-of-field)
|
|
|
491 (cond ((> (itimer-signum count) 0)
|
|
|
492 (while (not (zerop count))
|
|
|
493 (forward-sexp)
|
|
|
494 ;; wrap from eob to itimer-edit-start-marker
|
|
|
495 (if (eobp)
|
|
|
496 (progn
|
|
|
497 (goto-char itimer-edit-start-marker)
|
|
|
498 (forward-sexp)))
|
|
|
499 (forward-sexp)
|
|
|
500 (backward-sexp)
|
|
|
501 ;; treat fields at beginning of line as if they weren't there.
|
|
|
502 (if (bolp)
|
|
|
503 (progn
|
|
|
504 (forward-sexp 2)
|
|
|
505 (backward-sexp)))
|
|
70
|
506 (itimer-decf count)))
|
|
0
|
507 ((< (itimer-signum count) 0)
|
|
|
508 (while (not (zerop count))
|
|
|
509 (backward-sexp)
|
|
|
510 ;; treat fields at beginning of line as if they weren't there.
|
|
|
511 (if (bolp)
|
|
|
512 (backward-sexp))
|
|
|
513 ;; wrap from itimer-edit-start-marker to field at eob.
|
|
|
514 (if (<= (point) itimer-edit-start-marker)
|
|
|
515 (progn
|
|
|
516 (goto-char (point-max))
|
|
|
517 (backward-sexp)))
|
|
70
|
518 (itimer-incf count)))))
|
|
0
|
519
|
|
|
520 (defun itimer-edit-previous-field (count)
|
|
|
521 (interactive "p")
|
|
|
522 (itimer-edit-next-field (- count)))
|
|
|
523
|
|
|
524 (defun itimer-edit-beginning-of-field ()
|
|
|
525 (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point)))
|
|
|
526 (back (save-excursion (backward-sexp) (point))))
|
|
|
527 (cond ((eq forw-back back) (backward-sexp))
|
|
|
528 ((eq forw-back (point)) t)
|
|
|
529 (t (backward-sexp)))))
|
|
|
530
|
|
|
531
|
|
|
532 ;; internals of the itimer implementation.
|
|
|
533
|
|
|
534 (defun itimer-process-filter (process string)
|
|
70
|
535 (error "itimer-process-filter is not used in XEmacs")
|
|
|
536 ; ;; If the itimer process dies and generates output while doing
|
|
|
537 ; ;; so, we may be called before the process-sentinel. Sanity
|
|
|
538 ; ;; check the output just in case...
|
|
|
539 ; (if (not (string-match "^[0-9]" string))
|
|
|
540 ; (progn (message "itimer process gave odd output: %s" string)
|
|
|
541 ; ;; it may be still alive and waiting for input
|
|
|
542 ; (process-send-string itimer-process "3\n"))
|
|
|
543 ; ;; if there are no active itimers, return quickly.
|
|
|
544 ; (if itimer-list
|
|
|
545 ; (let ((time-elapsed (string-to-int string))
|
|
|
546 ; (itimers itimer-list)
|
|
|
547 ; (itimer)
|
|
|
548 ; ;; process filters can be hit by stray C-g's from the user,
|
|
|
549 ; ;; so we must protect this stuff appropriately.
|
|
|
550 ; ;; Quit's are allowed from within itimer functions, but we
|
|
|
551 ; ;; catch them.
|
|
|
552 ; (inhibit-quit t))
|
|
|
553 ; (setq itimer-process-next-wakeup 600)
|
|
|
554 ; (while itimers
|
|
|
555 ; (setq itimer (car itimers))
|
|
|
556 ; (set-itimer-value itimer (max 0 (- (itimer-value itimer) time-elapsed)) t)
|
|
|
557 ; (if (> (itimer-value itimer) 0)
|
|
|
558 ; (setq itimer-process-next-wakeup
|
|
|
559 ; (min itimer-process-next-wakeup (itimer-value itimer)))
|
|
|
560 ; ;; itimer has expired, we must call its function.
|
|
|
561 ; ;; protect our local vars from the itimer function.
|
|
|
562 ; ;; allow keyboard quit to occur, but catch and report it.
|
|
|
563 ; ;; provide the variable `current-itimer' in case the function
|
|
|
564 ; ;; is interested.
|
|
|
565 ; (condition-case condition-data
|
|
|
566 ; (let* ((current-itimer itimer)
|
|
|
567 ; itimer itimers time-elapsed
|
|
|
568 ; quit-flag inhibit-quit)
|
|
|
569 ; (funcall (itimer-function current-itimer)))
|
|
|
570 ; (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer)
|
|
|
571 ; (prin1-to-string condition-data)))
|
|
|
572 ; (quit (message "itimer \"%s\" quit" (itimer-name itimer))))
|
|
|
573 ; ;; restart the itimer if we should, otherwise delete it.
|
|
|
574 ; (if (null (itimer-restart itimer))
|
|
|
575 ; (delete-itimer itimer)
|
|
|
576 ; (set-itimer-value itimer (itimer-restart itimer) t)
|
|
|
577 ; (setq itimer-process-next-wakeup
|
|
|
578 ; (min itimer-process-next-wakeup (itimer-value itimer)))))
|
|
|
579 ; (setq itimers (cdr itimers)))
|
|
|
580 ; ;; if user is editing itimers, update displayed info
|
|
|
581 ; (if (eq major-mode 'itimer-edit-mode)
|
|
|
582 ; (list-itimers)))
|
|
|
583 ; (setq itimer-process-next-wakeup 600))
|
|
|
584 ; ;; tell itimer-process when to wakeup again
|
|
|
585 ; (process-send-string itimer-process
|
|
|
586 ; (concat (int-to-string itimer-process-next-wakeup)
|
|
|
587 ; "\n")))
|
|
|
588 )
|
|
0
|
589
|
|
|
590 (defun itimer-process-sentinel (process message)
|
|
70
|
591 (error "itimer-process-sentinel is not used in XEmacs")
|
|
|
592 ; (let ((inhibit-quit t))
|
|
|
593 ; (if (eq (process-status process) 'stop)
|
|
|
594 ; (continue-process process)
|
|
|
595 ; ;; not stopped, so it must have died.
|
|
|
596 ; ;; cleanup first...
|
|
|
597 ; (delete-process process)
|
|
|
598 ; (setq itimer-process nil)
|
|
|
599 ; ;; now, if there are any active itimers then we need to immediately
|
|
|
600 ; ;; start another itimer process, otherwise we can wait until the next
|
|
|
601 ; ;; start-itimer call, which will start one automatically.
|
|
|
602 ; (if (null itimer-list)
|
|
|
603 ; ()
|
|
|
604 ; ;; there may have been an error message in the echo area;
|
|
|
605 ; ;; give the user at least a little time to read it.
|
|
|
606 ; (sit-for 2)
|
|
|
607 ; (message "itimer process %s... respawning." (substring message 0 -1))
|
|
|
608 ; (itimer-process-start))))
|
|
|
609 )
|
|
0
|
610
|
|
|
611 (defun itimer-process-start ()
|
|
70
|
612 (error "itimer-process-start is not used in XEmacs")
|
|
|
613 ; (let ((inhibit-quit t)
|
|
|
614 ; (process-connection-type nil))
|
|
|
615 ; (setq itimer-process (start-process "itimer" nil "itimer"))
|
|
|
616 ; (process-kill-without-query itimer-process)
|
|
|
617 ; (set-process-filter itimer-process 'itimer-process-filter)
|
|
|
618 ; (set-process-sentinel itimer-process 'itimer-process-sentinel)
|
|
|
619 ; ;; Tell itimer process to wake up quickly, so that a correct wakeup
|
|
|
620 ; ;; time can be computed. Zero instead of one here loses because of
|
|
|
621 ; ;; underlying itimer implementations that use 0 to mean `disable the
|
|
|
622 ; ;; itimer'.
|
|
|
623 ; (setq itimer-process-next-wakeup 1)
|
|
|
624 ; (process-send-string itimer-process "1\n"))
|
|
|
625 )
|
|
0
|
626
|
|
|
627 (defun itimer-process-wakeup ()
|
|
70
|
628 (error "itimer-process-wakeup is not used in XEmacs")
|
|
|
629 ; (interrupt-process itimer-process)
|
|
|
630 ; (accept-process-output)
|
|
|
631 )
|
|
0
|
632
|
|
70
|
633
|
|
|
634 ;; XEmacs-specific code
|
|
|
635
|
|
|
636 (defun activate-itimer (itimer)
|
|
26
|
637 (let ((inhibit-quit t))
|
|
70
|
638 (set-itimer-id itimer
|
|
|
639 (add-timeout (itimer-value itimer)
|
|
|
640 'itimer-callback
|
|
|
641 itimer
|
|
|
642 (itimer-restart itimer))))
|
|
|
643 itimer)
|
|
|
644
|
|
|
645 (defun deactivate-itimer (itimer)
|
|
|
646 (let ((inhibit-quit t)
|
|
|
647 (id (itimer-id itimer)))
|
|
|
648 (and id (disable-timeout id))
|
|
|
649 (set-itimer-id itimer nil))
|
|
|
650 itimer)
|
|
|
651
|
|
|
652 (defun itimer-callback (current-itimer)
|
|
|
653 (funcall (itimer-function current-itimer)))
|
|
0
|
654
|
|
70
|
655
|
|
|
656 ;;; itimer-driven auto-saves
|
|
|
657
|
|
|
658 ;jwz: this is preloaded so don't ;;;###autoload
|
|
|
659 (defvar auto-save-timeout 30
|
|
|
660 "*Number of seconds idle time before auto-save.
|
|
|
661 Zero or nil means disable auto-saving due to idleness.
|
|
|
662
|
|
|
663 The actual amount of idle time between auto-saves is logarithmically related
|
|
|
664 to the size of the current buffer. This variable is the number of seconds
|
|
|
665 after which an auto-save will happen when the current buffer is 50k or less;
|
|
|
666 the timeout will be 2 1/4 times this in a 200k buffer, 3 3/4 times this in a
|
|
|
667 1000k buffer, and 4 1/2 times this in a 2000k buffer.
|
|
|
668
|
|
|
669 See also the variable `auto-save-interval', which controls auto-saving based
|
|
|
670 on the number of characters typed.")
|
|
|
671
|
|
|
672 ;jwz: this is preloaded so don't ;;;###autoload
|
|
|
673 (defvar auto-gc-threshold (/ gc-cons-threshold 3)
|
|
|
674 "*GC when this many bytes have been consed since the last GC,
|
|
|
675 and the user has been idle for `auto-save-timeout' seconds.")
|
|
0
|
676
|
|
70
|
677 (defun auto-save-itimer ()
|
|
|
678 "For use as a itimer callback function.
|
|
|
679 Auto-saves and garbage-collects based on the size of the current buffer
|
|
|
680 and the value of `auto-save-timeout', `auto-gc-threshold', and the current
|
|
|
681 keyboard idle-time."
|
|
|
682 (if (or (null auto-save-timeout)
|
|
|
683 (<= auto-save-timeout 0)
|
|
|
684 (eq (minibuffer-window) (selected-window)))
|
|
|
685 nil
|
|
|
686 (let ((buf-size (1+ (ash (buffer-size) -8)))
|
|
|
687 (delay-level 0)
|
|
|
688 (now (current-time))
|
|
|
689 delay)
|
|
|
690 (while (> buf-size 64)
|
|
|
691 (setq delay-level (1+ delay-level)
|
|
|
692 buf-size (- buf-size (ash buf-size -2))))
|
|
|
693 (if (< delay-level 4)
|
|
|
694 (setq delay-level 4))
|
|
|
695 ;; delay_level is 4 for files under around 50k, 7 at 100k, 9 at 200k,
|
|
|
696 ;; 11 at 300k, and 12 at 500k, 15 at 1 meg, and 17 at 2 meg.
|
|
|
697 (setq delay (/ (* delay-level auto-save-timeout) 4))
|
|
|
698 (let ((idle-time (if (or (not (consp last-input-time))
|
|
|
699 (/= (car now) (car last-input-time)))
|
|
|
700 (1+ delay)
|
|
|
701 (- (car (cdr now)) (cdr last-input-time)))))
|
|
|
702 (and (> idle-time delay)
|
|
|
703 (do-auto-save))
|
|
|
704 (and (> idle-time auto-save-timeout)
|
|
|
705 (> (consing-since-gc) auto-gc-threshold)
|
|
|
706 (garbage-collect)))))
|
|
|
707 ;; Look at the itimer that's currently running; if the user has changed
|
|
|
708 ;; the value of auto-save-timeout, modify this itimer to have the correct
|
|
|
709 ;; restart time. There will be some latency between when the user changes
|
|
|
710 ;; this variable and when it takes effect, but it will happen eventually.
|
|
|
711 (let ((self (get-itimer "auto-save")))
|
|
|
712 (or self (error "auto-save-itimer can't find itself"))
|
|
|
713 (if (and auto-save-timeout (> auto-save-timeout 4))
|
|
|
714 (or (= (itimer-restart self) (/ auto-save-timeout 4))
|
|
|
715 (set-itimer-restart self (/ auto-save-timeout 4)))))
|
|
|
716 nil)
|
|
0
|
717
|
|
70
|
718 (defun itimer-init-auto-gc ()
|
|
|
719 (or noninteractive ; may be being run from after-init-hook in -batch mode.
|
|
|
720 (get-itimer "auto-save")
|
|
|
721 ;; the time here is just the first interval; if the user changes it
|
|
|
722 ;; later, it will adjust.
|
|
|
723 (let ((time (max 2 (/ (or auto-save-timeout 30) 4))))
|
|
|
724 (start-itimer "auto-save" 'auto-save-itimer time time))))
|
|
0
|
725
|
|
70
|
726 (cond (purify-flag
|
|
|
727 ;; This file is being preloaded into an emacs about to be dumped.
|
|
|
728 ;; So arrange for the auto-save itimer to be started once emacs
|
|
|
729 ;; is launched.
|
|
|
730 (add-hook 'after-init-hook 'itimer-init-auto-gc))
|
|
|
731 (t
|
|
|
732 ;; Otherwise, this file is being loaded into a normal, interactive
|
|
|
733 ;; emacs. Start the auto-save timer now.
|
|
|
734 (itimer-init-auto-gc)))
|
|
0
|
735
|
|
70
|
736
|
|
|
737 (provide 'itimer)
|
