update.
[chise/xemacs-chise.git] / lisp / itimer.el
1 ;;; Interval timers for GNU Emacs
2 ;;; Copyright (C) 1988, 1991, 1993, 1997, 1998 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 2, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; A copy of the GNU General Public License can be obtained from this
15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
17 ;;; 02139, USA.
18 ;;;
19 ;;; Send bug reports to kyle_jones@wonderworks.com
20
21 (provide 'itimer)
22
23 (require 'lisp-float-type)
24
25 ;; `itimer' feature means Emacs-Lisp programmers get:
26 ;;    itimerp
27 ;;    itimer-live-p
28 ;;    itimer-value
29 ;;    itimer-restart
30 ;;    itimer-function
31 ;;    itimer-uses-arguments
32 ;;    itimer-function-arguments
33 ;;    set-itimer-value
34 ;;    set-itimer-restart
35 ;;    set-itimer-function
36 ;;    set-itimer-uses-arguments
37 ;;    set-itimer-function-arguments
38 ;;    get-itimer
39 ;;    start-itimer
40 ;;    read-itimer
41 ;;    delete-itimer
42 ;;    activate-itimer
43 ;;
44 ;; Interactive users get these commands:
45 ;;    edit-itimers
46 ;;    list-itimers
47 ;;    start-itimer
48 ;;
49 ;; See the doc strings of these functions for more information.
50 \f
51 (defvar itimer-version "1.09"
52   "Version number of the itimer package.")
53
54 (defvar itimer-list nil
55   "List of all active itimers.")
56
57 (defvar itimer-process nil
58   "Process that drives all itimers, if a subprocess is being used.")
59
60 (defvar itimer-timer nil
61   "Emacs internal timer that drives the itimer system, if a subprocess
62 is not being used to drive the system.")
63
64 (defvar itimer-timer-last-wakeup nil
65   "The time the timer driver function last ran.")
66
67 (defvar itimer-short-interval 1e-3
68   "Interval used for scheduling an event a very short time in the future.
69 Used internally to make the scheduler wake up early.
70 Unit is seconds.")
71
72 ;; This value is maintained internally; it does not determine
73 ;; itimer granularity.  Itimer granularity is 1 second if your
74 ;; Emacs doesn't support floats or your system doesn't have a
75 ;; clock with microsecond granularity.  Otherwise granularity is
76 ;; to the microsecond, although you can't possibly get timers to be
77 ;; executed with this kind of accuracy in practice.  There will
78 ;; be delays due to system and Emacs internal activity that delay
79 ;; dealing with synchronous events and process output.
80 (defvar itimer-next-wakeup itimer-short-interval
81   "Itimer process will wakeup to service running itimers within this
82 many seconds.")
83
84 (defvar itimer-edit-map nil
85   "Keymap used when in Itimer Edit mode.")
86
87 (if itimer-edit-map
88     ()
89   (setq itimer-edit-map (make-sparse-keymap))
90   (define-key itimer-edit-map "s" 'itimer-edit-set-field)
91   (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer)
92   (define-key itimer-edit-map "q" 'itimer-edit-quit)
93   (define-key itimer-edit-map "\t" 'itimer-edit-next-field)
94   (define-key itimer-edit-map " " 'next-line)
95   (define-key itimer-edit-map "n" 'next-line)
96   (define-key itimer-edit-map "p" 'previous-line)
97   (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field)
98   (define-key itimer-edit-map "x" 'start-itimer)
99   (define-key itimer-edit-map "?" 'itimer-edit-help))
100
101 (defvar itimer-inside-driver nil)
102
103 (defvar itimer-edit-start-marker nil)
104 \f
105 ;; macros must come first... or byte-compile'd code will throw back its
106 ;; head and scream.
107
108 (defmacro itimer-decrement (variable)
109   (list 'setq variable (list '1- variable)))
110
111 (defmacro itimer-increment (variable)
112   (list 'setq variable (list '1+ variable)))
113
114 (defmacro itimer-signum (n)
115   (list 'if (list '> n 0) 1
116     (list 'if (list 'zerop n) 0 -1)))
117
118 ;; Itimer access functions should behave as if they were subrs.  These
119 ;; macros are used to check the arguments to the itimer functions and
120 ;; signal errors appropriately if the arguments are not valid.
121
122 (defmacro check-itimer (var)
123   "If VAR is not bound to an itimer, signal `wrong-type-argument'.
124 This is a macro."
125   (list 'setq var
126         (list 'if (list 'itimerp var) var
127               (list 'signal ''wrong-type-argument
128                     (list 'list ''itimerp var)))))
129
130 (defmacro check-itimer-coerce-string (var)
131   "If VAR is not bound to a string, look up the itimer that it names and
132 bind VAR to it.  Otherwise, if VAR is not bound to an itimer, signal
133 wrong-type-argument.  This is a macro."
134   (list 'setq var
135         (list 'cond
136               (list (list 'itimerp var) var)
137               (list (list 'stringp var) (list 'get-itimer var))
138               (list t (list 'signal ''wrong-type-argument
139                             (list 'list ''string-or-itimer-p var))))))
140
141 (defmacro check-nonnegative-number (var)
142   "If VAR is not bound to a number, signal `wrong-type-argument'.
143 If VAR is not bound to a positive number, signal args-out-of-range.
144 This is a macro."
145   (list 'setq var
146         (list 'if (list 'not (list 'numberp var))
147               (list 'signal ''wrong-type-argument
148                     (list 'list ''natnump var))
149               (list 'if (list '< var 0)
150                     (list 'signal ''args-out-of-range (list 'list var))
151                     var))))
152
153 (defmacro check-string (var)
154   "If VAR is not bound to a string, signal `wrong-type-argument'.
155 This is a macro."
156   (list 'setq var
157         (list 'if (list 'stringp var) var
158               (list 'signal ''wrong-type-argument
159                     (list 'list ''stringp var)))))
160 \f
161 ;; Functions to access and modify itimer attributes.
162
163 (defun itimerp (object)
164   "Return non-nil if OBJECT is an itimer."
165   (and (consp object) (eq (length object) 8)))
166
167 (defun itimer-live-p (object)
168   "Return non-nil if OBJECT is an itimer and is active.
169 ``Active'' means Emacs will run it when it expires.
170 `activate-itimer' must be called on an itimer to make it active.
171 Itimers started with `start-itimer' are automatically active."
172   (and (itimerp object) (memq object itimer-list)))
173
174 (defun itimer-name (itimer)
175   "Return the name of ITIMER."
176   (check-itimer itimer)
177   (car itimer))
178
179 (defun itimer-value (itimer)
180   "Return the number of seconds until ITIMER expires."
181   (check-itimer itimer)
182   (nth 1 itimer))
183
184 (defun itimer-restart (itimer)
185   "Return the value to which ITIMER will be set at restart.
186 The value nil is returned if this itimer isn't set to restart."
187   (check-itimer itimer)
188   (nth 2 itimer))
189
190 (defun itimer-function (itimer)
191   "Return the function of ITIMER.
192 This function is called each time ITIMER expires."
193   (check-itimer itimer)
194   (nth 3 itimer))
195
196 (defun itimer-is-idle (itimer)
197   "Return non-nil if ITIMER is an idle timer.
198 Normal timers expire after a set interval.  Idle timers expire
199 only after Emacs has been idle for a specific interval.  ``Idle''
200 means no command events have occurred within the interval."
201   (check-itimer itimer)
202   (nth 4 itimer))
203
204 (defun itimer-uses-arguments (itimer)
205   "Return non-nil if the function of ITIMER will be called with arguments.
206 ITIMER's function is called with the arguments each time ITIMER expires.
207 The arguments themselves are retrievable with `itimer-function-arguments'."
208   (check-itimer itimer)
209   (nth 5 itimer))
210
211 (defun itimer-function-arguments (itimer)
212   "Return the function arguments of ITIMER as a list.
213 ITIMER's function is called with these arguments each time ITIMER expires."
214   (check-itimer itimer)
215   (nth 6 itimer))
216
217 (defun itimer-recorded-run-time (itimer)
218   (check-itimer itimer)
219   (nth 7 itimer))
220
221 (defun set-itimer-value (itimer value)
222   "Set the timeout value of ITIMER to be VALUE.
223 Itimer will expire in this many seconds.
224 If your version of Emacs supports floating point numbers then
225 VALUE can be a floating point number.  Otherwise it
226 must be an integer.
227 Returns VALUE."
228   (check-itimer itimer)
229   (check-nonnegative-number value)
230   (let ((inhibit-quit t))
231     ;; If the itimer is in the active list, and under the new
232     ;; timeout value would expire before we would normally
233     ;; wakeup, wakeup now and recompute a new wakeup time.
234     (or (and (< value itimer-next-wakeup)
235              (and (itimer-name itimer) (get-itimer (itimer-name itimer)))
236              (progn (itimer-driver-wakeup)
237                     (setcar (cdr itimer) value)
238                     (itimer-driver-wakeup)
239                     t ))
240         (setcar (cdr itimer) value))
241     value))
242
243 ;; Same as set-itimer-value but does not wakeup the driver.
244 ;; Only should be used by the drivers when processing expired timers.
245 (defun set-itimer-value-internal (itimer value)
246   (check-itimer itimer)
247   (check-nonnegative-number value)
248   (setcar (cdr itimer) value))
249
250 (defun set-itimer-restart (itimer restart)
251   "Set the restart value of ITIMER to be RESTART.
252 If RESTART is nil, ITIMER will not restart when it expires.
253 If your version of Emacs supports floating point numbers then
254 RESTART can be a floating point number.  Otherwise it
255 must be an integer.
256 Returns RESTART."
257   (check-itimer itimer)
258   (if restart (check-nonnegative-number restart))
259   (setcar (cdr (cdr itimer)) restart))
260
261 (defun set-itimer-function (itimer function)
262   "Set the function of ITIMER to be FUNCTION.
263 FUNCTION will be called when itimer expires.
264 Returns FUNCTION."
265   (check-itimer itimer)
266   (setcar (nthcdr 3 itimer) function))
267
268 (defun set-itimer-is-idle (itimer flag)
269   "Set flag that says whether ITIMER is an idle timer.
270 If FLAG is non-nil, then ITIMER will be considered an idle timer.
271 Returns FLAG."
272   (check-itimer itimer)
273   (setcar (nthcdr 4 itimer) flag))
274
275 (defun set-itimer-uses-arguments (itimer flag)
276   "Set flag that says whether the function of ITIMER is called with arguments.
277 If FLAG is non-nil, then the function will be called with one argument,
278 otherwise the function will be called with no arguments.
279 Returns FLAG."
280   (check-itimer itimer)
281   (setcar (nthcdr 5 itimer) flag))
282
283 (defun set-itimer-function-arguments (itimer &optional arguments)
284   "Set the function arguments of ITIMER to be ARGUMENTS.
285 The function of ITIMER will be called with ARGUMENTS when itimer expires.
286 Returns ARGUMENTS."
287   (check-itimer itimer)
288   (setcar (nthcdr 6 itimer) arguments))
289
290 (defun set-itimer-recorded-run-time (itimer time)
291   (check-itimer itimer)
292   (setcar (nthcdr 7 itimer) time))
293
294 (defun get-itimer (name)
295   "Return itimer named NAME, or nil if there is none."
296   (check-string name)
297   (assoc name itimer-list))
298
299 (defun read-itimer (prompt &optional initial-input)
300   "Read the name of an itimer from the minibuffer and return the itimer
301 associated with that name.  The user is prompted with PROMPT.
302 Optional second arg INITIAL-INPUT non-nil is inserted into the
303 minibuffer as initial user input."
304   (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input)))
305
306 (defun delete-itimer (itimer)
307   "Deletes ITIMER.  ITIMER may be an itimer or the name of one."
308   (check-itimer-coerce-string itimer)
309   (setq itimer-list (delq itimer itimer-list)))
310
311 (defun start-itimer (name function value &optional restart
312                      is-idle with-args &rest function-arguments)
313   "Start an itimer.
314 Arguments are
315   NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS.
316 NAME is an identifier for the itimer.  It must be a string.  If an itimer
317   already exists with this name, NAME will be modified slightly to make
318   it unique.
319 FUNCTION should be a function (or symbol naming one).  It
320   will be called each time the itimer expires with arguments of
321   FUNCTION-ARGUMENTS.  The function can access the itimer that
322   invoked it through the variable `current-itimer'.  If WITH-ARGS
323   is nil then FUNCTION is called with no arguments.  This is for
324   backward compatibility with older versions of the itimer
325   package which always called FUNCTION with no arguments.
326 VALUE is the number of seconds until this itimer expires.
327   If your version of Emacs supports floating point numbers then
328   VALUE can be a floating point number.  Otherwise it
329   must be an integer.
330 Optional fourth arg RESTART non-nil means that this itimer should be
331   restarted automatically after its function is called.  Normally an itimer
332   is deleted at expiration after its function has returned.
333   If non-nil RESTART should be a number indicating the value at which the
334   itimer should be set at restart time.
335 Optional fifth arg IS-IDLE specifies if this is an idle timer.
336   Normal timers expire after a set interval.  Idle timers expire
337   only after Emacs has been idle for specific interval.  ``Idle''
338   means no command events have occurred within the interval.
339 Returns the newly created itimer."
340   (interactive
341    (list (completing-read "Start itimer: " itimer-list)
342          (read (completing-read "Itimer function: " obarray 'fboundp))
343          (let (value)
344            (while (or (not (numberp value)) (< value 0))
345              (setq value (read-from-minibuffer "Itimer value: " nil nil t)))
346            value)
347          (let ((restart t))
348            (while (and restart (or (not (numberp restart)) (< restart 0)))
349              (setq restart (read-from-minibuffer "Itimer restart: "
350                                                  nil nil t)))
351            restart)
352          ;; hard to imagine the user specifying these interactively
353          nil
354          nil ))
355   (check-string name)
356   (check-nonnegative-number value)
357   (if restart (check-nonnegative-number restart))
358   ;; Make proposed itimer name unique if it's not already.
359   (let ((oname name)
360         (num 2))
361     (while (get-itimer name)
362       (setq name (format "%s<%d>" oname num))
363       (itimer-increment num)))
364   (activate-itimer (list name value restart function is-idle
365                          with-args function-arguments (list 0 0 0)))
366   (car itimer-list))
367
368 (defun make-itimer ()
369   "Create an unactivated itimer.
370 The itimer will not begin running until activated with `activate-itimer'.
371 Set the itimer's expire interval with `set-itimer-value'.
372 Set the itimer's function interval with `set-itimer-function'.
373 Once this is done, the timer can be activated."
374   (list nil 0 nil 'ignore nil nil nil (list 0 0 0)))
375
376 (defun activate-itimer (itimer)
377   "Activate ITIMER, which was previously created with `make-itimer'.
378 ITIMER will be added to the global list of running itimers,
379 its FUNCTION will be called when it expires, and so on."
380   (check-itimer itimer)
381   (if (memq itimer itimer-list)
382       (error "itimer already activated"))
383   (if (not (numberp (itimer-value itimer)))
384       (error "itimer timeout value not a number: %s" (itimer-value itimer)))
385   (if (<= (itimer-value itimer) 0)
386       (error "itimer timeout value not positive: %s" (itimer-value itimer)))
387   ;; If there's no itimer driver/process, start one now.
388   ;; Otherwise wake up the itimer driver so that seconds slept before
389   ;; the new itimer is created won't be counted against it.
390   (if (or itimer-process itimer-timer)
391       (itimer-driver-wakeup)
392     (itimer-driver-start))
393   ;; Roll a unique name for the timer if it doesn't have a name
394   ;; already.
395   (if (not (stringp (car itimer)))
396       (let ((name "itimer-0")
397             (oname "itimer-")
398             (num 1))
399         (while (get-itimer name)
400           (setq name (format "%s<%d>" oname num))
401           (itimer-increment num))
402         (setcar itimer name))
403     ;; signal an error if the timer's name matches an already
404     ;; activated timer.
405     (if (get-itimer (itimer-name itimer))
406         (error "itimer named \"%s\" already existing and activated"
407                (itimer-name itimer))))
408   (let ((inhibit-quit t))
409     (if itimer-timer
410         ;; Modify the itimer timeout value as if it were begun
411         ;; at the last time when the itimer driver was woken up.
412         (set-itimer-value
413          itimer
414          (+ (itimer-value itimer)
415             (itimer-time-difference (current-time)
416                                     itimer-timer-last-wakeup))))
417     ;; add the itimer to the global list
418     (setq itimer-list (cons itimer itimer-list))
419     ;; If the itimer process is scheduled to wake up too late for
420     ;; the itimer we wake it up to calculate a correct wakeup
421     ;; value giving consideration to the newly added itimer.
422     (if (< (itimer-value itimer) itimer-next-wakeup)
423         (itimer-driver-wakeup))))
424 \f
425 ;; User level functions to list and modify existing itimers.
426 ;; Itimer Edit major mode, and the editing commands thereof.
427
428 (defun list-itimers ()
429   "Pop up a buffer containing a list of all itimers.
430 The major mode of the buffer is Itimer Edit mode.  This major mode provides
431 commands to manipulate itimers; see the documentation for
432 `itimer-edit-mode' for more information."
433   (interactive)
434   (let* ((buf (get-buffer-create "*Itimer List*"))
435          (opoint (point))
436          (standard-output buf)
437          (itimers (reverse itimer-list)))
438     (set-buffer buf)
439     (itimer-edit-mode)
440     (setq buffer-read-only nil)
441     (erase-buffer)
442     (insert
443 "Name                  Value   Restart   Function            Idle   Arguments"
444 "\n"
445 "----                  -----   -------   --------            ----   --------")
446     (if (null itimer-edit-start-marker)
447         (setq itimer-edit-start-marker (point)))
448     (while itimers
449       (newline 1)
450       (prin1 (itimer-name (car itimers)))
451       (tab-to-tab-stop)
452       (insert (itimer-truncate-string
453                (format "%5.5s" (itimer-value (car itimers))) 5))
454       (tab-to-tab-stop)
455       (insert (itimer-truncate-string
456                (format "%5.5s" (itimer-restart (car itimers))) 5))
457       (tab-to-tab-stop)
458       (insert (itimer-truncate-string
459                (format "%.19s" (itimer-function (car itimers))) 19))
460       (tab-to-tab-stop)
461       (if (itimer-is-idle (car itimers))
462           (insert "yes")
463         (insert "no"))
464       (tab-to-tab-stop)
465       (if (itimer-uses-arguments (car itimers))
466           (prin1 (itimer-function-arguments (car itimers)))
467         (prin1 'NONE))
468       (setq itimers (cdr itimers)))
469     ;; restore point
470     (goto-char opoint)
471     (if (< (point) itimer-edit-start-marker)
472         (goto-char itimer-edit-start-marker))
473     (setq buffer-read-only t)
474     (display-buffer buf)))
475
476 (defun edit-itimers ()
477   "Display a list of all itimers and select it for editing.
478 The major mode of the buffer containing the listing is Itimer Edit mode.
479 This major mode provides commands to manipulate itimers; see the documentation
480 for `itimer-edit-mode' for more information."
481   (interactive)
482   ;; since user is editing, make sure displayed data is reasonably up-to-date
483   (if (or itimer-process itimer-timer)
484       (itimer-driver-wakeup))
485   (list-itimers)
486   (select-window (get-buffer-window "*Itimer List*"))
487   (goto-char itimer-edit-start-marker)
488   (if itimer-list
489       (progn
490         (forward-sexp 2)
491         (backward-sexp)))
492   (message "type q to quit, ? for help"))
493
494 ;; no point in making this interactive.
495 (defun itimer-edit-mode ()
496   "Major mode for manipulating itimers.
497 Attributes of running itimers are changed by moving the cursor to the
498 desired field and typing `s' to set that field.  The field will then be
499 set to the value read from the minibuffer.
500
501 Commands:
502 TAB    move forward a field
503 DEL    move backward a field
504 s      set a field
505 d      delete the selected itimer
506 x      start a new itimer
507 ?      help"
508   (kill-all-local-variables)
509   (make-local-variable 'tab-stop-list)
510   (setq major-mode 'itimer-edit-mode
511         mode-name "Itimer Edit"
512         truncate-lines t
513         tab-stop-list '(22 32 40 60 67))
514   (abbrev-mode 0)
515   (auto-fill-mode 0)
516   (buffer-disable-undo (current-buffer))
517   (use-local-map itimer-edit-map)
518   (set-syntax-table emacs-lisp-mode-syntax-table))
519
520 (put 'itimer-edit-mode 'mode-class 'special)
521
522 (defun itimer-edit-help ()
523   "Help function for Itimer Edit."
524   (interactive)
525   (if (eq last-command 'itimer-edit-help)
526       (describe-mode)
527     (message "TAB, DEL select fields, (s)et field, (d)elete itimer   (type ? for more help)")))
528
529 (defun itimer-edit-quit ()
530   "End Itimer Edit."
531   (interactive)
532   (bury-buffer (current-buffer))
533   (if (one-window-p t)
534       (switch-to-buffer (other-buffer (current-buffer)))
535     (delete-window)))
536
537 (defun itimer-edit-set-field ()
538   (interactive)
539   ;; First two lines in list buffer are headers.
540   ;; Cry out against the luser who attempts to change a field there.
541   (if (<= (point) itimer-edit-start-marker)
542       (error ""))
543   ;; field-value must be initialized to be something other than a
544   ;; number, symbol, or list.
545   (let (itimer field (field-value ""))
546     (setq itimer (save-excursion
547                   ;; read the name of the itimer from the beginning of
548                   ;; the current line.
549                   (beginning-of-line)
550                   (get-itimer (read (current-buffer))))
551           field (save-excursion
552                   (itimer-edit-beginning-of-field)
553                   (let ((opoint (point))
554                         (n 0))
555                     ;; count the number of sexprs until we reach the cursor
556                     ;; and use this info to determine which field the user
557                     ;; wants to modify.
558                     (beginning-of-line)
559                     (while (and (>= opoint (point)) (< n 6))
560                       (forward-sexp 2)
561                       (backward-sexp)
562                       (itimer-increment n))
563                     (cond ((eq n 1) (error "Cannot change itimer name."))
564                           ((eq n 2) 'value)
565                           ((eq n 3) 'restart)
566                           ((eq n 4) 'function)
567                           ((eq n 5) 'is-idle)
568                           (t 'function-argument)))))
569     (cond ((eq field 'value)
570            (let ((prompt "Set itimer value: "))
571              (while (not (natnump field-value))
572                (setq field-value (read-from-minibuffer prompt nil nil t)))))
573           ((eq field 'restart)
574            (let ((prompt "Set itimer restart: "))
575              (while (and field-value (not (natnump field-value)))
576                (setq field-value (read-from-minibuffer prompt nil nil t)))))
577           ((eq field 'function)
578            (let ((prompt "Set itimer function: "))
579              (while (not (or (and (symbolp field-value) (fboundp field-value))
580                              (and (consp field-value)
581                                   (memq (car field-value) '(lambda macro)))))
582                (setq field-value
583                      (read (completing-read prompt obarray 'fboundp nil))))))
584           ((eq field 'is-idle)
585            (setq field-value (not (itimer-is-idle itimer))))
586           ((eq field 'function-argument)
587            (let ((prompt "Set itimer function argument: "))
588              (setq field-value (read-expression prompt))
589              (cond ((not (listp field-value))
590                     (setq field-value (list field-value))))
591              (if (null field-value)
592                  (set-itimer-uses-arguments itimer nil)
593                (set-itimer-uses-arguments itimer t)))))
594     ;; set the itimer field
595     (funcall (intern (concat "set-itimer-" (symbol-name field)))
596              itimer field-value)
597     ;; move to beginning of field to be changed
598     (itimer-edit-beginning-of-field)
599     ;; modify the list buffer to reflect the change.
600     (let (buffer-read-only kill-ring)
601       (kill-sexp 1)
602       (kill-region (point) (progn (skip-chars-forward " \t") (point)))
603       (prin1 field-value (current-buffer))
604       (if (not (eolp))
605           (tab-to-tab-stop))
606       (backward-sexp))))
607
608 (defun itimer-edit-delete-itimer ()
609   (interactive)
610   ;; First two lines in list buffer are headers.
611   ;; Cry out against the luser who attempts to change a field there.
612   (if (<= (point) itimer-edit-start-marker)
613       (error ""))
614   (delete-itimer
615    (read-itimer "Delete itimer: "
616                (save-excursion (beginning-of-line) (read (current-buffer)))))
617   ;; update list information
618   (list-itimers))
619
620 (defun itimer-edit-next-field (count)
621   (interactive "p")
622   (itimer-edit-beginning-of-field)
623   (cond ((> (itimer-signum count) 0)
624          (while (not (zerop count))
625            (forward-sexp)
626            ;; wrap from eob to itimer-edit-start-marker
627            (if (eobp)
628                (progn
629                  (goto-char itimer-edit-start-marker)
630                  (forward-sexp)))
631            (forward-sexp)
632            (backward-sexp)
633            ;; treat fields at beginning of line as if they weren't there.
634            (if (bolp)
635                (progn
636                  (forward-sexp 2)
637                  (backward-sexp)))
638            (itimer-decrement count)))
639         ((< (itimer-signum count) 0)
640          (while (not (zerop count))
641            (backward-sexp)
642            ;; treat fields at beginning of line as if they weren't there.
643            (if (bolp)
644                (backward-sexp))
645            ;; wrap from itimer-edit-start-marker to field at eob.
646            (if (<= (point) itimer-edit-start-marker)
647                (progn
648                  (goto-char (point-max))
649                  (backward-sexp)))
650            (itimer-increment count)))))
651
652 (defun itimer-edit-previous-field (count)
653   (interactive "p")
654   (itimer-edit-next-field (- count)))
655
656 (defun itimer-edit-beginning-of-field ()
657   (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point)))
658         (back (save-excursion (backward-sexp) (point))))
659     (cond ((eq forw-back back) (backward-sexp))
660           ((eq forw-back (point)) t)
661           (t (backward-sexp)))))
662
663 (defun itimer-truncate-string (str len)
664   (if (<= (length str) len)
665       str
666     (substring str 0 len)))
667 \f
668 ;; internals of the itimer implementation.
669
670 (defun itimer-run-expired-timers (time-elapsed)
671   (let ((itimers (copy-sequence itimer-list))
672         (itimer)
673         (next-wakeup 600)
674         (idle-time)
675         (last-event-time)
676         (recorded-run-time)
677         ;; process filters can be hit by stray C-g's from the user,
678         ;; so we must protect this stuff appropriately.
679         ;; Quit's are allowed from within itimer functions, but we
680         ;; catch them and print a message.
681         (inhibit-quit t))
682     (setq next-wakeup 600)
683     (cond ((and (boundp 'last-command-event-time)
684                 (consp last-command-event-time))
685            (setq last-event-time last-command-event-time
686                  idle-time (itimer-time-difference (current-time)
687                                                    last-event-time)))
688           ((and (boundp 'last-input-time) (consp last-input-time))
689            (setq last-event-time (list (car last-input-time)
690                                        (cdr last-input-time)
691                                        0)
692                  idle-time (itimer-time-difference (current-time)
693                                                    last-event-time)))
694           ;; no way to do this under FSF Emacs yet.
695           (t (setq last-event-time '(0 0 0)
696                    idle-time 0)))
697     (while itimers
698       (setq itimer (car itimers))
699       (if (itimer-is-idle itimer)
700           (setq recorded-run-time (itimer-recorded-run-time itimer))
701         (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer)
702                                                     time-elapsed))))
703       (if (if (itimer-is-idle itimer)
704               (or (> (itimer-time-difference recorded-run-time
705                                              last-event-time)
706                      0)
707                   (< idle-time (itimer-value itimer)))
708             (> (itimer-value itimer) 0))
709           (setq next-wakeup
710                 (if (itimer-is-idle itimer)
711                     (if (< idle-time (itimer-value itimer))
712                         (min next-wakeup (- (itimer-value itimer) idle-time))
713                       (min next-wakeup (itimer-value itimer)))
714                   (min next-wakeup (itimer-value itimer))))
715         (and (itimer-is-idle itimer)
716              (set-itimer-recorded-run-time itimer (current-time)))
717         ;; itimer has expired, we must call its function.
718         ;; protect our local vars from the itimer function.
719         ;; allow keyboard quit to occur, but catch and report it.
720         ;; provide the variable `current-itimer' in case the function
721         ;; is interested.
722         (unwind-protect
723             (condition-case condition-data
724                 (save-match-data
725                   ;; Suppress warnings - see comment below.
726                   (defvar last-event-time)
727                   (defvar next-wakeup)
728                   (defvar itimer)
729                   (defvar itimers)
730                   (defvar time-elapsed)
731                   (let* ((current-itimer itimer)
732                          (quit-flag nil)
733                          (inhibit-quit nil)
734                          ;; for FSF Emacs timer.el emulation under XEmacs.
735                          ;; eldoc expect this to be done, apparently.
736                          (this-command nil)
737                          ;; bind these variables so that the itimer
738                          ;; function can't screw with them.
739                          last-event-time next-wakeup
740                          itimer itimers time-elapsed)
741                     (if (itimer-uses-arguments current-itimer)
742                         (apply (itimer-function current-itimer)
743                                (itimer-function-arguments current-itimer))
744                       (funcall (itimer-function current-itimer)))))
745               (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer)
746                               (prin1-to-string condition-data)))
747               (quit (message "itimer \"%s\" quit" (itimer-name itimer))))
748           ;; restart the itimer if we should, otherwise delete it.
749           (if (null (itimer-restart itimer))
750               (delete-itimer itimer)
751             (set-itimer-value-internal itimer (itimer-restart itimer))
752             (setq next-wakeup (min next-wakeup (itimer-value itimer))))))
753       (setq itimers (cdr itimers)))
754     ;; make another sweep through the list to catch any timers
755     ;; that might have been added by timer functions above.
756     (setq itimers itimer-list)
757     (while itimers
758       (setq next-wakeup (min next-wakeup (itimer-value (car itimers)))
759             itimers (cdr itimers)))
760     ;; if user is viewing the timer list, update displayed info.
761     (let ((b (get-buffer "*Itimer List*")))
762       (if (and b (get-buffer-window b))
763           (save-excursion
764             (list-itimers))))
765     next-wakeup ))
766
767 (defun itimer-process-filter (process string)
768   ;; If the itimer process dies and generates output while doing
769   ;; so, we may be called before the process-sentinel.  Sanity
770   ;; check the output just in case...
771   (if (not (string-match "^[0-9]" string))
772       (progn (message "itimer process gave odd output: %s" string)
773              ;; it may be still alive and waiting for input
774              (process-send-string itimer-process "3\n"))
775     ;; if there are no active itimers, return quickly.
776     (if itimer-list
777         (let ((wakeup nil))
778           (unwind-protect
779               (setq wakeup (itimer-run-expired-timers (string-to-int string)))
780             (and (null wakeup) (process-send-string process "1\n")))
781           (setq itimer-next-wakeup wakeup))
782       (setq itimer-next-wakeup 600))
783     ;; tell itimer-process when to wakeup again
784     (process-send-string itimer-process
785                          (concat (int-to-string itimer-next-wakeup)
786                                  "\n"))))
787
788 (defun itimer-process-sentinel (process message)
789   (let ((inhibit-quit t))
790     (if (eq (process-status process) 'stop)
791         (continue-process process)
792       ;; not stopped, so it must have died.
793       ;; cleanup first...
794       (delete-process process)
795       (setq itimer-process nil)
796       ;; now, if there are any active itimers then we need to immediately
797       ;; start another itimer process, otherwise we can wait until the next
798       ;; start-itimer call, which will start one automatically.
799       (if (null itimer-list)
800           ()
801         ;; there may have been an error message in the echo area;
802         ;; give the user at least a little time to read it.
803         (sit-for 2)
804         (message "itimer process %s... respawning." (substring message 0 -1))
805         (itimer-process-start)))))
806
807 (defun itimer-process-start ()
808   (let ((inhibit-quit t)
809         (process-connection-type nil))
810     (setq itimer-process (start-process "itimer" nil "itimer"))
811     (process-kill-without-query itimer-process)
812     (set-process-filter itimer-process 'itimer-process-filter)
813     (set-process-sentinel itimer-process 'itimer-process-sentinel)
814     ;; Tell itimer process to wake up quickly, so that a correct
815     ;; wakeup time can be computed.  Zero loses because of
816     ;; underlying itimer implementations that use 0 to mean
817     ;; `disable the itimer'.
818     (setq itimer-next-wakeup itimer-short-interval)
819     (process-send-string itimer-process
820                          (format "%s\n" itimer-next-wakeup))))
821
822 (defun itimer-process-wakeup ()
823   (interrupt-process itimer-process)
824   (accept-process-output))
825
826 (defun itimer-timer-start ()
827   (let ((inhibit-quit t))
828     (setq itimer-next-wakeup itimer-short-interval
829           itimer-timer-last-wakeup (current-time)
830           itimer-timer (add-timeout itimer-short-interval
831                                     'itimer-timer-driver nil nil))))
832
833 (defun itimer-disable-timeout (timeout)
834   ;; Disgusting hack, but necessary because there is no other way
835   ;; to remove a timer that has a restart value from while that
836   ;; timer's function is being run.  (FSF Emacs only.)
837   (if (vectorp timeout)
838       (aset timeout 4 nil))
839   (disable-timeout timeout))
840
841 (defun itimer-timer-wakeup ()
842   (let ((inhibit-quit t))
843     (itimer-disable-timeout itimer-timer)
844     (setq itimer-timer (add-timeout itimer-short-interval
845                                     'itimer-timer-driver nil 5))))
846
847 (defun itimer-time-difference (t1 t2)
848   (let (usecs secs 65536-secs carry)
849     (setq usecs (- (nth 2 t1) (nth 2 t2)))
850     (if (< usecs 0)
851         (setq carry 1
852               usecs (+ usecs 1000000))
853       (setq carry 0))
854     (setq secs (- (nth 1 t1) (nth 1 t2) carry))
855     (if (< secs 0)
856          (setq carry 1
857                secs (+ secs 65536))
858       (setq carry 0))
859     (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry))
860     (+ (* 65536-secs 65536.0)
861        secs
862        (/ usecs 1000000.0))))
863
864 (defun itimer-timer-driver (&rest ignored)
865   ;; inhibit quit because if the user quits at an inopportune
866   ;; time, the timer process won't be launched again and the
867   ;; system stops working.  itimer-run-expired-timers allows
868   ;; individual timer function to be aborted, so the user can
869   ;; escape a feral timer function.
870   (if (not itimer-inside-driver)
871       (let* ((inhibit-quit t)
872              (itimer-inside-driver t)
873              (now (current-time))
874              (elapsed (itimer-time-difference now itimer-timer-last-wakeup))
875              (sleep nil))
876         (setq itimer-timer-last-wakeup now
877               sleep (itimer-run-expired-timers elapsed))
878         (itimer-disable-timeout itimer-timer)
879         (setq itimer-next-wakeup sleep
880               itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5)))))
881
882 (defun itimer-driver-start ()
883   (if (fboundp 'add-timeout)
884       (itimer-timer-start)
885     (itimer-process-start)))
886
887 (defun itimer-driver-wakeup ()
888   (if (fboundp 'add-timeout)
889       (itimer-timer-wakeup)
890     (itimer-process-wakeup)))