Mercurial > hg > xemacs-beta
diff lisp/itimer.el @ 428:3ecd8885ac67 r21-2-22
Import from CVS: tag r21-2-22
author | cvs |
---|---|
date | Mon, 13 Aug 2007 11:28:15 +0200 |
parents | |
children | a5df635868b2 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/lisp/itimer.el Mon Aug 13 11:28:15 2007 +0200 @@ -0,0 +1,872 @@ +;;; Interval timers for GNU Emacs +;;; Copyright (C) 1988, 1991, 1993, 1997, 1998 Kyle E. Jones +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2, or (at your option) +;;; any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; A copy of the GNU General Public License can be obtained from this +;;; program's author (send electronic mail to kyle@uunet.uu.net) or from +;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA +;;; 02139, USA. +;;; +;;; Send bug reports to kyle_jones@wonderworks.com + +(provide 'itimer) + +;; `itimer' feature means Emacs-Lisp programmers get: +;; itimerp +;; itimer-live-p +;; itimer-value +;; itimer-restart +;; itimer-function +;; itimer-uses-arguments +;; itimer-function-arguments +;; set-itimer-value +;; set-itimer-restart +;; set-itimer-function +;; set-itimer-uses-arguments +;; set-itimer-function-arguments +;; get-itimer +;; start-itimer +;; read-itimer +;; delete-itimer +;; activate-itimer +;; +;; Interactive users get these commands: +;; edit-itimers +;; list-itimers +;; start-itimer +;; +;; See the doc strings of these functions for more information. + +(defvar itimer-version "1.07" + "Version number of the itimer package.") + +(defvar itimer-list nil + "List of all active itimers.") + +(defvar itimer-process nil + "Process that drives all itimers, if a subprocess is being used.") + +(defvar itimer-timer nil + "Emacs internal timer that drives the itimer system, if a subprocess +is not being used to drive the system.") + +(defvar itimer-timer-last-wakeup nil + "The time the timer driver function last ran.") + +(defvar itimer-short-interval (if (featurep 'lisp-float-type) 1e-3 1) + "Interval used for scheduling an event a very short time in the future. +Used internally to make the scheduler wake up early. +Unit is seconds.") + +;; This value is maintained internally; it does not determine +;; itimer granularity. Itimer granularity is 1 second if your +;; Emacs doesn't support floats or your system doesn't have a +;; clock with microsecond granularity. Otherwise granularity is +;; to the microsecond, although you can't possibly get timers to be +;; executed with this kind of accuracy in practice. There will +;; be delays due to system and Emacs internal activity that delay +;; dealing with synchronous events and process output. +(defvar itimer-next-wakeup itimer-short-interval + "Itimer process will wakeup to service running itimers within this +many seconds.") + +(defvar itimer-edit-map nil + "Keymap used when in Itimer Edit mode.") + +(if itimer-edit-map + () + (setq itimer-edit-map (make-sparse-keymap)) + (define-key itimer-edit-map "s" 'itimer-edit-set-field) + (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer) + (define-key itimer-edit-map "q" 'itimer-edit-quit) + (define-key itimer-edit-map "\t" 'itimer-edit-next-field) + (define-key itimer-edit-map " " 'next-line) + (define-key itimer-edit-map "n" 'next-line) + (define-key itimer-edit-map "p" 'previous-line) + (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field) + (define-key itimer-edit-map "x" 'start-itimer) + (define-key itimer-edit-map "?" 'itimer-edit-help)) + +(defvar itimer-inside-driver nil) + +(defvar itimer-edit-start-marker nil) + +;; macros must come first... or byte-compile'd code will throw back its +;; head and scream. + +(defmacro itimer-decrement (variable) + (list 'setq variable (list '1- variable))) + +(defmacro itimer-increment (variable) + (list 'setq variable (list '1+ variable))) + +(defmacro itimer-signum (n) + (list 'if (list '> n 0) 1 + (list 'if (list 'zerop n) 0 -1))) + +;; Itimer access functions should behave as if they were subrs. These +;; macros are used to check the arguments to the itimer functions and +;; signal errors appropriately if the arguments are not valid. + +(defmacro check-itimer (var) + "If VAR is not bound to an itimer, signal wrong-type-argument. +This is a macro." + (list 'setq var + (list 'if (list 'itimerp var) var + (list 'signal ''wrong-type-argument + (list 'list ''itimerp var))))) + +(defmacro check-itimer-coerce-string (var) + "If VAR is not bound to a string, look up the itimer that it names and +bind VAR to it. Otherwise, if VAR is not bound to an itimer, signal +wrong-type-argument. This is a macro." + (list 'setq var + (list 'cond + (list (list 'itimerp var) var) + (list (list 'stringp var) (list 'get-itimer var)) + (list t (list 'signal ''wrong-type-argument + (list 'list ''string-or-itimer-p var)))))) + +(defmacro check-nonnegative-number (var) + "If VAR is not bound to a number, signal wrong-type-argument. +If VAR is not bound to a positive number, signal args-out-of-range. +This is a macro." + (list 'setq var + (list 'if (list 'not (list 'numberp var)) + (list 'signal ''wrong-type-argument + (list 'list ''natnump var)) + (list 'if (list '< var 0) + (list 'signal ''args-out-of-range (list 'list var)) + var)))) + +(defmacro check-string (var) + "If VAR is not bound to a string, signal wrong-type-argument. +This is a macro." + (list 'setq var + (list 'if (list 'stringp var) var + (list 'signal ''wrong-type-argument + (list 'list ''stringp var))))) + +;; Functions to access and modify itimer attributes. + +(defun itimerp (obj) + "Return t if OBJ is an itimer." + (and (consp obj) (eq (length obj) 8))) + +(defun itimer-live-p (obj) + "Return non-nil if OBJ is an itimer and is active. +``Active'' means Emacs will run it when it expires. +`activate-timer' must be called on an itimer to make it active. +Itimers started with `start-itimer' are automatically active." + (and (itimerp obj) (memq obj itimer-list))) + +(defun itimer-name (itimer) + "Return the name of ITIMER." + (check-itimer itimer) + (car itimer)) + +(defun itimer-value (itimer) + "Return the number of seconds until ITIMER expires." + (check-itimer itimer) + (nth 1 itimer)) + +(defun itimer-restart (itimer) + "Return the value to which ITIMER will be set at restart. +Return nil if this itimer doesn't restart." + (check-itimer itimer) + (nth 2 itimer)) + +(defun itimer-function (itimer) + "Return the function of ITIMER. +This function is called each time ITIMER expires." + (check-itimer itimer) + (nth 3 itimer)) + +(defun itimer-is-idle (itimer) + "Return non-nil if ITIMER is an idle timer. +Normal timers expire after a set interval. Idle timers expire +only after Emacs has been idle for a specific interval. +``Idle'' means no command events occur within the interval." + (check-itimer itimer) + (nth 4 itimer)) + +(defun itimer-uses-arguments (itimer) + "Return non-nil if the function of ITIMER will be called with arguments. +ITIMER's function is called with the arguments each time ITIMER expires. +The arguments themselves are retrievable with `itimer-function-arguments'." + (check-itimer itimer) + (nth 5 itimer)) + +(defun itimer-function-arguments (itimer) + "Return the function arguments of ITIMER as a list. +ITIMER's function is called with these argument each time ITIMER expires." + (check-itimer itimer) + (nth 6 itimer)) + +(defun itimer-recorded-run-time (itimer) + (check-itimer itimer) + (nth 7 itimer)) + +(defun set-itimer-value (itimer value) + "Set the timeout value of ITIMER to be VALUE. +Itimer will expire in this many seconds. +If your version of Emacs supports floating point numbers then +VALUE can be a floating point number. Otherwise it +must be an integer. +Returns VALUE." + (check-itimer itimer) + (check-nonnegative-number value) + (let ((inhibit-quit t)) + ;; If the itimer is in the active list, and under the new + ;; timeout value would expire before we would normally + ;; wakeup, wakeup now and recompute a new wakeup time. + (or (and (< value itimer-next-wakeup) + (and (itimer-name itimer) (get-itimer (itimer-name itimer))) + (progn (itimer-driver-wakeup) + (setcar (cdr itimer) value) + (itimer-driver-wakeup) + t )) + (setcar (cdr itimer) value)) + value)) + +;; Same as set-itimer-value but does not wakeup the driver. +;; Only should be used by the drivers when processing expired timers. +(defun set-itimer-value-internal (itimer value) + (check-itimer itimer) + (check-nonnegative-number value) + (setcar (cdr itimer) value)) + +(defun set-itimer-restart (itimer restart) + "Set the restart value of ITIMER to be RESTART. +If RESTART is nil, ITIMER will not restart when it expires. +If your version of Emacs supports floating point numbers then +RESTART can be a floating point number. Otherwise it +must be an integer. +Returns RESTART." + (check-itimer itimer) + (if restart (check-nonnegative-number restart)) + (setcar (cdr (cdr itimer)) restart)) + +(defun set-itimer-function (itimer function) + "Set the function of ITIMER to be FUNCTION. +FUNCTION will be called when itimer expires. +Returns FUNCTION." + (check-itimer itimer) + (setcar (nthcdr 3 itimer) function)) + +(defun set-itimer-is-idle (itimer flag) + "Set flag that says whether ITIMER is an idle timer. +If FLAG is non-nil, then ITIMER will be considered an idle timer. +Returns FLAG." + (check-itimer itimer) + (setcar (nthcdr 4 itimer) flag)) + +(defun set-itimer-uses-arguments (itimer flag) + "Set flag that says whether the function of ITIMER is called with arguments. +If FLAG is non-nil, then the function will be called with one argument, +otherwise the function will be called with no arguments. +Returns FLAG." + (check-itimer itimer) + (setcar (nthcdr 5 itimer) flag)) + +(defun set-itimer-function-arguments (itimer &optional arguments) + "Set the function arguments of ITIMER to be ARGUMENTS. +The function of ITIMER will be called with ARGUMENTS when itimer expires. +Returns ARGUMENTS." + (check-itimer itimer) + (setcar (nthcdr 6 itimer) arguments)) + +(defun set-itimer-recorded-run-time (itimer time) + (check-itimer itimer) + (setcar (nthcdr 7 itimer) time)) + +(defun get-itimer (name) + "Return itimer named NAME, or nil if there is none." + (check-string name) + (assoc name itimer-list)) + +(defun read-itimer (prompt &optional initial-input) + "Read the name of an itimer from the minibuffer and return the itimer +associated with that name. The user is prompted with PROMPT. +Optional second arg INITIAL-INPUT non-nil is inserted into the +minibuffer as initial user input." + (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input))) + +(defun delete-itimer (itimer) + "Delete ITIMER. ITIMER may be an itimer or the name of one." + (check-itimer-coerce-string itimer) + (setq itimer-list (delq itimer itimer-list))) + +(defun start-itimer (name function value &optional restart + is-idle with-args &rest function-arguments) + "Start an itimer. +Arguments are + NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS. +NAME is an identifier for the itimer. It must be a string. If an itimer + already exists with this name, NAME will be modified slightly to make + it unique. +FUNCTION should be a function (or symbol naming one). It + will be called each time the itimer expires with arguments of + FUNCTION-ARGUMENTS. The function can access the itimer that + invoked it through the variable `current-itimer'. If WITH-ARGS + is nil then FUNCTION is called with no arguments. This is for + backward compatibility with older versions of the itimer + package which always called FUNCTION with no arguments. +VALUE is the number of seconds until this itimer expires. + If your version of Emacs supports floating point numbers then + VALUE can be a floating point number. Otherwise it + must be an integer. +Optional fourth arg RESTART non-nil means that this itimer should be + restarted automatically after its function is called. Normally an itimer + is deleted at expiration after its function has returned. + If non-nil, RESTART should be a number indicating the value at which + the itimer should be set at restart time. +Optional fifth arg IS-IDLE specifies if this is an idle timer. + Normal timers expire after a set interval. Idle timers expire + only after Emacs has been idle for specific interval. + ``Idle'' means no command events occur within the interval. +Returns the newly created itimer." + (interactive + (list (completing-read "Start itimer: " itimer-list) + (read (completing-read "Itimer function: " obarray 'fboundp)) + (let (value) + (while (or (not (numberp value)) (< value 0)) + (setq value (read-from-minibuffer "Itimer value: " nil nil t))) + value) + (let ((restart t)) + (while (and restart (or (not (numberp restart)) (< restart 0))) + (setq restart (read-from-minibuffer "Itimer restart: " + nil nil t))) + restart) + ;; hard to imagine the user specifying these interactively + nil + nil )) + (check-string name) + (check-nonnegative-number value) + (if restart (check-nonnegative-number restart)) + ;; Make proposed itimer name unique if it's not already. + (let ((oname name) + (num 2)) + (while (get-itimer name) + (setq name (format "%s<%d>" oname num)) + (itimer-increment num))) + (activate-itimer (list name value restart function is-idle + with-args function-arguments (list 0 0 0))) + (car itimer-list)) + +(defun make-itimer () + "Create an unactivated itimer. +The itimer will not begin running until activated with `activate-itimer'. +Set the itimer's expire interval with `set-itimer-value'. +Set the itimer's function interval with `set-itimer-function'. +Once this is done, the timer can be activated." + (list nil 0 nil 'ignore nil nil nil (list 0 0 0))) + +(defun activate-itimer (itimer) + "Activate ITIMER, which was previously created with `make-itimer'. +ITIMER will be added to the global list of running itimers, +its FUNCTION will be called when it expires, and so on." + (check-itimer itimer) + (if (memq itimer itimer-list) + (error "itimer already activated")) + (if (not (numberp (itimer-value itimer))) + (error "itimer timeout value not a number: %s" (itimer-value itimer))) + (if (<= (itimer-value itimer) 0) + (error "itimer timeout value not positive: %s" (itimer-value itimer))) + ;; If there's no itimer driver/process, start one now. + ;; Otherwise wake up the itimer driver so that seconds slept before + ;; the new itimer is created won't be counted against it. + (if (or itimer-process itimer-timer) + (itimer-driver-wakeup) + (itimer-driver-start)) + ;; Roll a unique name for the timer if it doesn't have a name + ;; already. + (if (not (stringp (car itimer))) + (let ((name "itimer-0") + (oname "itimer-") + (num 1)) + (while (get-itimer name) + (setq name (format "%s<%d>" oname num)) + (itimer-increment num)) + (setcar itimer name)) + ;; signal an error if the timer's name matches an already + ;; activated timer. + (if (get-itimer (itimer-name itimer)) + (error "itimer named \"%s\" already existing and activated" + (itimer-name itimer)))) + (let ((inhibit-quit t)) + ;; add the itimer to the global list + (setq itimer-list (cons itimer itimer-list)) + ;; If the itimer process is scheduled to wake up too late for + ;; the itimer we wake it up to calculate a correct wakeup + ;; value giving consideration to the newly added itimer. + (if (< (itimer-value itimer) itimer-next-wakeup) + (itimer-driver-wakeup)))) + +;; User level functions to list and modify existing itimers. +;; Itimer Edit major mode, and the editing commands thereof. + +(defun list-itimers () + "Pop up a buffer containing a list of all itimers. +The major mode of the buffer is Itimer Edit mode. This major mode provides +commands to manipulate itimers; see the documentation for +`itimer-edit-mode' for more information." + (interactive) + (let* ((buf (get-buffer-create "*Itimer List*")) + (opoint (point)) + (standard-output buf) + (itimers (reverse itimer-list))) + (set-buffer buf) + (itimer-edit-mode) + (setq buffer-read-only nil) + (erase-buffer) + (insert +"Name Value Restart Function Idle Arguments" +"\n" +"---- ----- ------- -------- ---- --------") + (if (null itimer-edit-start-marker) + (setq itimer-edit-start-marker (point))) + (while itimers + (newline 1) + (prin1 (itimer-name (car itimers))) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%5.5s" (itimer-value (car itimers))) 5)) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%5.5s" (itimer-restart (car itimers))) 5)) + (tab-to-tab-stop) + (insert (itimer-truncate-string + (format "%.19s" (itimer-function (car itimers))) 19)) + (tab-to-tab-stop) + (if (itimer-is-idle (car itimers)) + (insert "yes") + (insert "no")) + (tab-to-tab-stop) + (if (itimer-uses-arguments (car itimers)) + (prin1 (itimer-function-arguments (car itimers))) + (prin1 'NONE)) + (setq itimers (cdr itimers))) + ;; restore point + (goto-char opoint) + (if (< (point) itimer-edit-start-marker) + (goto-char itimer-edit-start-marker)) + (setq buffer-read-only t) + (display-buffer buf))) + +(defun edit-itimers () + "Display a list of all itimers and select it for editing. +The major mode of the buffer containing the listing is Itimer Edit mode. +This major mode provides commands to manipulate itimers; see the documentation +for `itimer-edit-mode' for more information." + (interactive) + ;; since user is editing, make sure displayed data is reasonably up-to-date + (if (or itimer-process itimer-timer) + (itimer-driver-wakeup)) + (list-itimers) + (select-window (get-buffer-window "*Itimer List*")) + (goto-char itimer-edit-start-marker) + (if itimer-list + (progn + (forward-sexp 2) + (backward-sexp))) + (message "type q to quit, ? for help")) + +;; no point in making this interactive. +(defun itimer-edit-mode () + "Major mode for manipulating itimers. +Attributes of running itimers are changed by moving the cursor to the +desired field and typing `s' to set that field. The field will then be +set to the value read from the minibuffer. + +Commands: +TAB move forward a field +DEL move backward a field +s set a field +d delete the selected itimer +x start a new itimer +? help" + (kill-all-local-variables) + (make-local-variable 'tab-stop-list) + (setq major-mode 'itimer-edit-mode + mode-name "Itimer Edit" + truncate-lines t + tab-stop-list '(22 32 40 60 67)) + (abbrev-mode 0) + (auto-fill-mode 0) + (buffer-flush-undo (current-buffer)) + (use-local-map itimer-edit-map) + (set-syntax-table emacs-lisp-mode-syntax-table)) + +(put 'itimer-edit-mode 'mode-class 'special) + +(defun itimer-edit-help () + "Help function for Itimer Edit." + (interactive) + (if (eq last-command 'itimer-edit-help) + (describe-mode) + (message "TAB, DEL select fields, (s)et field, (d)elete itimer (type ? for more help)"))) + +(defun itimer-edit-quit () + "End Itimer Edit." + (interactive) + (bury-buffer (current-buffer)) + (if (one-window-p t) + (switch-to-buffer (other-buffer (current-buffer))) + (delete-window))) + +(defun itimer-edit-set-field () + (interactive) + ;; First two lines in list buffer are headers. + ;; Cry out against the luser who attempts to change a field there. + (if (<= (point) itimer-edit-start-marker) + (error "")) + ;; field-value must be initialized to be something other than a + ;; number, symbol, or list. + (let (itimer field (field-value "")) + (setq itimer (save-excursion + ;; read the name of the itimer from the beginning of + ;; the current line. + (beginning-of-line) + (get-itimer (read (current-buffer)))) + field (save-excursion + (itimer-edit-beginning-of-field) + (let ((opoint (point)) + (n 0)) + ;; count the number of sexprs until we reach the cursor + ;; and use this info to determine which field the user + ;; wants to modify. + (beginning-of-line) + (while (and (>= opoint (point)) (< n 6)) + (forward-sexp 2) + (backward-sexp) + (itimer-increment n)) + (cond ((eq n 1) (error "Cannot change itimer name.")) + ((eq n 2) 'value) + ((eq n 3) 'restart) + ((eq n 4) 'function) + ((eq n 5) 'is-idle) + (t 'function-argument))))) + (cond ((eq field 'value) + (let ((prompt "Set itimer value: ")) + (while (not (natnump field-value)) + (setq field-value (read-from-minibuffer prompt nil nil t))))) + ((eq field 'restart) + (let ((prompt "Set itimer restart: ")) + (while (and field-value (not (natnump field-value))) + (setq field-value (read-from-minibuffer prompt nil nil t))))) + ((eq field 'function) + (let ((prompt "Set itimer function: ")) + (while (not (or (and (symbolp field-value) (fboundp field-value)) + (and (consp field-value) + (memq (car field-value) '(lambda macro))))) + (setq field-value + (read (completing-read prompt obarray 'fboundp nil)))))) + ((eq field 'is-idle) + (setq field-value (not (itimer-is-idle itimer)))) + ((eq field 'function-argument) + (let ((prompt "Set itimer function argument: ")) + (setq field-value (read-expression prompt)) + (cond ((not (listp field-value)) + (setq field-value (list field-value)))) + (if (null field-value) + (set-itimer-uses-arguments itimer nil) + (set-itimer-uses-arguments itimer t))))) + ;; set the itimer field + (funcall (intern (concat "set-itimer-" (symbol-name field))) + itimer field-value) + ;; move to beginning of field to be changed + (itimer-edit-beginning-of-field) + ;; modify the list buffer to reflect the change. + (let (buffer-read-only kill-ring) + (kill-sexp 1) + (kill-region (point) (progn (skip-chars-forward " \t") (point))) + (prin1 field-value (current-buffer)) + (if (not (eolp)) + (tab-to-tab-stop)) + (backward-sexp)))) + +(defun itimer-edit-delete-itimer () + (interactive) + ;; First two lines in list buffer are headers. + ;; Cry out against the luser who attempts to change a field there. + (if (<= (point) itimer-edit-start-marker) + (error "")) + (delete-itimer + (read-itimer "Delete itimer: " + (save-excursion (beginning-of-line) (read (current-buffer))))) + ;; update list information + (list-itimers)) + +(defun itimer-edit-next-field (count) + (interactive "p") + (itimer-edit-beginning-of-field) + (cond ((> (itimer-signum count) 0) + (while (not (zerop count)) + (forward-sexp) + ;; wrap from eob to itimer-edit-start-marker + (if (eobp) + (progn + (goto-char itimer-edit-start-marker) + (forward-sexp))) + (forward-sexp) + (backward-sexp) + ;; treat fields at beginning of line as if they weren't there. + (if (bolp) + (progn + (forward-sexp 2) + (backward-sexp))) + (itimer-decrement count))) + ((< (itimer-signum count) 0) + (while (not (zerop count)) + (backward-sexp) + ;; treat fields at beginning of line as if they weren't there. + (if (bolp) + (backward-sexp)) + ;; wrap from itimer-edit-start-marker to field at eob. + (if (<= (point) itimer-edit-start-marker) + (progn + (goto-char (point-max)) + (backward-sexp))) + (itimer-increment count))))) + +(defun itimer-edit-previous-field (count) + (interactive "p") + (itimer-edit-next-field (- count))) + +(defun itimer-edit-beginning-of-field () + (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point))) + (back (save-excursion (backward-sexp) (point)))) + (cond ((eq forw-back back) (backward-sexp)) + ((eq forw-back (point)) t) + (t (backward-sexp))))) + +(defun itimer-truncate-string (str len) + (if (<= (length str) len) + str + (substring str 0 len))) + +;; internals of the itimer implementation. + +(defun itimer-run-expired-timers (time-elapsed) + (let ((itimers (copy-sequence itimer-list)) + (itimer) + (next-wakeup 600) + (idle-time) + (last-event-time) + (recorded-run-time) + ;; process filters can be hit by stray C-g's from the user, + ;; so we must protect this stuff appropriately. + ;; Quit's are allowed from within itimer functions, but we + ;; catch them and print a message. + (inhibit-quit t)) + (setq next-wakeup 600) + (cond ((and (boundp 'last-command-event-time) + (consp 'last-command-event-time)) + (setq last-event-time last-command-event-time + idle-time (itimer-time-difference (current-time) + last-event-time))) + ((and (boundp 'last-input-time) (consp last-input-time)) + (setq last-event-time (list (car last-input-time) + (cdr last-input-time) + 0) + idle-time (itimer-time-difference (current-time) + last-event-time))) + ;; no way to do this under FSF Emacs yet. + (t (setq last-event-time '(0 0 0) + idle-time 0))) + (while itimers + (setq itimer (car itimers)) + (if (itimer-is-idle itimer) + (setq recorded-run-time (itimer-recorded-run-time itimer)) + (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer) + time-elapsed)))) + (if (if (itimer-is-idle itimer) + (or (> (itimer-time-difference recorded-run-time + last-event-time) + 0) + (< idle-time (itimer-value itimer))) + (> (itimer-value itimer) 0)) + (setq next-wakeup + (if (itimer-is-idle itimer) + (if (< idle-time (itimer-value itimer)) + (min next-wakeup (- (itimer-value itimer) idle-time)) + (min next-wakeup (itimer-value itimer))) + (min next-wakeup (itimer-value itimer)))) + (and (itimer-is-idle itimer) + (set-itimer-recorded-run-time itimer (current-time))) + ;; itimer has expired, we must call its function. + ;; protect our local vars from the itimer function. + ;; allow keyboard quit to occur, but catch and report it. + ;; provide the variable `current-itimer' in case the function + ;; is interested. + (unwind-protect + (condition-case condition-data + (save-match-data + (let* ((current-itimer itimer) + (quit-flag nil) + (inhibit-quit nil) + ;; for FSF Emacs timer.el emulation under XEmacs. + ;; eldoc expect this to be done, apparently. + (this-command nil)) + (if (itimer-uses-arguments current-itimer) + (apply (itimer-function current-itimer) + (itimer-function-arguments current-itimer)) + (funcall (itimer-function current-itimer))))) + (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer) + (prin1-to-string condition-data))) + (quit (message "itimer \"%s\" quit" (itimer-name itimer)))) + ;; restart the itimer if we should, otherwise delete it. + (if (null (itimer-restart itimer)) + (delete-itimer itimer) + (set-itimer-value-internal itimer (itimer-restart itimer)) + (setq next-wakeup (min next-wakeup (itimer-value itimer)))))) + (setq itimers (cdr itimers))) + ;; make another sweep through the list to catch any timers + ;; that might have been added by timer functions above. + (setq itimers itimer-list) + (while itimers + (setq next-wakeup (min next-wakeup (itimer-value (car itimers))) + itimers (cdr itimers))) + ;; if user is viewing the timer list, update displayed info. + (let ((b (get-buffer "*Itimer List*"))) + (if (and b (get-buffer-window b)) + (save-excursion + (list-itimers)))) + next-wakeup )) + +(defun itimer-process-filter (process string) + ;; If the itimer process dies and generates output while doing + ;; so, we may be called before the process-sentinel. Sanity + ;; check the output just in case... + (if (not (string-match "^[0-9]" string)) + (progn (message "itimer process gave odd output: %s" string) + ;; it may be still alive and waiting for input + (process-send-string itimer-process "3\n")) + ;; if there are no active itimers, return quickly. + (if itimer-list + (let ((wakeup nil)) + (unwind-protect + (setq wakeup (itimer-run-expired-timers (string-to-int string))) + (and (null wakeup) (process-send-string process "1\n"))) + (setq itimer-next-wakeup wakeup)) + (setq itimer-next-wakeup 600)) + ;; tell itimer-process when to wakeup again + (process-send-string itimer-process + (concat (int-to-string itimer-next-wakeup) + "\n")))) + +(defun itimer-process-sentinel (process message) + (let ((inhibit-quit t)) + (if (eq (process-status process) 'stop) + (continue-process process) + ;; not stopped, so it must have died. + ;; cleanup first... + (delete-process process) + (setq itimer-process nil) + ;; now, if there are any active itimers then we need to immediately + ;; start another itimer process, otherwise we can wait until the next + ;; start-itimer call, which will start one automatically. + (if (null itimer-list) + () + ;; there may have been an error message in the echo area; + ;; give the user at least a little time to read it. + (sit-for 2) + (message "itimer process %s... respawning." (substring message 0 -1)) + (itimer-process-start))))) + +(defun itimer-process-start () + (let ((inhibit-quit t) + (process-connection-type nil)) + (setq itimer-process (start-process "itimer" nil "itimer")) + (process-kill-without-query itimer-process) + (set-process-filter itimer-process 'itimer-process-filter) + (set-process-sentinel itimer-process 'itimer-process-sentinel) + ;; Tell itimer process to wake up quickly, so that a correct + ;; wakeup time can be computed. Zero loses because of + ;; underlying itimer implementations that use 0 to mean + ;; `disable the itimer'. + (setq itimer-next-wakeup itimer-short-interval) + (process-send-string itimer-process + (format "%s\n" itimer-next-wakeup)))) + +(defun itimer-process-wakeup () + (interrupt-process itimer-process) + (accept-process-output)) + +(defun itimer-timer-start () + (let ((inhibit-quit t)) + (setq itimer-next-wakeup itimer-short-interval + itimer-timer-last-wakeup (current-time) + itimer-timer (add-timeout itimer-short-interval + 'itimer-timer-driver nil nil)))) + +(defun itimer-disable-timeout (timeout) + ;; Disgusting hack, but necessary because there is no other way + ;; to remove a timer that has a restart value from while that + ;; timer's function is being run. (FSF Emacs only.) + (if (vectorp timeout) + (aset timeout 4 nil)) + (disable-timeout timeout)) + +(defun itimer-timer-wakeup () + (let ((inhibit-quit t)) + (itimer-disable-timeout itimer-timer) + (setq itimer-timer (add-timeout itimer-short-interval + 'itimer-timer-driver nil 5)))) + +(defun itimer-time-difference (t1 t2) + (let (usecs secs 65536-secs carry) + (setq usecs (- (nth 2 t1) (nth 2 t2))) + (if (< usecs 0) + (setq carry 1 + usecs (+ usecs 1000000)) + (setq carry 0)) + (setq secs (- (nth 1 t1) (nth 1 t2) carry)) + (if (< secs 0) + (setq carry 1 + secs (+ secs 65536)) + (setq carry 0)) + (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry)) + ;; loses for interval larger than the maximum signed Lisp integer. + ;; can't really be helped. + (+ (* 65536-secs 65536) + secs + (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) + +(defun itimer-timer-driver (&rest ignored) + ;; inhibit quit because if the user quits at an inopportune + ;; time, the timer process won't be launched again and the + ;; system stops working. itimer-run-expired-timers allows + ;; individual timer function to be aborted, so the user can + ;; escape a feral timer function. + (if (not itimer-inside-driver) + (let* ((inhibit-quit t) + (itimer-inside-driver t) + (now (current-time)) + (elapsed (itimer-time-difference now itimer-timer-last-wakeup)) + (sleep nil)) + (setq itimer-timer-last-wakeup now + sleep (itimer-run-expired-timers elapsed)) + (itimer-disable-timeout itimer-timer) + (setq itimer-next-wakeup sleep + itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5))))) + +(defun itimer-driver-start () + (if (fboundp 'add-timeout) + (itimer-timer-start) + (itimer-process-start))) + +(defun itimer-driver-wakeup () + (if (fboundp 'add-timeout) + (itimer-timer-wakeup) + (itimer-process-wakeup)))