From: Richard M. Stallman Date: Wed, 31 Jan 1996 20:12:19 +0000 (+0000) Subject: Initial revision X-Git-Tag: emacs-19.34~1411 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=c4ba2209a51105d7fa7e284d9392b53355553b61;p=emacs.git Initial revision --- diff --git a/lisp/timer.el b/lisp/timer.el index 3b468023437..e29ee58a211 100644 --- a/lisp/timer.el +++ b/lisp/timer.el @@ -1,4 +1,4 @@ -;;; timers.el --- run a function with args at some time in future +;;; timer.el --- run a function with args at some time in future. ;; Copyright (C) 1996 Free Software Foundation, Inc. @@ -25,17 +25,16 @@ ;; This package gives you the capability to run Emacs Lisp commands at ;; specified times in the future, either as one-shots or periodically. -;; The single entry point is `run-at-time'. ;;; Code: ;; Layout of a timer vector: -;; [triggered-p trigger-high trigger-low delta-secs function args] +;; [triggered-p high-seconds low-seconds usecs delta-secs function args] (defun timer-create () "Create a timer object." (let ((timer (make-vector 7 nil))) - (aset timer 0 (make-vector 1 'timer-event)) + (aset timer 0 t) timer)) (defun timerp (object) @@ -46,33 +45,47 @@ "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 menu seconds apart." +fire repeatedly that meny 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 (if (consp (cdr time)) (nth 2 time) 0)) - (aset timer 4 (and (integerp delta) (> delta 0) delta)) + (aset timer 4 (and (numberp delta) (> delta 0) delta)) timer) +(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." - (or usecs (setq usecs 0)) - (if (floatp secs) - (let* ((integer (floor secs)) - (fraction (floor (* 1000000 (- secs integer))))) - (setq usecs fraction secs integer))) - (let ((newusecs (+ (aref timer 3) usecs))) - (aset timer 3 (mod newusecs 1000000)) - (setq secs (+ secs (/ newusecs 1000000)))) - (let ((newlow (+ (aref timer 2) secs)) - (newhigh (aref timer 1))) - (setq newhigh (+ newhigh (/ newlow 65536)) - newlow (logand newlow 65535)) - (aset timer 1 newhigh) - (aset timer 2 newlow))) + (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. @@ -84,7 +97,7 @@ fire repeatedly that menu seconds apart." (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 (integerp delta) (> delta 0) delta)) + (aset timer 4 (and (numberp delta) (> delta 0) delta)) timer) (defun timer-set-function (timer function &optional args) @@ -122,6 +135,7 @@ fire repeatedly that menu seconds apart." nil) (error "Invalid or uninitialized timer"))) +(defalias 'disable-timeout 'cancel-timer) (defun cancel-timer (timer) "Remove TIMER from the list of active timers." (or (timerp timer) @@ -146,7 +160,7 @@ fire repeatedly that menu seconds apart." (defun timer-event-handler (event) "Call the handler for the timer in the event EVENT." (interactive "e") - (let ((timer (cdr-safe event))) + (let ((timer (car-safe (cdr-safe event)))) (if (timerp timer) (progn ;; Delete from queue. @@ -166,27 +180,33 @@ fire repeatedly that menu seconds apart." Arguments are TIME, REPEAT, FUNCTION &rest ARGS. TIME is a string like \"11:23pm\" or a value from `encode-time'. REPEAT, an integer number of seconds, is the interval on which to repeat -the call to the function. If REPEAT is nil or 0, call it just once." +the call to the function. If REPEAT is nil or 0, call it just once. + +This function returns a timer object which you can use in `cancel-timer'." (interactive "sRun at time: \nNRepeat interval: \naFunction: ") + ;; Special case: nil means "now" and is useful when repeting. + (if (null time) + (setq time (current-time))) + + ;; Handle relative times like "2 hours and 35 minutes" + (if (stringp time) + (let ((secs (timer-duration time))) + (if secs + (setq time (timer-relative-time (current-time) secs))))) + ;; Handle "11:23pm" and the like. Interpret it as meaning today ;; which admittedly is rather stupid if we have passed that time - ;; already. Unfortunately we don't have a `parse-time' function - ;; to do the right thing. + ;; already. (if (stringp time) (progn (require 'diary-lib) (let ((hhmm (diary-entry-time time)) (now (decode-time))) - (if (< hhmm 0) - (setq time 'bad) - (setq time - (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) - (nth 4 now) (nth 5 now) (nth 8 now))))))) - - ;; Special case: nil means "now" and is useful when repeting. - (if (null time) - (setq time (current-time))) + (if (>= hhmm 0) + (setq time + (encode-time 0 (% hhmm 100) (/ hhmm 100) (nth 3 now) + (nth 4 now) (nth 5 now) (nth 8 now))))))) (or (consp time) (error "Invalid time format")) @@ -198,14 +218,17 @@ the call to the function. If REPEAT is nil or 0, call it just once." (let ((timer (timer-create))) (timer-set-time timer time repeat) (timer-set-function timer function args) - (timer-activate timer))) + (timer-activate timer) + timer)) ;;;###autoload -(defun run-after-delay (secs repeat function &rest args) +(defun run-with-timer (secs repeat function &rest args) "Perform an action after a delay of SECS seconds. Repeat the action every REPEAT seconds, if REPEAT is non-nil. -SECS and REPEAT need not be integers. -The action is to call FUNCTION with arguments ARGS." +SECS and REPEAT may be integers or floating point numbers. +The action is to call FUNCTION with arguments ARGS. + +This function returns a timer object which you can use in `cancel-timer'." (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ") (or (null repeat) @@ -216,8 +239,96 @@ The action is to call FUNCTION with arguments ARGS." (timer-set-time timer (current-time)) (timer-inc-time timer secs) (timer-set-function timer function args) - (timer-activate timer))) + (timer-activate timer) + timer)) + +;;;###autoload +(defun add-timeout (secs function object &optional repeat) + "Add a timer to run SECS seconds from now, to call FUNCTION on OBJECT. +If REPEAT is non-nil, repeat the timer every REPEAT seconds. +This function is for compatibility; see also `run-with-timer'." + (run-with-timer secs repeat function object)) + +(defun timeout-event-p (event) + "Non-nil if EVENT is a timeout event." + (and (listp event) + (eq (car event) 'timer-event))) + +(defun with-timeout-handler (tag) + (throw tag 'timeout)) + +;;;###autoload (put 'with-timeout 'lisp-indent-function 1) + +;;;###autoload +(defmacro with-timeout (list &rest body) + "Run BODY, but if it doesn't finish in SECONDS seconds, give up. +If we give up, we run the TIMEOUT-FORMS and return the value of the last one. +The call looks like + (with-timeout (SECONDS TIMEOUT-FORMS...) BODY...) +The timeout is checked whenever Emacs waits for some kind of external +event \(such as keyboard input, input from subprocesses, or a certain time); +if the program loops without waiting in any way, the timeout will not +be detected." + (let ((seconds (car list)) + (timeout-forms (cdr list))) + `(let ((with-timeout-tag (cons nil nil)) + with-timeout-value with-timeout-timer) + (if (catch with-timeout-tag + (progn + (setq with-timeout-timer + (run-with-timer ,seconds nil + 'with-timeout-handler + with-timeout-tag)) + (setq with-timeout-value (progn . ,body)) + nil)) + (progn . ,timeout-forms) + (cancel-timer with-timeout-timer) + with-timeout-value)))) + +(defun y-or-n-p-with-timeout (prompt seconds default-value) + "Like (y-or-n-p PROMPT), with a timeout. +If the user does not answer after SECONDS seconds, return DEFAULT-VALUE." + (with-timeout (seconds default-value) + (y-or-n-p prompt))) + +(defvar timer-duration-words + (list (cons "microsec" 0.000001) + (cons "microsecond" 0.000001) + (cons "millisec" 0.001) + (cons "millisecond" 0.001) + (cons "sec" 1) + (cons "second" 1) + (cons "min" 60) + (cons "minute" 60) + (cons "hour" (* 60 60)) + (cons "day" (* 24 60 60)) + (cons "week" (* 7 24 60 60)) + (cons "fortnight" (* 14 24 60 60)) + (cons "month" (* 30 24 60 60)) ; Approximation + (cons "year" (* 365.25 24 60 60)) ; Approximation + ) + "Alist mapping temporal words to durations in seconds") + +(defun timer-duration (string) + "Return number of seconds specified by STRING, or nil if parsing fails." + (let ((secs 0) + (start 0) + (case-fold-search t)) + (while (string-match + "[ \t]*\\([0-9.]+\\)?[ \t]*\\([a-z]+[a-rt-z]\\)s?[ \t]*" + string start) + (let ((count (if (match-beginning 1) + (string-to-number (match-string 1 string)) + 1)) + (itemsize (cdr (assoc (match-string 2 string) + timer-duration-words)))) + (if itemsize + (setq start (match-end 0) + secs (+ secs (* count itemsize))) + (setq secs nil + start (length string))))) + secs)) -(provide 'timers) +(provide 'timer) -;;; timers.el ends here +;;; timer.el ends here