Mercurial > hg > xemacs-beta

comparison lisp/prim/itimer.el @ 30:ec9a17fef872 r19-15b98

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b98
author cvs
date Mon, 13 Aug 2007 08:52:29 +0200
parents 441bb1e64a06
children e04119814345
comparison
equal deleted inserted replaced
29:7976500f47f9 30:ec9a17fef872
1 ;;; itimer.el -- Interval timers for XEmacs 1 ;;; Interval timers for GNU Emacs
2 2 ;;; Copyright (C) 1988, 1991, 1993, 1997 Kyle E. Jones
3 ;; Copyright (C) 1988, 1991, 1993, 1997 Kyle E. Jones 3 ;;;
4 4 ;;; This program is free software; you can redistribute it and/or modify
5 ;; Author: Kyle Jones <kyle_jones@wonderworks.com> 5 ;;; it under the terms of the GNU General Public License as published by
6 ;; Keywords: extensions 6 ;;; the Free Software Foundation; either version 2, or (at your option)
7 7 ;;; any later version.
8 ;; This file is part of XEmacs 8 ;;;
9 9 ;;; This program is distributed in the hope that it will be useful,
10 ;; XEmacs is free software; you can redistribute it and/or modify it 10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;; under the terms of the GNU General Public License as published by 11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;; the Free Software Foundation; either version 2, or (at your option) 12 ;;; GNU General Public License for more details.
13 ;; any later version. 13 ;;;
14 14 ;;; A copy of the GNU General Public License can be obtained from this
15 ;; XEmacs is distributed in the hope that it will be useful, but 15 ;;; program's author (send electronic mail to kyle@uunet.uu.net) or from
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of 16 ;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 17 ;;; 02139, USA.
18 ;; General Public License for more details. 18 ;;;
19 19 ;;; Send bug reports to kyle_jones@wonderworks.com
20 ;; A copy of the GNU General Public License can be obtained from this
21 ;; program's author (send electronic mail to kyle@uunet.uu.net) or
22 ;; from the Free Software Foundation, Inc., 59 Temple Place - Suite
23 ;; 330, Boston, MA 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF
26
27 ;;; Commentary:
28
29 ;; Send bug reports to kyle_jones@wonderworks.com
30
31 ;;; Code:
32 20
33 (provide 'itimer) 21 (provide 'itimer)
34 22
35 ;; `itimer' feature means Emacs-Lisp programmers get: 23 ;; `itimer' feature means Emacs-Lisp programmers get:
36 ;; itimerp 24 ;; itimerp
37 ;; itimer-value 25 ;; itimer-value
38 ;; itimer-restart 26 ;; itimer-restart
39 ;; itimer-function 27 ;; itimer-function
40 ;; itimer-function-argument 28 ;; itimer-uses-arguments
29 ;; itimer-function-arguments
41 ;; set-itimer-value 30 ;; set-itimer-value
42 ;; set-itimer-restart 31 ;; set-itimer-restart
43 ;; set-itimer-function 32 ;; set-itimer-function
44 ;; set-itimer-uses-argument 33 ;; set-itimer-uses-arguments
45 ;; set-itimer-function-argument 34 ;; set-itimer-function-arguments
46 ;; get-itimer 35 ;; get-itimer
47 ;; start-itimer 36 ;; start-itimer
48 ;; read-itimer 37 ;; read-itimer
49 ;; delete-itimer 38 ;; delete-itimer
39 ;; activate-itimer
50 ;; 40 ;;
51 ;; Interactive users get these commands: 41 ;; Interactive users get these commands:
52 ;; edit-itimers 42 ;; edit-itimers
53 ;; list-itimers 43 ;; list-itimers
54 ;; start-itimer 44 ;; start-itimer
55 ;; 45 ;;
56 ;; See the doc strings of these functions for more information. 46 ;; See the doc strings of these functions for more information.
57 47
58 (defvar itimer-version "1.02" 48 (defvar itimer-version "1.03"
59 "Version number of the itimer package.") 49 "Version number of the itimer package.")
60 50
61 (defvar itimer-list nil 51 (defvar itimer-list nil
62 "List of all active itimers.") 52 "List of all active itimers.")
63 53
165 155
166 ;; Functions to access and modify itimer attributes. 156 ;; Functions to access and modify itimer attributes.
167 157
168 (defun itimerp (obj) 158 (defun itimerp (obj)
169 "Returns non-nil iff OBJ is an itimer." 159 "Returns non-nil iff OBJ is an itimer."
170 (and (consp obj) (stringp (car obj)) (eq (length obj) 6))) 160 (and (consp obj) (eq (length obj) 8)))
171 161
172 (defun itimer-name (itimer) 162 (defun itimer-name (itimer)
173 "Returns the name of ITIMER." 163 "Returns the name of ITIMER."
174 (check-itimer itimer) 164 (check-itimer itimer)
175 (car itimer)) 165 (car itimer))
189 "Returns the function of ITIMER. 179 "Returns the function of ITIMER.
190 This function is called each time ITIMER expires." 180 This function is called each time ITIMER expires."
191 (check-itimer itimer) 181 (check-itimer itimer)
192 (nth 3 itimer)) 182 (nth 3 itimer))
193 183
194 (defun itimer-uses-argument (itimer) 184 (defun itimer-is-idle (itimer)
195 "Returns non-nil if the function of ITIMER will be called with an argment. 185 "Returns non-nil if ITIMER is an idle timer.
196 ITIMER's function is called with this argument each timer ITIMER expires." 186 Normal timers eexpire after a set interval. Idle timers expire
187 only after Emacs has been idle for a specific interval. ``Idle''
188 means no command events within the interval."
197 (check-itimer itimer) 189 (check-itimer itimer)
198 (nth 4 itimer)) 190 (nth 4 itimer))
199 191
200 (defun itimer-function-argument (itimer) 192 (defun itimer-uses-arguments (itimer)
201 "Returns the function argument of ITIMER. 193 "Returns non-nil if the function of ITIMER will be called with arguments.
202 ITIMER's function is called with this argument each timer ITIMER expires." 194 ITIMER's function is called with the arguments each time ITIMER expires.
195 The arguments themselves are retrievable with `itimer-function-arguments'."
203 (check-itimer itimer) 196 (check-itimer itimer)
204 (nth 5 itimer)) 197 (nth 5 itimer))
198
199 (defun itimer-function-arguments (itimer)
200 "Returns the function arguments of ITIMER as a list.
201 ITIMER's function is called with these argument each timer ITIMER expires."
202 (check-itimer itimer)
203 (nth 6 itimer))
204
205 (defun itimer-recorded-run-time (itimer)
206 (check-itimer itimer)
207 (nth 7 itimer))
205 208
206 (defun set-itimer-value (itimer value) 209 (defun set-itimer-value (itimer value)
207 "Set the timeout value of ITIMER to be VALUE. 210 "Set the timeout value of ITIMER to be VALUE.
208 Itimer will expire is this many seconds. 211 Itimer will expire is this many seconds.
209 If your version of Emacs supports floating point numbers then 212 If your version of Emacs supports floating point numbers then
246 (defun set-itimer-function (itimer function) 249 (defun set-itimer-function (itimer function)
247 "Set the function of ITIMER to be FUNCTION. 250 "Set the function of ITIMER to be FUNCTION.
248 FUNCTION will be called when itimer expires. 251 FUNCTION will be called when itimer expires.
249 Returns FUNCTION." 252 Returns FUNCTION."
250 (check-itimer itimer) 253 (check-itimer itimer)
251 (setcar (cdr (cdr (cdr itimer))) function)) 254 (setcar (nthcdr 3 itimer) function))
252 255
253 (defun set-itimer-uses-argument (itimer flag) 256 (defun set-itimer-is-idle (itimer flag)
254 "Sets when the function of ITIMER is called with an argument. 257 "Sets flag that says whether ITIMER is an idle timer.
258 If FLAG is non-nil, then ITIMER will eb considered an idle timer.
259 Returns FLAG."
260 (check-itimer itimer)
261 (setcar (nthcdr 4 itimer) flag))
262
263 (defun set-itimer-uses-arguments (itimer flag)
264 "Sets flag that says whether the function of ITIMER is called with arguments.
255 If FLAG is non-nil, then the function will be called with one argument, 265 If FLAG is non-nil, then the function will be called with one argument,
256 otherwise the function will be called with no arguments. 266 otherwise the function will be called with no arguments.
257 Returns FLAG." 267 Returns FLAG."
258 (check-itimer itimer) 268 (check-itimer itimer)
259 (setcar (nthcdr 4 itimer) flag)) 269 (setcar (nthcdr 5 itimer) flag))
260 270
261 (defun set-itimer-function-argument (itimer argument) 271 (defun set-itimer-function-arguments (itimer &rest arguments)
262 "Set the function of ITIMER to be ARGUMENT. 272 "Set the function arguments of ITIMER to be ARGUMENTS.
263 The function of ITIMER will be called with ARGUMENT as its solt argument 273 The function of ITIMER will be called with ARGUMENTS when itimer expires.
264 when itimer expires. 274 Returns ARGUMENTS."
265 Returns ARGUMENT." 275 (check-itimer itimer)
266 (check-itimer itimer) 276 (setcar (nthcdr 6 itimer) arguments))
267 (setcar (nthcdr 5 itimer) argument)) 277
278 (defun set-itimer-recorded-run-time (itimer time)
279 (check-itimer itimer)
280 (setcar (nthcdr 7 itimer) time))
268 281
269 (defun get-itimer (name) 282 (defun get-itimer (name)
270 "Return itimer named NAME, or nil if there is none." 283 "Return itimer named NAME, or nil if there is none."
271 (check-string name) 284 (check-string name)
272 (assoc name itimer-list)) 285 (assoc name itimer-list))
282 "Deletes ITIMER. ITIMER may be an itimer or the name of one." 295 "Deletes ITIMER. ITIMER may be an itimer or the name of one."
283 (check-itimer-coerce-string itimer) 296 (check-itimer-coerce-string itimer)
284 (setq itimer-list (delq itimer itimer-list))) 297 (setq itimer-list (delq itimer itimer-list)))
285 298
286 (defun start-itimer (name function value &optional restart 299 (defun start-itimer (name function value &optional restart
287 with-arg function-argument) 300 is-idle with-args &rest function-arguments)
288 "Start an itimer. 301 "Start an itimer.
289 Args are NAME, FUNCTION, VALUE &optional RESTART, WITH-ARG, FUNCTION-ARGUMENT. 302 Arguments are
303 NAME, FUNCTION, VALUE &optional RESTART, IS-IDLE, WITH-ARGS, &rest FUNCTION-ARGUMENTS.
290 NAME is an identifier for the itimer. It must be a string. If an itimer 304 NAME is an identifier for the itimer. It must be a string. If an itimer
291 already exists with this name, NAME will be modified slightly to until 305 already exists with this name, NAME will be modified slightly to until
292 it is unique. 306 it is unique.
293 FUNCTION should be a function (or symbol naming one) of one argument. It 307 FUNCTION should be a function (or symbol naming one). It
294 will be called each time the itimer expires with an argument of 308 will be called each time the itimer expires with arguments of
295 FUNCTION-ARGUMENT. The function can access the itimer that 309 FUNCTION-ARGUMENTS. The function can access the itimer that
296 invoked it through the variable `current-itimer'. If WITH-ARG 310 invoked it through the variable `current-itimer'. If WITH-ARGS
297 is nil then FUNCTION is called with no arguments. This is for 311 is nil then FUNCTION is called with no arguments. This is for
298 backward compatibility with older versions of the itimer 312 backward compatibility with older versions of the itimer
299 package which always called FUNCTION with no arguments. 313 package which always called FUNCTION with no arguments.
300 VALUE is the number of seconds until this itimer expires. 314 VALUE is the number of seconds until this itimer expires.
301 If your version of Emacs supports floating point numbers then 315 If your version of Emacs supports floating point numbers then
304 Optional fourth arg RESTART non-nil means that this itimer should be 318 Optional fourth arg RESTART non-nil means that this itimer should be
305 restarted automatically after its function is called. Normally an itimer 319 restarted automatically after its function is called. Normally an itimer
306 is deleted at expiration after its function has returned. 320 is deleted at expiration after its function has returned.
307 If non-nil RESTART should be a number indicating the value at which the 321 If non-nil RESTART should be a number indicating the value at which the
308 itimer should be set at restart time. 322 itimer should be set at restart time.
323 Optional fifth arg IS-IDLE specified if this is an idle timer.
324 Normal timers eexpire after a set interval. Idle timers expire
325 only after Emacs has been idle for specific interval. ``Idle''
326 means no command events within the interval.
309 Returns the newly created itimer." 327 Returns the newly created itimer."
310 (interactive 328 (interactive
311 (list (completing-read "Start itimer: " itimer-list) 329 (list (completing-read "Start itimer: " itimer-list)
312 (read (completing-read "Itimer function: " obarray 'fboundp)) 330 (read (completing-read "Itimer function: " obarray 'fboundp))
313 (let (value) 331 (let (value)
329 (let ((oname name) 347 (let ((oname name)
330 (num 2)) 348 (num 2))
331 (while (get-itimer name) 349 (while (get-itimer name)
332 (setq name (concat oname "<" num ">")) 350 (setq name (concat oname "<" num ">"))
333 (itimer-increment num))) 351 (itimer-increment num)))
334 ;; If there's no itimer process, start one now. 352 (activate-itimer (list name value restart function is-idle
335 ;; Otherwise wake up the itimer process so that seconds slept before 353 with-args function-arguments (list 0 0 0)))
354 (car itimer-list))
355
356 (defun make-itimer ()
357 "Create an unactivated itimer.
358 The itimer will not begin running until activated with `activate-itimer'.
359 Set the itimer's expire interval with `set-itimer-value'.
360 Set the itimer's function interval with `set-itimer-function'.
361 Once this is done, the timer can be activated."
362 (list nil 0 nil 'ignore nil nil nil (list 0 0 0)))
363
364 (defun activate-itimer (itimer)
365 "Activate ITIMER, which was previously created with `make-itimer'.
366 ITIMER will be added to the global list of running itimers,
367 its FUNCTION will be called when it expires, and so on."
368 (check-itimer itimer)
369 (if (memq itimer itimer-list)
370 (error "itimer already activated"))
371 (if (not (numberp (itimer-value itimer)))
372 (error "itimer timeout value not a number: %s" (itimer-value itimer)))
373 (if (<= (itimer-value itimer) 0)
374 (error "itimer timeout value not positive: %s" (itimer-value itimer)))
375 ;; If there's no itimer driver/process, start one now.
376 ;; Otherwise wake up the itimer driver so that seconds slept before
336 ;; the new itimer is created won't be counted against it. 377 ;; the new itimer is created won't be counted against it.
337 (if (or itimer-process itimer-timer) 378 (if (or itimer-process itimer-timer)
338 (itimer-driver-wakeup) 379 (itimer-driver-wakeup)
339 (itimer-driver-start)) 380 (itimer-driver-start))
381 ;; Roll a unique name for the timer if it doesn't have a name
382 ;; already.
383 (if (not (stringp (car itimer)))
384 (let ((name "itimer-0")
385 (oname "itimer-")
386 (num 1))
387 (while (get-itimer name)
388 (setq name (concat oname "<" num ">"))
389 (itimer-increment num))
390 (setcar itimer name))
391 ;; signal an error if the timer's name matches an already
392 ;; activated timer.
393 (if (get-itimer (itimer-name itimer))
394 (error "itimer named \"%s\" already existing and activated"
395 (itimer-name itimer))))
340 (let ((inhibit-quit t)) 396 (let ((inhibit-quit t))
341 ;; add the itimer to the global list 397 ;; add the itimer to the global list
342 (setq itimer-list 398 (setq itimer-list (cons itimer itimer-list))
343 (cons (list name value restart function with-arg function-argument) 399 ;; If the itimer process is scheduled to wake up too late for
344 itimer-list)) 400 ;; the itimer we wake it up to calculate a correct wakeup
345 ;; If the itimer process is scheduled to wake up too late for the itimer 401 ;; value giving consideration to the newly added itimer.
346 ;; we wake it up to calculate a correct wakeup value giving consideration 402 (if (< (itimer-value itimer) itimer-next-wakeup)
347 ;; to the newly added itimer. 403 (itimer-driver-wakeup))))
348 (if (< value itimer-next-wakeup)
349 (itimer-driver-wakeup)))
350 (car itimer-list))
351 404
352 ;; User level functions to list and modify existing itimers. 405 ;; User level functions to list and modify existing itimers.
353 ;; Itimer Edit major mode, and the editing commands thereof. 406 ;; Itimer Edit major mode, and the editing commands thereof.
354 407
355 (defun list-itimers () 408 (defun list-itimers ()
365 (set-buffer buf) 418 (set-buffer buf)
366 (itimer-edit-mode) 419 (itimer-edit-mode)
367 (setq buffer-read-only nil) 420 (setq buffer-read-only nil)
368 (erase-buffer) 421 (erase-buffer)
369 (insert 422 (insert
370 "Name Value Restart Function Argument\n" 423 "Name Value Restart Function Idle Arguments"
371 "---- ----- ------- -------- --------") 424 "\n"
425 "---- ----- ------- -------- ---- --------")
372 (if (null itimer-edit-start-marker) 426 (if (null itimer-edit-start-marker)
373 (setq itimer-edit-start-marker (point))) 427 (setq itimer-edit-start-marker (point)))
374 (while itimers 428 (while itimers
375 (newline 1) 429 (newline 1)
376 (prin1 (itimer-name (car itimers))) 430 (prin1 (itimer-name (car itimers)))
380 (tab-to-tab-stop) 434 (tab-to-tab-stop)
381 (insert (itimer-truncate-string 435 (insert (itimer-truncate-string
382 (format "%5.5s" (itimer-restart (car itimers))) 5)) 436 (format "%5.5s" (itimer-restart (car itimers))) 5))
383 (tab-to-tab-stop) 437 (tab-to-tab-stop)
384 (insert (itimer-truncate-string 438 (insert (itimer-truncate-string
385 (format "%.26s" (itimer-function (car itimers))) 26)) 439 (format "%.19s" (itimer-function (car itimers))) 19))
386 (tab-to-tab-stop) 440 (tab-to-tab-stop)
387 (if (itimer-uses-argument (car itimers)) 441 (if (itimer-is-idle (car itimers))
388 (prin1 (itimer-function-argument (car itimers))) 442 (insert "yes")
443 (insert "no"))
444 (tab-to-tab-stop)
445 (if (itimer-uses-arguments (car itimers))
446 (prin1 (itimer-function-arguments (car itimers)))
389 (prin1 'NONE)) 447 (prin1 'NONE))
390 (setq itimers (cdr itimers))) 448 (setq itimers (cdr itimers)))
391 ;; restore point 449 ;; restore point
392 (goto-char opoint) 450 (goto-char opoint)
393 (if (< (point) itimer-edit-start-marker) 451 (if (< (point) itimer-edit-start-marker)
414 (message "type q to quit, ? for help")) 472 (message "type q to quit, ? for help"))
415 473
416 ;; no point in making this interactive. 474 ;; no point in making this interactive.
417 (defun itimer-edit-mode () 475 (defun itimer-edit-mode ()
418 "Major mode for manipulating itimers. 476 "Major mode for manipulating itimers.
419 Atrributes of running itimers are changed by moving the cursor to the 477 Attributes of running itimers are changed by moving the cursor to the
420 desired field and typing `s' to set that field. The field will then be 478 desired field and typing `s' to set that field. The field will then be
421 set to the value read from the minibuffer. 479 set to the value read from the minibuffer.
422 480
423 Commands: 481 Commands:
424 TAB move forward a field 482 TAB move forward a field
430 (kill-all-local-variables) 488 (kill-all-local-variables)
431 (make-local-variable 'tab-stop-list) 489 (make-local-variable 'tab-stop-list)
432 (setq major-mode 'itimer-edit-mode 490 (setq major-mode 'itimer-edit-mode
433 mode-name "Itimer Edit" 491 mode-name "Itimer Edit"
434 truncate-lines t 492 truncate-lines t
435 tab-stop-list '(22 32 40 67)) 493 tab-stop-list '(22 32 40 60 67))
436 (abbrev-mode 0) 494 (abbrev-mode 0)
437 (auto-fill-mode 0) 495 (auto-fill-mode 0)
438 (buffer-flush-undo (current-buffer)) 496 (buffer-flush-undo (current-buffer))
439 (use-local-map itimer-edit-map) 497 (use-local-map itimer-edit-map)
440 (set-syntax-table emacs-lisp-mode-syntax-table)) 498 (set-syntax-table emacs-lisp-mode-syntax-table))
476 (n 0)) 534 (n 0))
477 ;; count the number of sexprs until we reach the cursor 535 ;; count the number of sexprs until we reach the cursor
478 ;; and use this info to determine which field the user 536 ;; and use this info to determine which field the user
479 ;; wants to modify. 537 ;; wants to modify.
480 (beginning-of-line) 538 (beginning-of-line)
481 (while (and (>= opoint (point)) (< n 5)) 539 (while (and (>= opoint (point)) (< n 6))
482 (forward-sexp 2) 540 (forward-sexp 2)
483 (backward-sexp) 541 (backward-sexp)
484 (itimer-increment n)) 542 (itimer-increment n))
485 (cond ((eq n 1) (error "Cannot change itimer name.")) 543 (cond ((eq n 1) (error "Cannot change itimer name."))
486 ((eq n 2) 'value) 544 ((eq n 2) 'value)
487 ((eq n 3) 'restart) 545 ((eq n 3) 'restart)
488 ((eq n 4) 'function) 546 ((eq n 4) 'function)
547 ((eq n 5) 'is-idle)
489 (t 'function-argument))))) 548 (t 'function-argument)))))
490 (cond ((eq field 'value) 549 (cond ((eq field 'value)
491 (let ((prompt "Set itimer value: ")) 550 (let ((prompt "Set itimer value: "))
492 (while (not (natnump field-value)) 551 (while (not (natnump field-value))
493 (setq field-value (read-from-minibuffer prompt nil nil t))))) 552 (setq field-value (read-from-minibuffer prompt nil nil t)))))
500 (while (not (or (and (symbolp field-value) (fboundp field-value)) 559 (while (not (or (and (symbolp field-value) (fboundp field-value))
501 (and (consp field-value) 560 (and (consp field-value)
502 (memq (car field-value) '(lambda macro))))) 561 (memq (car field-value) '(lambda macro)))))
503 (setq field-value 562 (setq field-value
504 (read (completing-read prompt obarray 'fboundp nil)))))) 563 (read (completing-read prompt obarray 'fboundp nil))))))
564 ((eq field 'is-idle)
565 (setq field-value (not (itimer-is-idle itimer))))
505 ((eq field 'function-argument) 566 ((eq field 'function-argument)
506 (let ((prompt "Set itimer function argument: ")) 567 (let ((prompt "Set itimer function argument: "))
507 (setq field-value (read-expression prompt)) 568 (setq field-value (read-expression prompt))
508 (set-itimer-uses-argument itimer t)))) 569 (cond ((not (listp field-value))
570 (setq field-value (list field-value))))
571 (if (null field-value)
572 (set-itimer-uses-arguments itimer nil)
573 (set-itimer-uses-arguments itimer t)))))
509 ;; set the itimer field 574 ;; set the itimer field
510 (funcall (intern (concat "set-itimer-" (symbol-name field))) 575 (funcall (intern (concat "set-itimer-" (symbol-name field)))
511 itimer field-value) 576 itimer field-value)
512 ;; move to beginning of field to be changed 577 ;; move to beginning of field to be changed
513 (itimer-edit-beginning-of-field) 578 (itimer-edit-beginning-of-field)
584 649
585 (defun itimer-run-expired-timers (time-elapsed) 650 (defun itimer-run-expired-timers (time-elapsed)
586 (let ((itimers (copy-sequence itimer-list)) 651 (let ((itimers (copy-sequence itimer-list))
587 (itimer) 652 (itimer)
588 (next-wakeup 600) 653 (next-wakeup 600)
654 (idle-time)
655 (last-event-time)
656 (recorded-run-time)
589 ;; process filters can be hit by stray C-g's from the user, 657 ;; process filters can be hit by stray C-g's from the user,
590 ;; so we must protect this stuff appropriately. 658 ;; so we must protect this stuff appropriately.
591 ;; Quit's are allowed from within itimer functions, but we 659 ;; Quit's are allowed from within itimer functions, but we
592 ;; catch them and print a message. 660 ;; catch them and print a message.
593 (inhibit-quit t)) 661 (inhibit-quit t))
594 (setq next-wakeup 600) 662 (setq next-wakeup 600)
663 (if (and (boundp 'last-input-time) (consp last-input-time))
664 (setq last-event-time (list (car last-input-time)
665 (cdr last-input-time)
666 0)
667 idle-time (itimer-time-difference (current-time)
668 last-event-time))
669 ;; no way to do this under FSF Emacs yet.
670 (setq last-event-time '(0 0 0)
671 idle-time 0))
595 (while itimers 672 (while itimers
596 (setq itimer (car itimers)) 673 (setq itimer (car itimers))
597 (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer) 674 (if (itimer-is-idle itimer)
598 time-elapsed))) 675 (setq recorded-run-time (itimer-recorded-run-time itimer))
599 (if (> (itimer-value itimer) 0) 676 (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer)
677 time-elapsed))))
678 (if (if (itimer-is-idle itimer)
679 (or (> (itimer-time-difference recorded-run-time
680 last-event-time)
681 0)
682 (< idle-time (itimer-value itimer)))
683 (> (itimer-value itimer) 0))
600 (setq next-wakeup 684 (setq next-wakeup
601 (min next-wakeup (itimer-value itimer))) 685 (if (itimer-is-idle itimer)
686 (if (< idle-time (itimer-value itimer))
687 (min next-wakeup (- (itimer-value itimer) idle-time))
688 (min next-wakeup (itimer-value itimer)))
689 (min next-wakeup (itimer-value itimer))))
690 (and (itimer-is-idle itimer)
691 (set-itimer-recorded-run-time itimer (current-time)))
602 ;; itimer has expired, we must call its function. 692 ;; itimer has expired, we must call its function.
603 ;; protect our local vars from the itimer function. 693 ;; protect our local vars from the itimer function.
604 ;; allow keyboard quit to occur, but catch and report it. 694 ;; allow keyboard quit to occur, but catch and report it.
605 ;; provide the variable `current-itimer' in case the function 695 ;; provide the variable `current-itimer' in case the function
606 ;; is interested. 696 ;; is interested.
608 (save-match-data 698 (save-match-data
609 (let* ((current-itimer itimer) 699 (let* ((current-itimer itimer)
610 (quit-flag nil) 700 (quit-flag nil)
611 (inhibit-quit nil) 701 (inhibit-quit nil)
612 itimer itimers time-elapsed) 702 itimer itimers time-elapsed)
613 (if (itimer-uses-argument current-itimer) 703 (if (itimer-uses-arguments current-itimer)
614 (funcall (itimer-function current-itimer) 704 (apply (itimer-function current-itimer)
615 (itimer-function-argument current-itimer)) 705 (itimer-function-arguments current-itimer))
616 (funcall (itimer-function current-itimer))))) 706 (funcall (itimer-function current-itimer)))))
617 (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer) 707 (error (message "itimer \"%s\" signaled: %s" (itimer-name itimer)
618 (prin1-to-string condition-data))) 708 (prin1-to-string condition-data)))
619 (quit (message "itimer \"%s\" quit" (itimer-name itimer)))) 709 (quit (message "itimer \"%s\" quit" (itimer-name itimer))))
620 ;; restart the itimer if we should, otherwise delete it. 710 ;; restart the itimer if we should, otherwise delete it.
699 (disable-timeout itimer-timer))) 789 (disable-timeout itimer-timer)))
700 (setq itimer-timer (add-timeout itimer-short-interval 790 (setq itimer-timer (add-timeout itimer-short-interval
701 'itimer-timer-driver nil nil)))) 791 'itimer-timer-driver nil nil))))
702 792
703 (defun itimer-time-difference (t1 t2) 793 (defun itimer-time-difference (t1 t2)
704 (let (usecs secs 65536-secs) 794 (let (usecs secs 65536-secs carry)
705 (setq usecs (- (nth 2 t1) (nth 2 t2))) 795 (setq usecs (- (nth 2 t1) (nth 2 t2)))
706 (if (< usecs 0) 796 (if (< usecs 0)
707 (setq carry 1 797 (setq carry 1
708 usecs (+ usecs 1000000)) 798 usecs (+ usecs 1000000))
709 (setq carry 0)) 799 (setq carry 0))
710 (setq secs (- (nth 1 t1) (nth 1 t2) carry)) 800 (setq secs (- (nth 1 t1) (nth 1 t2) carry))
711 (if (< secs 0) 801 (if (< secs 0)
712 (setq carry 1 802 (setq carry 1
713 secs (+ secs 65536)) 803 secs (+ secs 65536))
714 (setq carry 0)) 804 (setq carry 0))
715 (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry)) 805 (setq 65536-secs (- (nth 0 t1) (nth 0 t2) carry))
716 ;; loses for interval larger than the maximum signed Lisp integer. 806 ;; loses for interval larger than the maximum signed Lisp integer.
717 ;; can't really be helped. 807 ;; can't really be helped.
718 (+ (* 65536-secs 65536) 808 (+ (* 65536-secs 65536)
741 831
742 (defun itimer-driver-wakeup () 832 (defun itimer-driver-wakeup ()
743 (if (fboundp 'add-timeout) 833 (if (fboundp 'add-timeout)
744 (itimer-timer-wakeup) 834 (itimer-timer-wakeup)
745 (itimer-process-wakeup))) 835 (itimer-process-wakeup)))
746
747 ;;; itimer.el ends here