Commits

Anonymous committed 85404bf

Natively support run-at-time and friends using itimers.

  • Participants
  • Parent commits 44091c1

Comments (0)

Files changed (3)

+2004-09-07  Jerry James  <james@xemacs.org>
+
+	* Makefile (ELCS): Add timer-funcs.el and realphabetize.
+
 2004-10-04  Adrian Aichner  <adrian@xemacs.org>
 
 	* ffap.el (ffap-alist): Single typo fix.
 
 ELCS = add-log.elc advice.elc annotations.elc assoc.elc case-table.elc \
 	chistory.elc comint.elc comint-xemacs.elc compile.elc debug.elc \
-	ebuff-menu.elc echistory.elc ehelp.elc edmacro.elc electric.elc \
-	enriched.elc env.elc facemenu.elc ffap.elc helper.elc imenu.elc \
-	iso-syntax.elc macros.elc novice.elc outline.elc \
+	easy-mmode.elc ebuff-menu.elc echistory.elc ehelp.elc edmacro.elc \
+	electric.elc enriched.elc env.elc facemenu.elc ffap.elc field.elc \
+	helper.elc imenu.elc iso-syntax.elc macros.elc novice.elc outline.elc \
 	passwd.elc pp.elc regexp-opt.elc regi.elc ring.elc shell.elc \
-	skeleton.elc sort.elc thing.elc time-stamp.elc timezone.elc \
-	xbm-button.elc xpm-button.elc tq.elc easy-mmode.elc field.elc
+	skeleton.elc sort.elc thing.elc time-stamp.elc timer-funcs.elc \
+	timezone.elc tq.elc xbm-button.elc xpm-button.elc
 
 DATA_FILES = etc/enriched.doc
 DATA_DEST = .
+;;; timer-funcs.el --- timer implementation-independent functions
+
+;; Copyright (C) 1996 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+
+;; This file is part of XEmacs.
+
+;; XEmacs 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.
+
+;; XEmacs 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.
+
+;; You should have received a copy of the GNU General Public License
+;; 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 file contains functions from Emacs timer.el that do not take timer
+;; objects as parameters.  This lets us use itimers as the implementation,
+;; instead of emulated Emacs timers.  Note that a few of these functions
+;; RETURN itimers, however.
+
+;;; Code:
+
+(require 'itimer)
+
+(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))
+	 (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)))))
+
+(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
+    ;; `/' rounds towards zero while `mod' returns a positive number,
+    ;; so we can't rely on (= a (+ (* 100 (/ a 100)) (mod a 100))).
+    (setq low (+ low (/ micro 1000000) (if (< micro 0) -1 0)))
+    (setq micro (mod micro 1000000))
+    (setq high (+ high (/ low 65536) (if (< low 0) -1 0)))
+    (setq low (logand low 65535))
+
+    (list high low (and (/= micro 0) micro))))
+
+(defun cancel-function-timers (function)
+  "Cancel all itimers scheduled by `run-at-time' which would run FUNCTION."
+  (interactive "aCancel itimers of function: ")
+  (dolist (itimer itimer-list)
+    (if (eq (itimer-function itimer) function)
+	(delete-itimer itimer))))
+
+(define-error 'invalid-repetition-interval "Invalid repetition interval")
+(define-error 'invalid-time "Invalid time format")
+
+;;;###autoload
+(defun run-at-time (time repeat function &rest args)
+  "Perform an action at time TIME.
+Repeat the action every REPEAT seconds, if REPEAT is non-nil.
+TIME should be a string recognized by `timer-parse-time', like \"11:23pm\",
+nil meaning now, a number of seconds from now, a value from `current-time',
+or t (with non-nil REPEAT) meaning the next integral multiple of REPEAT.
+REPEAT may be an integer or floating point number.
+The action is to call FUNCTION with arguments ARGS.
+
+This function returns an itimer object which you can use in `delete-itimer'."
+  (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
+
+  (or (null repeat)
+      (and (numberp repeat) (< 0 repeat))
+      (error 'invalid-repetition-interval repeat))
+
+  ;; Special case: nil means "now" and is useful when repeating.
+  (if (null time)
+      (setq time 0))
+
+  ;; Special case: t means the next integral multiple of REPEAT.
+  (if (and (eq time t) repeat)
+      (let ((now (current-time)))
+	(setq time
+	      (itimer-time-difference
+	       (timer-next-integral-multiple-of-time now repeat)
+	       now))))
+
+  ;; Handle relative times like "2 hours and 35 minutes"
+  (if (stringp time)
+      (let ((spec-time (timer-duration time)))
+	(if spec-time
+	    (setq time spec-time))))
+
+  ;; Handle "11:23pm" and the like.  Interpret it as meaning today
+  ;; which admittedly is rather stupid if we have passed that time
+  ;; already.  (Though only Emacs hackers hack Emacs at that time.)
+  (if (stringp time)
+      (let ((spec-time (timer-parse-time time)))
+	(if spec-time
+	    (setq time
+		  (ceiling
+		   (itimer-time-difference spec-time (current-time)))))))
+
+  (or (numberp time)
+      (error 'invalid-time time))
+
+  (apply #'start-itimer "run-at-time" function time repeat nil t args))
+
+;;;###autoload
+(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 may be integers or floating point numbers.
+The action is to call FUNCTION with arguments ARGS.
+
+This function returns an itimer object which you can use in `delete-itimer'."
+  (interactive "sRun after delay (seconds): \nNRepeat interval: \naFunction: ")
+  (apply #'start-itimer "run-with-timer" function secs repeat nil t args))
+
+;;;###autoload
+(defun run-with-idle-timer (secs repeat function &rest args)
+  "Perform an action the next time XEmacs is idle for SECS seconds.
+The action is to call FUNCTION with arguments ARGS.
+SECS may be an integer or a floating point number.
+
+If REPEAT is non-nil, do the action each time XEmacs has been idle for
+exactly SECS seconds (that is, only once for each time XEmacs becomes idle).
+
+This function returns an itimer object which you can use in `delete-itimer'."
+  (interactive
+   (list (read-from-minibuffer "Run after idle (seconds): " nil nil t)
+	 (y-or-n-p "Repeat each time XEmacs is idle? ")
+	 (intern (completing-read "Function: " obarray 'fboundp t))))
+  (apply #'start-itimer "run-with-idle-timer" function secs
+	 (if repeat secs nil) t t args))
+
+(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 should look like:
+ (with-timeout (SECONDS TIMEOUT-FORMS...) BODY...)
+The timeout is checked whenever XEmacs 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)
+      (when (catch with-timeout-tag
+	      (progn
+		(setq with-timeout-timer
+		      (start-itimer "with-timeout" #'with-timeout-handler
+				    ,seconds nil nil t with-timeout-tag))
+		(setq with-timeout-value (progn ,@body))
+		nil))
+	    ,@timeout-forms
+	    (delete-itimer with-timeout-timer)
+	    with-timeout-value))))
+
+;;;###autoload
+(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)))))
+    (if (= start (length string))
+	secs
+      (if (string-match "\\`[0-9.]+\\'" string)
+	  (string-to-number string)))))
+
+(defun timer-parse-time (s)
+  "Return an encoded time represesnting the time specifed by S.
+This is a time in the same format as returned by `current-time'.  This
+function assumes that the specified time is during the current day.
+S can be of the form XXXX, X:XX, XX:XX, XXXXXX, X:XX:XX, or XX:XX:XX (military
+time), or any of the above followed by \"am\", \"AM\", \"pm\", or \"PM\".  If
+S does not describe a recognizable time, nil is returned."
+  (let ((case-fold-search t)
+	(now (decode-time))
+	hour minute second)
+    (cond ((string-match;; Hour only  XXam or XXpm
+	    "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
+	   (setq hour (+ (% (string-to-number (match-string 1 s)) 12)
+			 (if (char-equal ?a (aref s (match-beginning 2)))
+			     0 12))
+		 minute 0
+		 second 0))
+	  ((string-match;; Hour and minute  XX:XXam or XX:XXpm
+	    "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
+	   (setq hour (+ (% (string-to-number (match-string 1 s)) 12)
+			 (if (char-equal ?a (aref s (match-beginning 3)))
+			     0 12))
+		 minute (string-to-number (match-string 2 s))
+		 second 0))
+	  ((string-match;; Hour, minute, and seconds  XX:XX:XXam or XX:XX:XXpm
+	    "^[ \t]*\\([0-9]?[0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
+	   (setq hour (+ (% (string-to-number (match-string 1 s)) 12)
+			 (if (char-equal ?a (aref s (match-beginning 4)))
+			     0 12))
+		 minute (string-to-number (match-string 2 s))
+		 second (string-to-number (match-string 3 s))))
+	  ((string-match;; Military time  
+	    "\\`[ \t\n\\^M]*\\([0-9]?[0-9]\\)[:.]?\\([0-9][0-9]\\)[:.]?\\([0-9][0-9]\\)?\\(\\>\\|[^ap]\\)" s)
+	   (setq hour (string-to-number (match-string 1 s))
+		 minute (string-to-number (match-string 2 s))
+		 second (if (match-beginning 3)
+			    (string-to-number (match-string 3 s))
+			  0))))
+    (if hour
+	(nconc
+	 (encode-time
+	  second minute hour (nth 3 now) (nth 4 now) (nth 5 now) (nth 8 now))
+	 '(0)))))
+
+(provide 'timer-funcs)
+
+;;; timer-funcs.el ends here