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