+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+
+;; This package gives you the capability to run Emacs Lisp commands at
+;; specified times in the future, either as one-shots or periodically.
+
+;;; Code:
+
+;; Layout of a timer vector:
+;; [triggered-p high-seconds low-seconds usecs repeat-delay
+;; function args idle-delay]
+
+(defun timer-create ()
+ "Create a timer object."
+ (let ((timer (make-vector 8 nil)))
+ (aset timer 0 t)
+ timer))
+
+(defun timerp (object)
+ "Return t if OBJECT is a timer."
+ (and (vectorp object) (= (length object) 8)))
+
+(defun timer-set-time (timer time &optional delta)
+ "Set the trigger time of TIMER to TIME.
+TIME must be in the internal format returned by, e.g., `current-time'.
+If optional third argument DELTA is a non-zero integer, make the timer
+fire repeatedly that many seconds apart."
+ (or (timerp timer)
+ (error "Invalid timer"))
+ (aset timer 1 (car time))
+ (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time)))
+ (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time)))
+ (nth 2 time))
+ 0))
+ (aset timer 4 (and (numberp delta) (> delta 0) delta))
+ timer)
+
+(defun timer-set-idle-time (timer secs &optional repeat)
+ "Set the trigger idle time of TIMER to SECS.
+If optional third argument REPEAT is non-nil, make the timer
+fire each time Emacs is idle for that many seconds."
+ (or (timerp timer)
+ (error "Invalid timer"))
+ (aset timer 1 0)
+ (aset timer 2 0)
+ (aset timer 3 0)
+ (timer-inc-time timer secs)
+ (aset timer 4 repeat)
+ timer)
+
+(defun timer-next-integral-multiple-of-time (time secs)
+ "Yield the next value after TIME that is an integral multiple of SECS.
+More precisely, the next value, after TIME, that is an integral multiple
+of SECS seconds since the epoch. SECS may be a fraction."
+ (let ((time-base (ash 1 16)))
+ (if (fboundp 'atan)
+ ;; Use floating point, taking care to not lose precision.
+ (let* ((float-time-base (float time-base))
+ (million 1000000.0)
+ (time-usec (+ (* million
+ (+ (* float-time-base (nth 0 time))
+ (nth 1 time)))
+ (nth 2 time)))
+ (secs-usec (* million secs))
+ (mod-usec (mod time-usec secs-usec))
+ (next-usec (+ (- time-usec mod-usec) secs-usec))
+ (time-base-million (* float-time-base million)))
+ (list (floor next-usec time-base-million)
+ (floor (mod next-usec time-base-million) million)
+ (floor (mod next-usec million))))
+ ;; Floating point is not supported.
+ ;; Use integer arithmetic, avoiding overflow if possible.
+ (let* ((mod-sec (mod (+ (* (mod time-base secs)
+ (mod (nth 0 time) secs))
+ (nth 1 time))
+ secs))
+ (next-1-sec (+ (- (nth 1 time) mod-sec) secs)))
+ (list (+ (nth 0 time) (floor next-1-sec time-base))
+ (mod next-1-sec time-base)
+ 0)))))
+
+(defun timer-relative-time (time secs &optional usecs)
+ "Advance TIME by SECS seconds and optionally USECS microseconds.
+SECS may be a fraction."
+ (let ((high (car time))
+ (low (if (consp (cdr time)) (nth 1 time) (cdr time)))
+ (micro (if (numberp (car-safe (cdr-safe (cdr time))))
+ (nth 2 time)
+ 0)))
+ ;; Add
+ (if usecs (setq micro (+ micro usecs)))
+ (if (floatp secs)
+ (setq micro (+ micro (floor (* 1000000 (- secs (floor secs)))))))
+ (setq low (+ low (floor secs)))
+
+ ;; Normalize
+ (setq low (+ low (/ micro 1000000)))
+ (setq micro (mod micro 1000000))
+ (setq high (+ high (/ low 65536)))
+ (setq low (logand low 65535))
+
+ (list high low (and (/= micro 0) micro))))
+
+(defun timer-inc-time (timer secs &optional usecs)
+ "Increment the time set in TIMER by SECS seconds and USECS microseconds.
+SECS may be a fraction."
+ (let ((time (timer-relative-time
+ (list (aref timer 1) (aref timer 2) (aref timer 3))
+ secs
+ usecs)))
+ (aset timer 1 (nth 0 time))
+ (aset timer 2 (nth 1 time))
+ (aset timer 3 (or (nth 2 time) 0))))
+
+(defun timer-set-time-with-usecs (timer time usecs &optional delta)
+ "Set the trigger time of TIMER to TIME.
+TIME must be in the internal format returned by, e.g., `current-time'.
+If optional third argument DELTA is a non-zero integer, make the timer
+fire repeatedly that many seconds apart."
+ (or (timerp timer)
+ (error "Invalid timer"))
+ (aset timer 1 (car time))
+ (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time)))
+ (aset timer 3 usecs)
+ (aset timer 4 (and (numberp delta) (> delta 0) delta))
+ timer)
+
+(defun timer-set-function (timer function &optional args)
+ "Make TIMER call FUNCTION with optional ARGS when triggering."
+ (or (timerp timer)
+ (error "Invalid timer"))
+ (aset timer 5 function)
+ (aset timer 6 args)
+ timer)
+\f
+(defun timer-activate (timer)
+ "Put TIMER on the list of active timers."
+ (if (and (timerp timer)
+ (integerp (aref timer 1))
+ (integerp (aref timer 2))
+ (integerp (aref timer 3))
+ (aref timer 5))
+ (let ((timers timer-list)
+ last)
+ ;; Skip all timers to trigger before the new one.
+ (while (and timers
+ (or (> (aref timer 1) (aref (car timers) 1))
+ (and (= (aref timer 1) (aref (car timers) 1))
+ (> (aref timer 2) (aref (car timers) 2)))
+ (and (= (aref timer 1) (aref (car timers) 1))
+ (= (aref timer 2) (aref (car timers) 2))
+ (> (aref timer 3) (aref (car timers) 3)))))
+ (setq last timers
+ timers (cdr timers)))
+ ;; Insert new timer after last which possibly means in front of queue.
+ (if last
+ (setcdr last (cons timer timers))
+ (setq timer-list (cons timer timers)))
+ (aset timer 0 nil)
+ (aset timer 7 nil)
+ nil)
+ (error "Invalid or uninitialized timer")))
+
+(defun timer-activate-when-idle (timer)
+ "Arrange to activate TIMER whenever Emacs is next idle."
+ (if (and (timerp timer)
+ (integerp (aref timer 1))
+ (integerp (aref timer 2))
+ (integerp (aref timer 3))
+ (aref timer 5))
+ (let ((timers timer-idle-list)
+ last)
+ ;; Skip all timers to trigger before the new one.
+ (while (and timers
+ (or (> (aref timer 1) (aref (car timers) 1))
+ (and (= (aref timer 1) (aref (car timers) 1))
+ (> (aref timer 2) (aref (car timers) 2)))
+ (and (= (aref timer 1) (aref (car timers) 1))
+ (= (aref timer 2) (aref (car timers) 2))
+ (> (aref timer 3) (aref (car timers) 3)))))
+ (setq last timers
+ timers (cdr timers)))
+ ;; Insert new timer after last which possibly means in front of queue.
+ (if last
+ (setcdr last (cons timer timers))
+ (setq timer-idle-list (cons timer timers)))
+ (aset timer 0 t)
+ (aset timer 7 t)
+ nil)
+ (error "Invalid or uninitialized timer")))
+
+;;;###autoload
+(defalias 'disable-timeout 'cancel-timer)
+;;;###autoload
+(defun cancel-timer (timer)
+ "Remove TIMER from the list of active timers."
+ (or (timerp timer)
+ (error "Invalid timer"))
+ (setq timer-list (delq timer timer-list))
+ (setq timer-idle-list (delq timer timer-idle-list))
+ nil)
+
+;;;###autoload
+(defun cancel-function-timers (function)
+ "Cancel all timers scheduled by `run-at-time' which would run FUNCTION."
+ (interactive "aCancel timers of function: ")
+ (let ((tail timer-list))
+ (while tail
+ (if (eq (aref (car tail) 5) function)
+ (setq timer-list (delq (car tail) timer-list)))
+ (setq tail (cdr tail))))
+ (let ((tail timer-idle-list))
+ (while tail
+ (if (eq (aref (car tail) 5) function)
+ (setq timer-idle-list (delq (car tail) timer-idle-list)))
+ (setq tail (cdr tail)))))
+\f
+;; Record the last few events, for debugging.
+(defvar timer-event-last-2 nil)
+(defvar timer-event-last-1 nil)
+(defvar timer-event-last nil)