git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/itimer.el

   1 ;;; Interval timers for GNU Emacs
   2 ;;; Copyright (C) 1988, 1991, 1993, 1997, 1998 Kyle E. Jones
   3 ;;;
   4 ;;; This program is free software; you can redistribute it and/or modify
   5 ;;; it under the terms of the GNU General Public License as published by
   6 ;;; the Free Software Foundation; either version 2, or (at your option)
   7 ;;; any later version.
   8 ;;;
   9 ;;; This program is distributed in the hope that it will be useful,
  10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;;; GNU General Public License for more details.
  13 ;;;
  14 ;;; A copy of the GNU General Public License can be obtained from this
  15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
  16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
  17 ;;; 02139, USA.
  18 ;;;
  19 ;;; Send bug reports to kyle_jones@wonderworks.com
  20
  21 (provide 'itimer)
  22
  23 ;; `itimer' feature means Emacs-Lisp programmers get:
  24 ;;    itimerp
  25 ;;    itimer-live-p
  26 ;;    itimer-value
  27 ;;    itimer-restart
  28 ;;    itimer-function
  29 ;;    itimer-uses-arguments
  30 ;;    itimer-function-arguments
  31 ;;    set-itimer-value
  32 ;;    set-itimer-restart
  33 ;;    set-itimer-function
  34 ;;    set-itimer-uses-arguments
  35 ;;    set-itimer-function-arguments
  36 ;;    get-itimer
  37 ;;    start-itimer
  38 ;;    read-itimer
  39 ;;    delete-itimer
  40 ;;    activate-itimer
  41 ;;
  42 ;; Interactive users get these commands:
  43 ;;    edit-itimers
  44 ;;    list-itimers
  45 ;;    start-itimer
  46 ;;
  47 ;; See the doc strings of these functions for more information.
  48 \f
  49 (defvar itimer-version "1.07"
  50   "Version number of the itimer package.")
  51
  52 (defvar itimer-list nil
  53   "List of all active itimers.")
  54
  55 (defvar itimer-process nil
  56   "Process that drives all itimers, if a subprocess is being used.")
  57
  58 (defvar itimer-timer nil
  59   "Emacs internal timer that drives the itimer system, if a subprocess
  60 is not being used to drive the system.")
  61
  62 (defvar itimer-timer-last-wakeup nil
  63   "The time the timer driver function last ran.")
  64
  65 (defvar itimer-short-interval (if (featurep 'lisp-float-type) 1e-3 1)
  66   "Interval used for scheduling an event a very short time in the future.
  67 Used internally to make the scheduler wake up early.
  68 Unit is seconds.")
  69
  70 ;; This value is maintained internally; it does not determine
  71 ;; itimer granularity.  Itimer granularity is 1 second if your
  72 ;; Emacs doesn't support floats or your system doesn't have a
  73 ;; clock with microsecond granularity.  Otherwise granularity is
  74 ;; to the microsecond, although you can't possibly get timers to be
  75 ;; executed with this kind of accuracy in practice.  There will
  76 ;; be delays due to system and Emacs internal activity that delay
  77 ;; dealing with synchronous events and process output.
  78 (defvar itimer-next-wakeup itimer-short-interval
  79   "Itimer process will wakeup to service running itimers within this
  80 many seconds.")
  81
  82 (defvar itimer-edit-map nil
  83   "Keymap used when in Itimer Edit mode.")
  84
  85 (if itimer-edit-map
  86     ()
  87   (setq itimer-edit-map (make-sparse-keymap))
  88   (define-key itimer-edit-map "s" 'itimer-edit-set-field)
  89   (define-key itimer-edit-map "d" 'itimer-edit-delete-itimer)
  90   (define-key itimer-edit-map "q" 'itimer-edit-quit)
  91   (define-key itimer-edit-map "\t" 'itimer-edit-next-field)
  92   (define-key itimer-edit-map " " 'next-line)
  93   (define-key itimer-edit-map "n" 'next-line)
  94   (define-key itimer-edit-map "p" 'previous-line)
  95   (define-key itimer-edit-map "\C-?" 'itimer-edit-previous-field)
  96   (define-key itimer-edit-map "x" 'start-itimer)
  97   (define-key itimer-edit-map "?" 'itimer-edit-help))
  98
  99 (defvar itimer-inside-driver nil)
 100
 101 (defvar itimer-edit-start-marker nil)
 102 \f
 103 ;; macros must come first... or byte-compile'd code will throw back its
 104 ;; head and scream.
 105
 106 (defmacro itimer-decrement (variable)
 107   (list 'setq variable (list '1- variable)))
 108
 109 (defmacro itimer-increment (variable)
 110   (list 'setq variable (list '1+ variable)))
 111
 112 (defmacro itimer-signum (n)
 113   (list 'if (list '> n 0) 1
 114     (list 'if (list 'zerop n) 0 -1)))
 115
 116 ;; Itimer access functions should behave as if they were subrs.  These
 117 ;; macros are used to check the arguments to the itimer functions and
 118 ;; signal errors appropriately if the arguments are not valid.
 119
 120 (defmacro check-itimer (var)
 121   "If VAR is not bound to an itimer, signal wrong-type-argument.
 122 This is a macro."
 123   (list 'setq var
 124         (list 'if (list 'itimerp var) var
 125               (list 'signal ''wrong-type-argument
 126                     (list 'list ''itimerp var)))))
 127
 128 (defmacro check-itimer-coerce-string (var)
 129   "If VAR is not bound to a string, look up the itimer that it names and
 130 bind VAR to it.  Otherwise, if VAR is not bound to an itimer, signal
 131 wrong-type-argument.  This is a macro."
 132   (list 'setq var
 133         (list 'cond
 134               (list (list 'itimerp var) var)
 135               (list (list 'stringp var) (list 'get-itimer var))
 136               (list t (list 'signal ''wrong-type-argument
 137                             (list 'list ''string-or-itimer-p var))))))
 138
 139 (defmacro check-nonnegative-number (var)
 140   "If VAR is not bound to a number, signal wrong-type-argument.
 141 If VAR is not bound to a positive number, signal args-out-of-range.
 142 This is a macro."
 143   (list 'setq var
 144         (list 'if (list 'not (list 'numberp var))
 145               (list 'signal ''wrong-type-argument
 146                     (list 'list ''natnump var))
 147               (list 'if (list '< var 0)
 148                     (list 'signal ''args-out-of-range (list 'list var))
 149                     var))))
 150
 151 (defmacro check-string (var)
 152   "If VAR is not bound to a string, signal wrong-type-argument.
 153 This is a macro."
 154   (list 'setq var
 155         (list 'if (list 'stringp var) var
 156               (list 'signal ''wrong-type-argument
 157                     (list 'list ''stringp var)))))
 158 \f
 159 ;; Functions to access and modify itimer attributes.
 160
 161 (defun itimerp (obj)
 162   "Return t if OBJ is an itimer."
 163   (and (consp obj) (eq (length obj) 8)))
 164
 165 (defun itimer-live-p (obj)
 166   "Return non-nil if OBJ is an itimer and is active.
 167 ``Active'' means Emacs will run it when it expires.
 168 `activate-timer' must be called on an itimer to make it active.
 169 Itimers started with `start-itimer' are automatically active."
 170   (and (itimerp obj) (memq obj itimer-list)))
 171
 172 (defun itimer-name (itimer)
 173   "Return the name of ITIMER."
 174   (check-itimer itimer)
 175   (car itimer))
 176
 177 (defun itimer-value (itimer)
 178   "Return the number of seconds until ITIMER expires."
 179   (check-itimer itimer)
 180   (nth 1 itimer))
 181
 182 (defun itimer-restart (itimer)
 183   "Return the value to which ITIMER will be set at restart.
 184 Return nil if this itimer doesn't restart."
 185   (check-itimer itimer)
 186   (nth 2 itimer))
 187
 188 (defun itimer-function (itimer)
 189   "Return the function of ITIMER.
 190 This function is called each time ITIMER expires."
 191   (check-itimer itimer)
 192   (nth 3 itimer))
 193
 194 (defun itimer-is-idle (itimer)
 195   "Return non-nil if ITIMER is an idle timer.
 196 Normal timers expire after a set interval.  Idle timers expire
 197 only after Emacs has been idle for a specific interval.
 198 ``Idle'' means no command events occur within the interval."
 199   (check-itimer itimer)
 200   (nth 4 itimer))
 201
 202 (defun itimer-uses-arguments (itimer)
 203   "Return non-nil if the function of ITIMER will be called with arguments.
 204 ITIMER's function is called with the arguments each time ITIMER expires.
 205 The arguments themselves are retrievable with `itimer-function-arguments'."
 206   (check-itimer itimer)
 207   (nth 5 itimer))
 208
 209 (defun itimer-function-arguments (itimer)
 210   "Return the function arguments of ITIMER as a list.
 211 ITIMER's function is called with these argument each time ITIMER expires."
 212   (check-itimer itimer)
 213   (nth 6 itimer))
 214
 215 (defun itimer-recorded-run-time (itimer)
 216   (check-itimer itimer)
 217   (nth 7 itimer))
 218
 219 (defun set-itimer-value (itimer value)
 220   "Set the timeout value of ITIMER to be VALUE.
 221 Itimer will expire in this many seconds.
 222 If your version of Emacs supports floating point numbers then
 223 VALUE can be a floating point number.  Otherwise it
 224 must be an integer.
 225 Returns VALUE."
 226   (check-itimer itimer)
 227   (check-nonnegative-number value)
 228   (let ((inhibit-quit t))
 229     ;; If the itimer is in the active list, and under the new
 230     ;; timeout value would expire before we would normally
 231     ;; wakeup, wakeup now and recompute a new wakeup time.
 232     (or (and (< value itimer-next-wakeup)
 233              (and (itimer-name itimer) (get-itimer (itimer-name itimer)))
 234              (progn (itimer-driver-wakeup)
 235                     (setcar (cdr itimer) value)
 236                     (itimer-driver-wakeup)
 237                     t ))
 238         (setcar (cdr itimer) value))
 239     value))
 240
 241 ;; Same as set-itimer-value but does not wakeup the driver.
 242 ;; Only should be used by the drivers when processing expired timers.
 243 (defun set-itimer-value-internal (itimer value)
 244   (check-itimer itimer)
 245   (check-nonnegative-number value)
 246   (setcar (cdr itimer) value))
 247
 248 (defun set-itimer-restart (itimer restart)
 249   "Set the restart value of ITIMER to be RESTART.
 250 If RESTART is nil, ITIMER will not restart when it expires.
 251 If your version of Emacs supports floating point numbers then
 252 RESTART can be a floating point number.  Otherwise it
 253 must be an integer.
 254 Returns RESTART."
 255   (check-itimer itimer)
 256   (if restart (check-nonnegative-number restart))
 257   (setcar (cdr (cdr itimer)) restart))
 258
 259 (defun set-itimer-function (itimer function)
 260   "Set the function of ITIMER to be FUNCTION.
 261 FUNCTION will be called when itimer expires.
 262 Returns FUNCTION."
 263   (check-itimer itimer)
 264   (setcar (nthcdr 3 itimer) function))
 265
 266 (defun set-itimer-is-idle (itimer flag)
 267   "Set flag that says whether ITIMER is an idle timer.
 268 If FLAG is non-nil, then ITIMER will be considered an idle timer.
 269 Returns FLAG."
 270   (check-itimer itimer)
 271   (setcar (nthcdr 4 itimer) flag))
 272
 273 (defun set-itimer-uses-arguments (itimer flag)
 274   "Set flag that says whether the function of ITIMER is called with arguments.
 275 If FLAG is non-nil, then the function will be called with one argument,
 276 otherwise the function will be called with no arguments.
 277 Returns FLAG."
 278   (check-itimer itimer)
 279   (setcar (nthcdr 5 itimer) flag))
 280
 281 (defun set-itimer-function-arguments (itimer &optional arguments)
 282   "Set the function arguments of ITIMER to be ARGUMENTS.
 283 The function of ITIMER will be called with ARGUMENTS when itimer expires.
 284 Returns ARGUMENTS."
 285   (check-itimer itimer)
 286   (setcar (nthcdr 6 itimer) arguments))
 287
 288 (defun set-itimer-recorded-run-time (itimer time)
 289   (check-itimer itimer)
 290   (setcar (nthcdr 7 itimer) time))
 291
 292 (defun get-itimer (name)
 293   "Return itimer named NAME, or nil if there is none."
 294   (check-string name)
 295   (assoc name itimer-list))
 296
 297 (defun read-itimer (prompt &optional initial-input)
 298   "Read the name of an itimer from the minibuffer and return the itimer
 299 associated with that name.  The user is prompted with PROMPT.
 300 Optional second arg INITIAL-INPUT non-nil is inserted into the
 301 minibuffer as initial user input."
 302   (get-itimer (completing-read prompt itimer-list nil 'confirm initial-input)))
 303
 304 (defun delete-itimer (itimer)
 305   "Delete ITIMER.  ITIMER may be an itimer or the name of one."
 306   (check-itimer-coerce-string itimer)
 307   (setq itimer-list (delq itimer itimer-list)))
 308
 309 (defun start-itimer (name function value &optional restart
 310                      is-idle with-args &rest function-arguments)
 311   "Start an itimer.
 312 Arguments are
 313   NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS.
 314 NAME is an identifier for the itimer.  It must be a string.  If an itimer
 315   already exists with this name, NAME will be modified slightly to make
 316   it unique.
 317 FUNCTION should be a function (or symbol naming one).  It
 318   will be called each time the itimer expires with arguments of
 319   FUNCTION-ARGUMENTS.  The function can access the itimer that
 320   invoked it through the variable `current-itimer'.  If WITH-ARGS
 321   is nil then FUNCTION is called with no arguments.  This is for
 322   backward compatibility with older versions of the itimer
 323   package which always called FUNCTION with no arguments.
 324 VALUE is the number of seconds until this itimer expires.
 325   If your version of Emacs supports floating point numbers then
 326   VALUE can be a floating point number.  Otherwise it
 327   must be an integer.
 328 Optional fourth arg RESTART non-nil means that this itimer should be
 329   restarted automatically after its function is called.  Normally an itimer
 330   is deleted at expiration after its function has returned.
 331   If non-nil, RESTART should be a number indicating the value at which
 332   the itimer should be set at restart time.
 333 Optional fifth arg IS-IDLE specifies if this is an idle timer.
 334   Normal timers expire after a set interval.  Idle timers expire
 335   only after Emacs has been idle for specific interval.
 336   ``Idle'' means no command events occur within the interval.
 337 Returns the newly created itimer."
 338   (interactive
 339    (list (completing-read "Start itimer: " itimer-list)
 340          (read (completing-read "Itimer function: " obarray 'fboundp))
 341          (let (value)
 342            (while (or (not (numberp value)) (< value 0))
 343              (setq value (read-from-minibuffer "Itimer value: " nil nil t)))
 344            value)
 345          (let ((restart t))
 346            (while (and restart (or (not (numberp restart)) (< restart 0)))
 347              (setq restart (read-from-minibuffer "Itimer restart: "
 348                                                  nil nil t)))
 349            restart)
 350          ;; hard to imagine the user specifying these interactively
 351          nil
 352          nil ))
 353   (check-string name)
 354   (check-nonnegative-number value)
 355   (if restart (check-nonnegative-number restart))
 356   ;; Make proposed itimer name unique if it's not already.
 357   (let ((oname name)
 358         (num 2))
 359     (while (get-itimer name)
 360       (setq name (format "%s<%d>" oname num))
 361       (itimer-increment num)))
 362   (activate-itimer (list name value restart function is-idle
 363                          with-args function-arguments (list 0 0 0)))
 364   (car itimer-list))
 365
 366 (defun make-itimer ()
 367   "Create an unactivated itimer.
 368 The itimer will not begin running until activated with `activate-itimer'.
 369 Set the itimer's expire interval with `set-itimer-value'.
 370 Set the itimer's function interval with `set-itimer-function'.
 371 Once this is done, the timer can be activated."
 372   (list nil 0 nil 'ignore nil nil nil (list 0 0 0)))
 373
 374 (defun activate-itimer (itimer)
 375   "Activate ITIMER, which was previously created with `make-itimer'.
 376 ITIMER will be added to the global list of running itimers,
 377 its FUNCTION will be called when it expires, and so on."
 378   (check-itimer itimer)
 379   (if (memq itimer itimer-list)
 380       (error "itimer already activated"))
 381   (if (not (numberp (itimer-value itimer)))
 382       (error "itimer timeout value not a number: %s" (itimer-value itimer)))
 383   (if (<= (itimer-value itimer) 0)
 384       (error "itimer timeout value not positive: %s" (itimer-value itimer)))
 385   ;; If there's no itimer driver/process, start one now.
 386   ;; Otherwise wake up the itimer driver so that seconds slept before
 387   ;; the new itimer is created won't be counted against it.
 388   (if (or itimer-process itimer-timer)
 389       (itimer-driver-wakeup)
 390     (itimer-driver-start))
 391   ;; Roll a unique name for the timer if it doesn't have a name
 392   ;; already.
 393   (if (not (stringp (car itimer)))
 394       (let ((name "itimer-0")
 395             (oname "itimer-")
 396             (num 1))
 397         (while (get-itimer name)
 398           (setq name (format "%s<%d>" oname num))
 399           (itimer-increment num))
 400         (setcar itimer name))
 401     ;; signal an error if the timer's name matches an already
 402     ;; activated timer.
 403     (if (get-itimer (itimer-name itimer))
 404         (error "itimer named \"%s\" already existing and activated"
 405                (itimer-name itimer))))
 406   (let ((inhibit-quit t))
 407     ;; add the itimer to the global list
 408     (setq itimer-list (cons itimer itimer-list))
 409     ;; If the itimer process is scheduled to wake up too late for
 410     ;; the itimer we wake it up to calculate a correct wakeup
 411     ;; value giving consideration to the newly added itimer.
 412     (if (< (itimer-value itimer) itimer-next-wakeup)
 413         (itimer-driver-wakeup))))
 414 \f
 415 ;; User level functions to list and modify existing itimers.
 416 ;; Itimer Edit major mode, and the editing commands thereof.
 417
 418 (defun list-itimers ()
 419   "Pop up a buffer containing a list of all itimers.
 420 The major mode of the buffer is Itimer Edit mode.  This major mode provides
 421 commands to manipulate itimers; see the documentation for
 422 `itimer-edit-mode' for more information."
 423   (interactive)
 424   (let* ((buf (get-buffer-create "*Itimer List*"))
 425          (opoint (point))
 426          (standard-output buf)
 427          (itimers (reverse itimer-list)))
 428     (set-buffer buf)
 429     (itimer-edit-mode)
 430     (setq buffer-read-only nil)
 431     (erase-buffer)
 432     (insert
 433 "Name                  Value   Restart   Function            Idle   Arguments"
 434 "\n"
 435 "----                  -----   -------   --------            ----   --------")
 436     (if (null itimer-edit-start-marker)
 437         (setq itimer-edit-start-marker (point)))
 438     (while itimers
 439       (newline 1)
 440       (prin1 (itimer-name (car itimers)))
 441       (tab-to-tab-stop)
 442       (insert (itimer-truncate-string
 443                (format "%5.5s" (itimer-value (car itimers))) 5))
 444       (tab-to-tab-stop)
 445       (insert (itimer-truncate-string
 446                (format "%5.5s" (itimer-restart (car itimers))) 5))
 447       (tab-to-tab-stop)
 448       (insert (itimer-truncate-string
 449                (format "%.19s" (itimer-function (car itimers))) 19))
 450       (tab-to-tab-stop)
 451       (if (itimer-is-idle (car itimers))
 452           (insert "yes")
 453         (insert "no"))
 454       (tab-to-tab-stop)
 455       (if (itimer-uses-arguments (car itimers))
 456           (prin1 (itimer-function-arguments (car itimers)))
 457         (prin1 'NONE))
 458       (setq itimers (cdr itimers)))
 459     ;; restore point
 460     (goto-char opoint)
 461     (if (< (point) itimer-edit-start-marker)
 462         (goto-char itimer-edit-start-marker))
 463     (setq buffer-read-only t)
 464     (display-buffer buf)))
 465
 466 (defun edit-itimers ()
 467   "Display a list of all itimers and select it for editing.
 468 The major mode of the buffer containing the listing is Itimer Edit mode.
 469 This major mode provides commands to manipulate itimers; see the documentation
 470 for `itimer-edit-mode' for more information."
 471   (interactive)
 472   ;; since user is editing, make sure displayed data is reasonably up-to-date
 473   (if (or itimer-process itimer-timer)
 474       (itimer-driver-wakeup))
 475   (list-itimers)
 476   (select-window (get-buffer-window "*Itimer List*"))
 477   (goto-char itimer-edit-start-marker)
 478   (if itimer-list
 479       (progn
 480         (forward-sexp 2)
 481         (backward-sexp)))
 482   (message "type q to quit, ? for help"))
 483
 484 ;; no point in making this interactive.
 485 (defun itimer-edit-mode ()
 486   "Major mode for manipulating itimers.
 487 Attributes of running itimers are changed by moving the cursor to the
 488 desired field and typing `s' to set that field.  The field will then be
 489 set to the value read from the minibuffer.
 490
 491 Commands:
 492 TAB    move forward a field
 493 DEL    move backward a field
 494 s      set a field
 495 d      delete the selected itimer
 496 x      start a new itimer
 497 ?      help"
 498   (kill-all-local-variables)
 499   (make-local-variable 'tab-stop-list)
 500   (setq major-mode 'itimer-edit-mode
 501         mode-name "Itimer Edit"
 502         truncate-lines t
 503         tab-stop-list '(22 32 40 60 67))
 504   (abbrev-mode 0)
 505   (auto-fill-mode 0)
 506   (buffer-flush-undo (current-buffer))
 507   (use-local-map itimer-edit-map)
 508   (set-syntax-table emacs-lisp-mode-syntax-table))
 509
 510 (put 'itimer-edit-mode 'mode-class 'special)
 511
 512 (defun itimer-edit-help ()
 513   "Help function for Itimer Edit."
 514   (interactive)
 515   (if (eq last-command 'itimer-edit-help)
 516       (describe-mode)
 517     (message "TAB, DEL select fields, (s)et field, (d)elete itimer   (type ? for more help)")))
 518
 519 (defun itimer-edit-quit ()
 520   "End Itimer Edit."
 521   (interactive)
 522   (bury-buffer (current-buffer))
 523   (if (one-window-p t)
 524       (switch-to-buffer (other-buffer (current-buffer)))
 525     (delete-window)))
 526
 527 (defun itimer-edit-set-field ()
 528   (interactive)
 529   ;; First two lines in list buffer are headers.
 530   ;; Cry out against the luser who attempts to change a field there.
 531   (if (<= (point) itimer-edit-start-marker)
 532       (error ""))
 533   ;; field-value must be initialized to be something other than a
 534   ;; number, symbol, or list.
 535   (let (itimer field (field-value ""))
 536     (setq itimer (save-excursion
 537                   ;; read the name of the itimer from the beginning of
 538                   ;; the current line.
 539                   (beginning-of-line)
 540                   (get-itimer (read (current-buffer))))
 541           field (save-excursion
 542                   (itimer-edit-beginning-of-field)
 543                   (let ((opoint (point))
 544                         (n 0))
 545                     ;; count the number of sexprs until we reach the cursor
 546                     ;; and use this info to determine which field the user
 547                     ;; wants to modify.
 548                     (beginning-of-line)
 549                     (while (and (>= opoint (point)) (< n 6))
 550                       (forward-sexp 2)
 551                       (backward-sexp)
 552                       (itimer-increment n))
 553                     (cond ((eq n 1) (error "Cannot change itimer name."))
 554                           ((eq n 2) 'value)
 555                           ((eq n 3) 'restart)
 556                           ((eq n 4) 'function)
 557                           ((eq n 5) 'is-idle)
 558                           (t 'function-argument)))))
 559     (cond ((eq field 'value)
 560            (let ((prompt "Set itimer value: "))
 561              (while (not (natnump field-value))
 562                (setq field-value (read-from-minibuffer prompt nil nil t)))))
 563           ((eq field 'restart)
 564            (let ((prompt "Set itimer restart: "))
 565              (while (and field-value (not (natnump field-value)))
 566                (setq field-value (read-from-minibuffer prompt nil nil t)))))
 567           ((eq field 'function)
 568            (let ((prompt "Set itimer function: "))
 569              (while (not (or (and (symbolp field-value) (fboundp field-value))
 570                              (and (consp field-value)
 571                                   (memq (car field-value) '(lambda macro)))))
 572                (setq field-value
 573                      (read (completing-read prompt obarray 'fboundp nil))))))
 574           ((eq field 'is-idle)
 575            (setq field-value (not (itimer-is-idle itimer))))
 576           ((eq field 'function-argument)
 577            (let ((prompt "Set itimer function argument: "))
 578              (setq field-value (read-expression prompt))
 579              (cond ((not (listp field-value))
 580                     (setq field-value (list field-value))))
 581              (if (null field-value)
 582                  (set-itimer-uses-arguments itimer nil)
 583                (set-itimer-uses-arguments itimer t)))))
 584     ;; set the itimer field
 585     (funcall (intern (concat "set-itimer-" (symbol-name field)))
 586              itimer field-value)
 587     ;; move to beginning of field to be changed
 588     (itimer-edit-beginning-of-field)
 589     ;; modify the list buffer to reflect the change.
 590     (let (buffer-read-only kill-ring)
 591       (kill-sexp 1)
 592       (kill-region (point) (progn (skip-chars-forward " \t") (point)))
 593       (prin1 field-value (current-buffer))
 594       (if (not (eolp))
 595           (tab-to-tab-stop))
 596       (backward-sexp))))
 597
 598 (defun itimer-edit-delete-itimer ()
 599   (interactive)
 600   ;; First two lines in list buffer are headers.
 601   ;; Cry out against the luser who attempts to change a field there.
 602   (if (<= (point) itimer-edit-start-marker)
 603       (error ""))
 604   (delete-itimer
 605    (read-itimer "Delete itimer: "
 606                (save-excursion (beginning-of-line) (read (current-buffer)))))
 607   ;; update list information
 608   (list-itimers))
 609
 610 (defun itimer-edit-next-field (count)
 611   (interactive "p")
 612   (itimer-edit-beginning-of-field)
 613   (cond ((> (itimer-signum count) 0)
 614          (while (not (zerop count))
 615            (forward-sexp)
 616            ;; wrap from eob to itimer-edit-start-marker
 617            (if (eobp)
 618                (progn
 619                  (goto-char itimer-edit-start-marker)
 620                  (forward-sexp)))
 621            (forward-sexp)
 622            (backward-sexp)
 623            ;; treat fields at beginning of line as if they weren't there.
 624            (if (bolp)
 625                (progn
 626                  (forward-sexp 2)
 627                  (backward-sexp)))
 628            (itimer-decrement count)))
 629         ((< (itimer-signum count) 0)
 630          (while (not (zerop count))
 631            (backward-sexp)
 632            ;; treat fields at beginning of line as if they weren't there.
 633            (if (bolp)
 634                (backward-sexp))
 635            ;; wrap from itimer-edit-start-marker to field at eob.
 636            (if (<= (point) itimer-edit-start-marker)
 637                (progn
 638                  (goto-char (point-max))
 639                  (backward-sexp)))
 640            (itimer-increment count)))))
 641
 642 (defun itimer-edit-previous-field (count)
 643   (interactive "p")
 644   (itimer-edit-next-field (- count)))
 645
 646 (defun itimer-edit-beginning-of-field ()
 647   (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point)))
 648         (back (save-excursion (backward-sexp) (point))))
 649     (cond ((eq forw-back back) (backward-sexp))
 650           ((eq forw-back (point)) t)
 651           (t (backward-sexp)))))
 652
 653 (defun itimer-truncate-string (str len)
 654   (if (<= (length str) len)
 655       str
 656     (substring str 0 len)))
 657 \f
 658 ;; internals of the itimer implementation.
 659
 660 (defun itimer-run-expired-timers (time-elapsed)
 661   (let ((itimers (copy-sequence itimer-list))
 662         (itimer)
 663         (next-wakeup 600)
 664         (idle-time)
 665         (last-event-time)
 666         (recorded-run-time)
 667         ;; process filters can be hit by stray C-g's from the user,
 668         ;; so we must protect this stuff appropriately.
 669         ;; Quit's are allowed from within itimer functions, but we
 670         ;; catch them and print a message.
 671         (inhibit-quit t))
 672     (setq next-wakeup 600)
 673     (cond ((and (boundp 'last-command-event-time)
 674                 (consp 'last-command-event-time))
 675            (setq last-event-time last-command-event-time
 676                  idle-time (itimer-time-difference (current-time)
 677                                                    last-event-time)))
 678           ((and (boundp 'last-input-time) (consp last-input-time))
 679            (setq last-event-time (list (car last-input-time)
 680                                        (cdr last-input-time)
 681                                        0)
 682                  idle-time (itimer-time-difference (current-time)
 683                                                    last-event-time)))
 684           ;; no way to do this under FSF Emacs yet.
 685           (t (setq last-event-time '(0 0 0)
 686                    idle-time 0)))
 687     (while itimers
 688       (setq itimer (car itimers))
 689       (if (itimer-is-idle itimer)
 690           (setq recorded-run-time (itimer-recorded-run-time itimer))
 691         (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer)
 692                                                     time-elapsed))))
 693       (if (if (itimer-is-idle itimer)
 694               (or (> (itimer-time-difference recorded-run-time
 695                                              last-event-time)
 696                      0)
 697                   (< idle-time (itimer-value itimer)))
 698             (> (itimer-value itimer) 0))
 699           (setq next-wakeup
 700                 (if (itimer-is-idle itimer)
 701                     (if (< idle-time (itimer-value itimer))
 702                         (min next-wakeup (- (itimer-value itimer) idle-time))
 703                       (min next-wakeup (itimer-value itimer)))
 704                   (min next-wakeup (itimer-value itimer))))
 705         (and (itimer-is-idle itimer)
 706              (set-itimer-recorded-run-time itimer (current-time)))
 707         ;; itimer has expired, we must call its function.
 708         ;; protect our local vars from the itimer function.
 709         ;; allow keyboard quit to occur, but catch and report it.
 710         ;; provide the variable `current-itimer' in case the function
 711         ;; is interested.
 712         (unwind-protect
 713             (condition-case condition-data
 714                 (save-match-data
 715                   (let* ((current-itimer itimer)
 716                          (quit-flag nil)
 717                          (inhibit-quit nil)
 718                          ;; for FSF Emacs timer.el emulation under XEmacs.
 719                          ;; eldoc expect this to be done, apparently.
 720                          (this-command nil))
 721                     (if (itimer-uses-arguments current-itimer)
 722                         (apply (itimer-function current-itimer)
 723                                (itimer-function-arguments current-itimer))
 724                       (funcall (itimer-function current-itimer)))))
 725               (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer)
 726                               (prin1-to-string condition-data)))
 727               (quit (message "itimer \"%s\" quit" (itimer-name itimer))))
 728           ;; restart the itimer if we should, otherwise delete it.
 729           (if (null (itimer-restart itimer))
 730               (delete-itimer itimer)
 731             (set-itimer-value-internal itimer (itimer-restart itimer))
 732             (setq next-wakeup (min next-wakeup (itimer-value itimer))))))
 733       (setq itimers (cdr itimers)))
 734     ;; make another sweep through the list to catch any timers
 735     ;; that might have been added by timer functions above.
 736     (setq itimers itimer-list)
 737     (while itimers
 738       (setq next-wakeup (min next-wakeup (itimer-value (car itimers)))
 739             itimers (cdr itimers)))
 740     ;; if user is viewing the timer list, update displayed info.
 741     (let ((b (get-buffer "*Itimer List*")))
 742       (if (and b (get-buffer-window b))
 743           (save-excursion
 744             (list-itimers))))
 745     next-wakeup ))
 746
 747 (defun itimer-process-filter (process string)
 748   ;; If the itimer process dies and generates output while doing
 749   ;; so, we may be called before the process-sentinel.  Sanity
 750   ;; check the output just in case...
 751   (if (not (string-match "^[0-9]" string))
 752       (progn (message "itimer process gave odd output: %s" string)
 753              ;; it may be still alive and waiting for input
 754              (process-send-string itimer-process "3\n"))
 755     ;; if there are no active itimers, return quickly.
 756     (if itimer-list
 757         (let ((wakeup nil))
 758           (unwind-protect
 759               (setq wakeup (itimer-run-expired-timers (string-to-int string)))
 760             (and (null wakeup) (process-send-string process "1\n")))
 761           (setq itimer-next-wakeup wakeup))
 762       (setq itimer-next-wakeup 600))
 763     ;; tell itimer-process when to wakeup again
 764     (process-send-string itimer-process
 765                          (concat (int-to-string itimer-next-wakeup)
 766                                  "\n"))))
 767
 768 (defun itimer-process-sentinel (process message)
 769   (let ((inhibit-quit t))
 770     (if (eq (process-status process) 'stop)
 771         (continue-process process)
 772       ;; not stopped, so it must have died.
 773       ;; cleanup first...
 774       (delete-process process)
 775       (setq itimer-process nil)
 776       ;; now, if there are any active itimers then we need to immediately
 777       ;; start another itimer process, otherwise we can wait until the next
 778       ;; start-itimer call, which will start one automatically.
 779       (if (null itimer-list)
 780           ()
 781         ;; there may have been an error message in the echo area;
 782         ;; give the user at least a little time to read it.
 783         (sit-for 2)
 784         (message "itimer process %s... respawning." (substring message 0 -1))
 785         (itimer-process-start)))))
 786
 787 (defun itimer-process-start ()
 788   (let ((inhibit-quit t)
 789         (process-connection-type nil))
 790     (setq itimer-process (start-process "itimer" nil "itimer"))
 791     (process-kill-without-query itimer-process)
 792     (set-process-filter itimer-process 'itimer-process-filter)
 793     (set-process-sentinel itimer-process 'itimer-process-sentinel)
 794     ;; Tell itimer process to wake up quickly, so that a correct
 795     ;; wakeup time can be computed.  Zero loses because of
 796     ;; underlying itimer implementations that use 0 to mean
 797     ;; `disable the itimer'.
 798     (setq itimer-next-wakeup itimer-short-interval)
 799     (process-send-string itimer-process
 800                          (format "%s\n" itimer-next-wakeup))))
 801
 802 (defun itimer-process-wakeup ()
 803   (interrupt-process itimer-process)
 804   (accept-process-output))
 805
 806 (defun itimer-timer-start ()
 807   (let ((inhibit-quit t))
 808     (setq itimer-next-wakeup itimer-short-interval
 809           itimer-timer-last-wakeup (current-time)
 810           itimer-timer (add-timeout itimer-short-interval
 811                                     'itimer-timer-driver nil nil))))
 812
 813 (defun itimer-disable-timeout (timeout)
 814   ;; Disgusting hack, but necessary because there is no other way
 815   ;; to remove a timer that has a restart value from while that
 816   ;; timer's function is being run.  (FSF Emacs only.)
 817   (if (vectorp timeout)
 818       (aset timeout 4 nil))
 819   (disable-timeout timeout))
 820
 821 (defun itimer-timer-wakeup ()
 822   (let ((inhibit-quit t))
 823     (itimer-disable-timeout itimer-timer)
 824     (setq itimer-timer (add-timeout itimer-short-interval
 825                                     'itimer-timer-driver nil 5))))
 826
 827 (defun itimer-time-difference (t1 t2)
 828   (let (usecs secs 65536-secs carry)
 829     (setq usecs (- (nth 2 t1) (nth 2 t2)))
 830     (if (< usecs 0)
 831         (setq carry 1
 832               usecs (+ usecs 1000000))
 833       (setq carry 0))
 834     (setq secs (- (nth 1 t1) (nth 1 t2) carry))
 835     (if (< secs 0)
 836          (setq carry 1
 837                secs (+ secs 65536))
 838       (setq carry 0))
 839     (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry))
 840     ;; loses for interval larger than the maximum signed Lisp integer.
 841     ;; can't really be helped.
 842     (+ (* 65536-secs 65536)
 843        secs
 844        (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000)))))
 845
 846 (defun itimer-timer-driver (&rest ignored)
 847   ;; inhibit quit because if the user quits at an inopportune
 848   ;; time, the timer process won't be launched again and the
 849   ;; system stops working.  itimer-run-expired-timers allows
 850   ;; individual timer function to be aborted, so the user can
 851   ;; escape a feral timer function.
 852   (if (not itimer-inside-driver)
 853       (let* ((inhibit-quit t)
 854              (itimer-inside-driver t)
 855              (now (current-time))
 856              (elapsed (itimer-time-difference now itimer-timer-last-wakeup))
 857              (sleep nil))
 858         (setq itimer-timer-last-wakeup now
 859               sleep (itimer-run-expired-timers elapsed))
 860         (itimer-disable-timeout itimer-timer)
 861         (setq itimer-next-wakeup sleep
 862               itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5)))))
 863
 864 (defun itimer-driver-start ()
 865   (if (fboundp 'add-timeout)
 866       (itimer-timer-start)
 867     (itimer-process-start)))
 868
 869 (defun itimer-driver-wakeup ()
 870   (if (fboundp 'add-timeout)
 871       (itimer-timer-wakeup)
 872     (itimer-process-wakeup)))