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