xemacs-beta: lisp/itimer.el comparison

comparison lisp/itimer.el @ 209:41ff10fd062f r20-4b3

Import from CVS: tag r20-4b3

author	cvs
date	Mon, 13 Aug 2007 10:04:58 +0200
parents
children	966663fcf606

comparison

equal deleted inserted replaced

-:f427b8ec4379
+:41ff10fd062f
+;;; itimer.el --- Interval timers for XEmacs
+;; Copyright (C) 1988, 1991, 1993, 1997 Kyle E. Jones
+;; Author: Kyle Jones <kyle_jones@wonderworks.com>
+;; Keywords: internal, dumped
+;; 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 XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
+;; 02111-1307, USA.
+;;; Synched up with: Not in FSF
+;;; Commentary:
+;; This file is dumped with XEmacs.
+;; Send bug reports to kyle_jones@wonderworks.com
+;;; Code:
+(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.06"
+"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 doens't support floats or your system doesn't have a
+;; clock with microsecond granularity.  Otherwise granularity is
+;; to the microsend, 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 syunchronous 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)
+"Returns non-nil iff OBJ is an itimer."
+(and (consp obj) (eq (length obj) 8)))
+(defun itimer-live-p (obj)
+"Returns non-nil iff OBJ is an itimer and is active.
+``Active'' means Emacs will run it when it expires.
+`activate-timer' must be called on a itimer to make it active.
+Itimers started with `start-itimer' are automatically active."
+(and (itimerp obj) (memq obj itimer-list)))
+(defun itimer-name (itimer)
+"Returns the name of ITIMER."
+(check-itimer itimer)
+(car itimer))
+(defun itimer-value (itimer)
+"Returns the number of seconds until ITIMER expires."
+(check-itimer itimer)
+(nth 1 itimer))
+(defun itimer-restart (itimer)
+"Returns the value to which ITIMER will be set at restart.
+nil is returned if this itimer doesn't restart."
+(check-itimer itimer)
+(nth 2 itimer))
+(defun itimer-function (itimer)
+"Returns the function of ITIMER.
+This function is called each time ITIMER expires."
+(check-itimer itimer)
+(nth 3 itimer))
+(defun itimer-is-idle (itimer)
+"Returns 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 within the interval."
+(check-itimer itimer)
+(nth 4 itimer))
+(defun itimer-uses-arguments (itimer)
+"Returns 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)
+"Returns the function arguments of ITIMER as a list.
+ITIMER's function is called with these argument each timer 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 is 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)
+"Sets flag that says whether ITIMER is an idle timer.
+If FLAG is non-nil, then ITIMER will eb considered an idle timer.
+Returns FLAG."
+(check-itimer itimer)
+(setcar (nthcdr 4 itimer) flag))
+(defun set-itimer-uses-arguments (itimer flag)
+"Sets 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)
+"Deletes 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 until
+it is 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
+you can 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 specified if this is an idle timer.
+Normal timers eexpire after a set interval.  Idle timers expire
+only after Emacs has been idle for specific interval.  ``Idle''
+means no command events 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 (concat 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 (concat 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-disable-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)
+(if (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.
+(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)
+			 itimer itimers time-elapsed)
+		    (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)))
+;; if user is editing itimers, update displayed info
+(if (eq major-mode 'itimer-edit-mode)
+	(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-timer-wakeup ()
+(let ((inhibit-quit t))
+(cond ((fboundp 'disable-timeout)
+	   (disable-timeout itimer-timer))
+	  ((fboundp 'cancel-timer)
+	   (cancel-timer 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 bne 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))
+	(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)))
+;;; itimer.el ends here

Mercurial > hg > xemacs-beta

comparison lisp/itimer.el @ 209:41ff10fd062f r20-4b3