1;;; timer.el --- run a function with args at some time in future 2 3;; Copyright (C) 1996, 2001, 2002, 2003, 2004, 2005, 4;; 2006, 2007 Free Software Foundation, Inc. 5 6;; Maintainer: FSF 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to the 22;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 23;; Boston, MA 02110-1301, USA. 24 25;;; Commentary: 26 27;; This package gives you the capability to run Emacs Lisp commands at 28;; specified times in the future, either as one-shots or periodically. 29 30;;; Code: 31 32;; Layout of a timer vector: 33;; [triggered-p high-seconds low-seconds usecs repeat-delay 34;; function args idle-delay] 35;; triggered-p is nil if the timer is active (waiting to be triggered), 36;; t if it is inactive ("already triggered", in theory) 37 38(defun timer-create () 39 "Create a timer object which can be passed to `timer-activate'." 40 (let ((timer (make-vector 8 nil))) 41 (aset timer 0 t) 42 timer)) 43 44(defun timerp (object) 45 "Return t if OBJECT is a timer." 46 (and (vectorp object) (= (length object) 8))) 47 48(defun timer-set-time (timer time &optional delta) 49 "Set the trigger time of TIMER to TIME. 50TIME must be in the internal format returned by, e.g., `current-time'. 51If optional third argument DELTA is a positive number, make the timer 52fire repeatedly that many seconds apart." 53 (or (timerp timer) 54 (error "Invalid timer")) 55 (aset timer 1 (car time)) 56 (aset timer 2 (if (consp (cdr time)) (car (cdr time)) (cdr time))) 57 (aset timer 3 (or (and (consp (cdr time)) (consp (cdr (cdr time))) 58 (nth 2 time)) 59 0)) 60 (aset timer 4 (and (numberp delta) (> delta 0) delta)) 61 timer) 62 63(defun timer-set-idle-time (timer secs &optional repeat) 64 "Set the trigger idle time of TIMER to SECS. 65SECS may be an integer, floating point number, or the internal 66time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'. 67If optional third argument REPEAT is non-nil, make the timer 68fire each time Emacs is idle for that many seconds." 69 (or (timerp timer) 70 (error "Invalid timer")) 71 (if (consp secs) 72 (progn (aset timer 1 (car secs)) 73 (aset timer 2 (if (consp (cdr secs)) (car (cdr secs)) (cdr secs))) 74 (aset timer 3 (or (and (consp (cdr secs)) (consp (cdr (cdr secs))) 75 (nth 2 secs)) 76 0))) 77 (aset timer 1 0) 78 (aset timer 2 0) 79 (aset timer 3 0) 80 (timer-inc-time timer secs)) 81 (aset timer 4 repeat) 82 timer) 83 84(defun timer-next-integral-multiple-of-time (time secs) 85 "Yield the next value after TIME that is an integral multiple of SECS. 86More precisely, the next value, after TIME, that is an integral multiple 87of SECS seconds since the epoch. SECS may be a fraction." 88 (let ((time-base (ash 1 16))) 89 (if (fboundp 'atan) 90 ;; Use floating point, taking care to not lose precision. 91 (let* ((float-time-base (float time-base)) 92 (million 1000000.0) 93 (time-usec (+ (* million 94 (+ (* float-time-base (nth 0 time)) 95 (nth 1 time))) 96 (nth 2 time))) 97 (secs-usec (* million secs)) 98 (mod-usec (mod time-usec secs-usec)) 99 (next-usec (+ (- time-usec mod-usec) secs-usec)) 100 (time-base-million (* float-time-base million))) 101 (list (floor next-usec time-base-million) 102 (floor (mod next-usec time-base-million) million) 103 (floor (mod next-usec million)))) 104 ;; Floating point is not supported. 105 ;; Use integer arithmetic, avoiding overflow if possible. 106 (let* ((mod-sec (mod (+ (* (mod time-base secs) 107 (mod (nth 0 time) secs)) 108 (nth 1 time)) 109 secs)) 110 (next-1-sec (+ (- (nth 1 time) mod-sec) secs))) 111 (list (+ (nth 0 time) (floor next-1-sec time-base)) 112 (mod next-1-sec time-base) 113 0))))) 114 115(defun timer-relative-time (time secs &optional usecs) 116 "Advance TIME by SECS seconds and optionally USECS microseconds. 117SECS may be either an integer or a floating point number." 118 (let ((high (car time)) 119 (low (if (consp (cdr time)) (nth 1 time) (cdr time))) 120 (micro (if (numberp (car-safe (cdr-safe (cdr time)))) 121 (nth 2 time) 122 0))) 123 ;; Add 124 (if usecs (setq micro (+ micro usecs))) 125 (if (floatp secs) 126 (setq micro (+ micro (floor (* 1000000 (- secs (floor secs))))))) 127 (setq low (+ low (floor secs))) 128 129 ;; Normalize 130 ;; `/' rounds towards zero while `mod' returns a positive number, 131 ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))). 132 (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0))) 133 (setq micro (mod micro 1000000)) 134 (setq high (+ high (/ low 65536) (if (< low 0) -1 0))) 135 (setq low (logand low 65535)) 136 137 (list high low (and (/= micro 0) micro)))) 138 139(defun timer-inc-time (timer secs &optional usecs) 140 "Increment the time set in TIMER by SECS seconds and USECS microseconds. 141SECS may be a fraction. If USECS is omitted, that means it is zero." 142 (let ((time (timer-relative-time 143 (list (aref timer 1) (aref timer 2) (aref timer 3)) 144 secs 145 usecs))) 146 (aset timer 1 (nth 0 time)) 147 (aset timer 2 (nth 1 time)) 148 (aset timer 3 (or (nth 2 time) 0)))) 149 150(defun timer-set-time-with-usecs (timer time usecs &optional delta) 151 "Set the trigger time of TIMER to TIME plus USECS. 152TIME must be in the internal format returned by, e.g., `current-time'. 153The microsecond count from TIME is ignored, and USECS is used instead. 154If optional fourth argument DELTA is a positive number, make the timer 155fire repeatedly that many seconds apart." 156 (or (timerp timer) 157 (error "Invalid timer")) 158 (aset timer 1 (nth 0 time)) 159 (aset timer 2 (nth 1 time)) 160 (aset timer 3 usecs) 161 (aset timer 4 (and (numberp delta) (> delta 0) delta)) 162 timer) 163(make-obsolete 'timer-set-time-with-usecs 164 "use `timer-set-time' and `timer-inc-time' instead." 165 "22.1") 166 167(defun timer-set-function (timer function &optional args) 168 "Make TIMER call FUNCTION with optional ARGS when triggering." 169 (or (timerp timer) 170 (error "Invalid timer")) 171 (aset timer 5 function) 172 (aset timer 6 args) 173 timer) 174 175(defun timer-activate (timer &optional triggered-p reuse-cell) 176 "Put TIMER on the list of active timers. 177 178If TRIGGERED-P is t, that means to make the timer inactive 179\(put it on the list, but mark it as already triggered). 180To remove from the list, use `cancel-timer'. 181 182REUSE-CELL, if non-nil, is a cons cell to reuse instead 183of allocating a new one." 184 (if (and (timerp timer) 185 (integerp (aref timer 1)) 186 (integerp (aref timer 2)) 187 (integerp (aref timer 3)) 188 (aref timer 5)) 189 (let ((timers timer-list) 190 last) 191 ;; Skip all timers to trigger before the new one. 192 (while (and timers 193 (or (> (aref timer 1) (aref (car timers) 1)) 194 (and (= (aref timer 1) (aref (car timers) 1)) 195 (> (aref timer 2) (aref (car timers) 2))) 196 (and (= (aref timer 1) (aref (car timers) 1)) 197 (= (aref timer 2) (aref (car timers) 2)) 198 (> (aref timer 3) (aref (car timers) 3))))) 199 (setq last timers 200 timers (cdr timers))) 201 (if reuse-cell 202 (progn 203 (setcar reuse-cell timer) 204 (setcdr reuse-cell timers)) 205 (setq reuse-cell (cons timer timers))) 206 ;; Insert new timer after last which possibly means in front of queue. 207 (if last 208 (setcdr last reuse-cell) 209 (setq timer-list reuse-cell)) 210 (aset timer 0 triggered-p) 211 (aset timer 7 nil) 212 nil) 213 (error "Invalid or uninitialized timer"))) 214 215(defun timer-activate-when-idle (timer &optional dont-wait reuse-cell) 216 "Arrange to activate TIMER whenever Emacs is next idle. 217If optional argument DONT-WAIT is non-nil, then enable the 218timer to activate immediately, or at the right time, if Emacs 219is already idle. 220 221REUSE-CELL, if non-nil, is a cons cell to reuse instead 222of allocating a new one." 223 (if (and (timerp timer) 224 (integerp (aref timer 1)) 225 (integerp (aref timer 2)) 226 (integerp (aref timer 3)) 227 (aref timer 5)) 228 (let ((timers timer-idle-list) 229 last) 230 ;; Skip all timers to trigger before the new one. 231 (while (and timers 232 (or (> (aref timer 1) (aref (car timers) 1)) 233 (and (= (aref timer 1) (aref (car timers) 1)) 234 (> (aref timer 2) (aref (car timers) 2))) 235 (and (= (aref timer 1) (aref (car timers) 1)) 236 (= (aref timer 2) (aref (car timers) 2)) 237 (> (aref timer 3) (aref (car timers) 3))))) 238 (setq last timers 239 timers (cdr timers))) 240 (if reuse-cell 241 (progn 242 (setcar reuse-cell timer) 243 (setcdr reuse-cell timers)) 244 (setq reuse-cell (cons timer timers))) 245 ;; Insert new timer after last which possibly means in front of queue. 246 (if last 247 (setcdr last reuse-cell) 248 (setq timer-idle-list reuse-cell)) 249 (aset timer 0 (not dont-wait)) 250 (aset timer 7 t) 251 nil) 252 (error "Invalid or uninitialized timer"))) 253 254;;;###autoload 255(defalias 'disable-timeout 'cancel-timer) 256;;;###autoload 257(defun cancel-timer (timer) 258 "Remove TIMER from the list of active timers." 259 (or (timerp timer) 260 (error "Invalid timer")) 261 (setq timer-list (delq timer timer-list)) 262 (setq timer-idle-list (delq timer timer-idle-list)) 263 nil) 264 265(defun cancel-timer-internal (timer) 266 "Remove TIMER from the list of active timers or idle timers. 267Only to be used in this file. It returns the cons cell 268that was removed from the timer list." 269 (let ((cell1 (memq timer timer-list)) 270 (cell2 (memq timer timer-idle-list))) 271 (if cell1 272 (setq timer-list (delq timer timer-list))) 273 (if cell2 274 (setq timer-idle-list (delq timer timer-idle-list))) 275 (or cell1 cell2))) 276 277;;;###autoload 278(defun cancel-function-timers (function) 279 "Cancel all timers which would run FUNCTION. 280This affects ordinary timers such as are scheduled by `run-at-time', 281and idle timers such as are scheduled by `run-with-idle-timer'." 282 (interactive "aCancel timers of function: ") 283 (let ((tail timer-list)) 284 (while tail 285 (if (eq (aref (car tail) 5) function) 286 (setq timer-list (delq (car tail) timer-list))) 287 (setq tail (cdr tail)))) 288 (let ((tail timer-idle-list)) 289 (while tail 290 (if (eq (aref (car tail) 5) function) 291 (setq timer-idle-list (delq (car tail) timer-idle-list))) 292 (setq tail (cdr tail))))) 293 294;; Record the last few events, for debugging. 295(defvar timer-event-last nil 296 "Last timer that was run.") 297(defvar timer-event-last-1 nil 298 "Next-to-last timer that was run.") 299(defvar timer-event-last-2 nil 300 "Third-to-last timer that was run.") 301 302(defvar timer-max-repeats 10 303 "*Maximum number of times to repeat a timer, if many repeats are delayed. 304Timer invocations can be delayed because Emacs is suspended or busy, 305or because the system's time changes. If such an occurrence makes it 306appear that many invocations are overdue, this variable controls 307how many will really happen.") 308 309(defun timer-until (timer time) 310 "Calculate number of seconds from when TIMER will run, until TIME. 311TIMER is a timer, and stands for the time when its next repeat is scheduled. 312TIME is a time-list." 313 (let ((high (- (car time) (aref timer 1))) 314 (low (- (nth 1 time) (aref timer 2)))) 315 (+ low (* high 65536)))) 316 317(defun timer-event-handler (timer) 318 "Call the handler for the timer TIMER. 319This function is called, by name, directly by the C code." 320 (setq timer-event-last-2 timer-event-last-1) 321 (setq timer-event-last-1 timer-event-last) 322 (setq timer-event-last timer) 323 (let ((inhibit-quit t)) 324 (if (timerp timer) 325 (let (retrigger cell) 326 ;; Delete from queue. Record the cons cell that was used. 327 (setq cell (cancel-timer-internal timer)) 328 ;; Re-schedule if requested. 329 (if (aref timer 4) 330 (if (aref timer 7) 331 (timer-activate-when-idle timer nil cell) 332 (timer-inc-time timer (aref timer 4) 0) 333 ;; If real time has jumped forward, 334 ;; perhaps because Emacs was suspended for a long time, 335 ;; limit how many times things get repeated. 336 (if (and (numberp timer-max-repeats) 337 (< 0 (timer-until timer (current-time)))) 338 (let ((repeats (/ (timer-until timer (current-time)) 339 (aref timer 4)))) 340 (if (> repeats timer-max-repeats) 341 (timer-inc-time timer (* (aref timer 4) repeats))))) 342 (timer-activate timer t cell) 343 (setq retrigger t))) 344 ;; Run handler. 345 ;; We do this after rescheduling so that the handler function 346 ;; can cancel its own timer successfully with cancel-timer. 347 (condition-case nil 348 (apply (aref timer 5) (aref timer 6)) 349 (error nil)) 350 (if retrigger 351 (aset timer 0 nil))) 352 (error "Bogus timer event")))) 353 354;; This function is incompatible with the one in levents.el. 355(defun timeout-event-p (event) 356 "Non-nil if EVENT is a timeout event." 357 (and (listp event) (eq (car event) 'timer-event))) 358 359;;;###autoload 360(defun run-at-time (time repeat function &rest args) 361 "Perform an action at time TIME. 362Repeat the action every REPEAT seconds, if REPEAT is non-nil. 363TIME should be one of: a string giving an absolute time like 364\"11:23pm\" (the acceptable formats are those recognized by 365`diary-entry-time'; note that such times are interpreted as times 366today, even if in the past); a string giving a relative time like 367\"2 hours 35 minutes\" (the acceptable formats are those 368recognized by `timer-duration'); nil meaning now; a number of 369seconds from now; a value from `encode-time'; or t (with non-nil 370REPEAT) meaning the next integral multiple of REPEAT. REPEAT may 371be an integer or floating point number. The action is to call 372FUNCTION with arguments ARGS. 373 374This function returns a timer object which you can use in `cancel-timer'." 375 (interactive "sRun at time: \nNRepeat interval: \naFunction: ") 376 377 (or (null repeat) 378 (and (numberp repeat) (< 0 repeat)) 379 (error "Invalid repetition interval")) 380 381 ;; Special case: nil means "now" and is useful when repeating. 382 (if (null time) 383 (setq time (current-time))) 384 385 ;; Special case: t means the next integral multiple of REPEAT. 386 (if (and (eq time t) repeat) 387 (setq time (timer-next-integral-multiple-of-time (current-time) repeat))) 388 389 ;; Handle numbers as relative times in seconds. 390 (if (numberp time) 391 (setq time (timer-relative-time (current-time) time))) 392 393 ;; Handle relative times like "2 hours 35 minutes" 394 (if (stringp time) 395 (let ((secs (timer-duration time))) 396 (if secs 397 (setq time (timer-relative-time (current-time) secs))))) 398 399 ;; Handle "11:23pm" and the like. Interpret it as meaning today 400 ;; which admittedly is rather stupid if we have passed that time 401 ;; already. (Though only Emacs hackers hack Emacs at that time.) 402 (if (stringp time) 403 (progn 404 (require 'diary-lib) 405 (let ((hhmm (diary-entry-time time)) 406 (now (decode-time))) 407 (if (>= hhmm 0) 408 (setq time 409 (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) 410 (nth 4 now) (nth 5 now) (nth 8 now))))))) 411 412 (or (consp time) 413 (error "Invalid time format")) 414 415 (let ((timer (timer-create))) 416 (timer-set-time timer time repeat) 417 (timer-set-function timer function args) 418 (timer-activate timer) 419 timer)) 420 421;;;###autoload 422(defun run-with-timer (secs repeat function &rest args) 423 "Perform an action after a delay of SECS seconds. 424Repeat the action every REPEAT seconds, if REPEAT is non-nil. 425SECS and REPEAT may be integers or floating point numbers. 426The action is to call FUNCTION with arguments ARGS. 427 428This function returns a timer object which you can use in `cancel-timer'." 429 (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") 430 (apply 'run-at-time secs repeat function args)) 431 432;;;###autoload 433(defun add-timeout (secs function object &optional repeat) 434 "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. 435If REPEAT is non-nil, repeat the timer every REPEAT seconds. 436This function is for compatibility; see also `run-with-timer'." 437 (run-with-timer secs repeat function object)) 438 439;;;###autoload 440(defun run-with-idle-timer (secs repeat function &rest args) 441 "Perform an action the next time Emacs is idle for SECS seconds. 442The action is to call FUNCTION with arguments ARGS. 443SECS may be an integer, a floating point number, or the internal 444time format (HIGH LOW USECS) returned by, e.g., `current-idle-time'. 445If Emacs is currently idle, and has been idle for N seconds (N < SECS), 446then it will call FUNCTION in SECS - N seconds from now. 447 448If REPEAT is non-nil, do the action each time Emacs has been idle for 449exactly SECS seconds (that is, only once for each time Emacs becomes idle). 450 451This function returns a timer object which you can use in `cancel-timer'." 452 (interactive 453 (list (read-from-minibuffer "Run after idle (seconds): " nil nil t) 454 (y-or-n-p "Repeat each time Emacs is idle? ") 455 (intern (completing-read "Function: " obarray 'fboundp t)))) 456 (let ((timer (timer-create))) 457 (timer-set-function timer function args) 458 (timer-set-idle-time timer secs repeat) 459 (timer-activate-when-idle timer t) 460 timer)) 461 462(defun with-timeout-handler (tag) 463 "This is the timer function used for the timer made by `with-timeout'." 464 (throw tag 'timeout)) 465 466;;;###autoload (put 'with-timeout 'lisp-indent-function 1) 467 468(defvar with-timeout-timers nil 469 "List of all timers used by currently pending `with-timeout' calls.") 470 471;;;###autoload 472(defmacro with-timeout (list &rest body) 473 "Run BODY, but if it doesn't finish in SECONDS seconds, give up. 474If we give up, we run the TIMEOUT-FORMS and return the value of the last one. 475The timeout is checked whenever Emacs waits for some kind of external 476event (such as keyboard input, input from subprocesses, or a certain time); 477if the program loops without waiting in any way, the timeout will not 478be detected. 479\n(fn (SECONDS TIMEOUT-FORMS...) BODY)" 480 (let ((seconds (car list)) 481 (timeout-forms (cdr list))) 482 `(let ((with-timeout-tag (cons nil nil)) 483 with-timeout-value with-timeout-timer 484 (with-timeout-timers with-timeout-timers)) 485 (if (catch with-timeout-tag 486 (progn 487 (setq with-timeout-timer 488 (run-with-timer ,seconds nil 489 'with-timeout-handler 490 with-timeout-tag)) 491 (push with-timeout-timer with-timeout-timers) 492 (setq with-timeout-value (progn . ,body)) 493 nil)) 494 (progn . ,timeout-forms) 495 (cancel-timer with-timeout-timer) 496 with-timeout-value)))) 497 498(defun with-timeout-suspend () 499 "Stop the clock for `with-timeout'. Used by debuggers. 500The idea is that the time you spend in the debugger should not 501count against these timeouts. 502 503The value is a list that the debugger can pass to `with-timeout-unsuspend' 504when it exits, to make these timers start counting again." 505 (mapcar (lambda (timer) 506 (cancel-timer timer) 507 (list timer 508 (time-subtract 509 ;; The time that this timer will go off. 510 (list (aref timer 1) (aref timer 2) (aref timer 3)) 511 (current-time)))) 512 with-timeout-timers)) 513 514(defun with-timeout-unsuspend (timer-spec-list) 515 "Restart the clock for `with-timeout'. 516The argument should be a value previously returned by `with-timeout-suspend'." 517 (dolist (elt timer-spec-list) 518 (let ((timer (car elt)) 519 (delay (cadr elt))) 520 (timer-set-time timer (time-add (current-time) delay)) 521 (timer-activate timer)))) 522 523(defun y-or-n-p-with-timeout (prompt seconds default-value) 524 "Like (y-or-n-p PROMPT), with a timeout. 525If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." 526 (with-timeout (seconds default-value) 527 (y-or-n-p prompt))) 528 529(defvar timer-duration-words 530 (list (cons "microsec" 0.000001) 531 (cons "microsecond" 0.000001) 532 (cons "millisec" 0.001) 533 (cons "millisecond" 0.001) 534 (cons "sec" 1) 535 (cons "second" 1) 536 (cons "min" 60) 537 (cons "minute" 60) 538 (cons "hour" (* 60 60)) 539 (cons "day" (* 24 60 60)) 540 (cons "week" (* 7 24 60 60)) 541 (cons "fortnight" (* 14 24 60 60)) 542 (cons "month" (* 30 24 60 60)) ; Approximation 543 (cons "year" (* 365.25 24 60 60)) ; Approximation 544 ) 545 "Alist mapping temporal words to durations in seconds") 546 547(defun timer-duration (string) 548 "Return number of seconds specified by STRING, or nil if parsing fails." 549 (let ((secs 0) 550 (start 0) 551 (case-fold-search t)) 552 (while (string-match 553 "[ \t]*\\([0-9.]+\\)?[ \t]*\\([a-z]+[a-rt-z]\\)s?[ \t]*" 554 string start) 555 (let ((count (if (match-beginning 1) 556 (string-to-number (match-string 1 string)) 557 1)) 558 (itemsize (cdr (assoc (match-string 2 string) 559 timer-duration-words)))) 560 (if itemsize 561 (setq start (match-end 0) 562 secs (+ secs (* count itemsize))) 563 (setq secs nil 564 start (length string))))) 565 (if (= start (length string)) 566 secs 567 (if (string-match "\\`[0-9.]+\\'" string) 568 (string-to-number string))))) 569 570(provide 'timer) 571 572;;; arch-tag: b1a9237b-7787-4382-9e46-8f2c3b3273e0 573;;; timer.el ends here 574