Mercurial > hg > xemacs-beta

comparison lisp/itimer.el @ 267:966663fcf606 r20-5b32

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-5b32
author cvs
date Mon, 13 Aug 2007 10:26:29 +0200
parents 41ff10fd062f
children c5d627a313b1
comparison
equal deleted inserted replaced
266:18d185df8c54 267:966663fcf606
1 ;;; itimer.el --- Interval timers for XEmacs 1 ;;; Interval timers for GNU Emacs
2 2 ;;; Copyright (C) 1988, 1991, 1993, 1997, 1998 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: internal, dumped 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 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF
26
27 ;;; Commentary:
28
29 ;; This file is dumped with XEmacs.
30
31 ;; Send bug reports to kyle_jones@wonderworks.com
32
33 ;;; Code:
34 20
35 (provide 'itimer) 21 (provide 'itimer)
36 22
37 ;; `itimer' feature means Emacs-Lisp programmers get: 23 ;; `itimer' feature means Emacs-Lisp programmers get:
38 ;; itimerp 24 ;; itimerp
58 ;; list-itimers 44 ;; list-itimers
59 ;; start-itimer 45 ;; start-itimer
60 ;; 46 ;;
61 ;; See the doc strings of these functions for more information. 47 ;; See the doc strings of these functions for more information.
62 48
63 (defvar itimer-version "1.06" 49 (defvar itimer-version "1.07"
64 "Version number of the itimer package.") 50 "Version number of the itimer package.")
65 51
66 (defvar itimer-list nil 52 (defvar itimer-list nil
67 "List of all active itimers.") 53 "List of all active itimers.")
68 54
81 Used internally to make the scheduler wake up early. 67 Used internally to make the scheduler wake up early.
82 Unit is seconds.") 68 Unit is seconds.")
83 69
84 ;; This value is maintained internally; it does not determine 70 ;; This value is maintained internally; it does not determine
85 ;; itimer granularity. Itimer granularity is 1 second if your 71 ;; itimer granularity. Itimer granularity is 1 second if your
86 ;; Emacs doens't support floats or your system doesn't have a 72 ;; Emacs doesn't support floats or your system doesn't have a
87 ;; clock with microsecond granularity. Otherwise granularity is 73 ;; clock with microsecond granularity. Otherwise granularity is
88 ;; to the microsend, although you can't possibly get timers to be 74 ;; to the microsecond, although you can't possibly get timers to be
89 ;; executed with this kind of accuracy in practice. There will 75 ;; executed with this kind of accuracy in practice. There will
90 ;; be delays due to system and Emacs internal activity that delay 76 ;; be delays due to system and Emacs internal activity that delay
91 ;; dealing with syunchronous events and process output. 77 ;; dealing with synchronous events and process output.
92 (defvar itimer-next-wakeup itimer-short-interval 78 (defvar itimer-next-wakeup itimer-short-interval
93 "Itimer process will wakeup to service running itimers within this 79 "Itimer process will wakeup to service running itimers within this
94 many seconds.") 80 many seconds.")
95 81
96 (defvar itimer-edit-map nil 82 (defvar itimer-edit-map nil
515 mode-name "Itimer Edit" 501 mode-name "Itimer Edit"
516 truncate-lines t 502 truncate-lines t
517 tab-stop-list '(22 32 40 60 67)) 503 tab-stop-list '(22 32 40 60 67))
518 (abbrev-mode 0) 504 (abbrev-mode 0)
519 (auto-fill-mode 0) 505 (auto-fill-mode 0)
520 (buffer-disable-undo (current-buffer)) 506 (buffer-flush-undo (current-buffer))
521 (use-local-map itimer-edit-map) 507 (use-local-map itimer-edit-map)
522 (set-syntax-table emacs-lisp-mode-syntax-table)) 508 (set-syntax-table emacs-lisp-mode-syntax-table))
523 509
524 (put 'itimer-edit-mode 'mode-class 'special) 510 (put 'itimer-edit-mode 'mode-class 'special)
525 511
682 ;; so we must protect this stuff appropriately. 668 ;; so we must protect this stuff appropriately.
683 ;; Quit's are allowed from within itimer functions, but we 669 ;; Quit's are allowed from within itimer functions, but we
684 ;; catch them and print a message. 670 ;; catch them and print a message.
685 (inhibit-quit t)) 671 (inhibit-quit t))
686 (setq next-wakeup 600) 672 (setq next-wakeup 600)
687 (if (and (boundp 'last-input-time) (consp last-input-time)) 673 (cond ((and (boundp 'last-command-event-time)
688 (setq last-event-time (list (car last-input-time) 674 (consp 'last-command-event-time))
689 (cdr last-input-time) 675 (setq last-event-time last-command-event-time
690 0) 676 idle-time (itimer-time-difference (current-time)
691 idle-time (itimer-time-difference (current-time) 677 last-event-time)))
692 last-event-time)) 678 ((and (boundp 'last-input-time) (consp last-input-time))
693 ;; no way to do this under FSF Emacs yet. 679 (setq last-event-time (list (car last-input-time)
694 (setq last-event-time '(0 0 0) 680 (cdr last-input-time)
695 idle-time 0)) 681 0)
682 idle-time (itimer-time-difference (current-time)
683 last-event-time)))
684 ;; no way to do this under FSF Emacs yet.
685 (t (setq last-event-time '(0 0 0)
686 idle-time 0)))
696 (while itimers 687 (while itimers
697 (setq itimer (car itimers)) 688 (setq itimer (car itimers))
698 (if (itimer-is-idle itimer) 689 (if (itimer-is-idle itimer)
699 (setq recorded-run-time (itimer-recorded-run-time itimer)) 690 (setq recorded-run-time (itimer-recorded-run-time itimer))
700 (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer) 691 (set-itimer-value-internal itimer (max 0 (- (itimer-value itimer)
739 (if (null (itimer-restart itimer)) 730 (if (null (itimer-restart itimer))
740 (delete-itimer itimer) 731 (delete-itimer itimer)
741 (set-itimer-value-internal itimer (itimer-restart itimer)) 732 (set-itimer-value-internal itimer (itimer-restart itimer))
742 (setq next-wakeup (min next-wakeup (itimer-value itimer)))))) 733 (setq next-wakeup (min next-wakeup (itimer-value itimer))))))
743 (setq itimers (cdr itimers))) 734 (setq itimers (cdr itimers)))
744 ;; if user is editing itimers, update displayed info 735 ;; make another sweep through the list to catch any timers
745 (if (eq major-mode 'itimer-edit-mode) 736 ;; that might have been added by timer functions above.
746 (list-itimers)) 737 (setq itimers itimer-list)
738 (while itimers
739 (setq next-wakeup (min next-wakeup (itimer-value (car itimers)))
740 itimers (cdr itimers)))
741 ;; if user is viewing the timer list, update displayed info.
742 (let ((b (get-buffer "*Itimer List*")))
743 (if (and b (get-buffer-window b))
744 (save-excursion
745 (list-itimers))))
747 next-wakeup )) 746 next-wakeup ))
748 747
749 (defun itimer-process-filter (process string) 748 (defun itimer-process-filter (process string)
750 ;; If the itimer process dies and generates output while doing 749 ;; If the itimer process dies and generates output while doing
751 ;; so, we may be called before the process-sentinel. Sanity 750 ;; so, we may be called before the process-sentinel. Sanity
810 (setq itimer-next-wakeup itimer-short-interval 809 (setq itimer-next-wakeup itimer-short-interval
811 itimer-timer-last-wakeup (current-time) 810 itimer-timer-last-wakeup (current-time)
812 itimer-timer (add-timeout itimer-short-interval 811 itimer-timer (add-timeout itimer-short-interval
813 'itimer-timer-driver nil nil)))) 812 'itimer-timer-driver nil nil))))
814 813
814 (defun itimer-disable-timeout (timeout)
815 ;; Disgusting hack, but necessary because there is no other way
816 ;; to remove a timer that has a restart value from while that
817 ;; timer's function is being run. (FSF Emacs only.)
818 (if (vectorp timeout)
819 (aset timeout 4 nil))
820 (disable-timeout timeout))
821
815 (defun itimer-timer-wakeup () 822 (defun itimer-timer-wakeup ()
816 (let ((inhibit-quit t)) 823 (let ((inhibit-quit t))
817 (cond ((fboundp 'disable-timeout) 824 (itimer-disable-timeout itimer-timer)
818 (disable-timeout itimer-timer))
819 ((fboundp 'cancel-timer)
820 (cancel-timer itimer-timer)))
821 (setq itimer-timer (add-timeout itimer-short-interval 825 (setq itimer-timer (add-timeout itimer-short-interval
822 'itimer-timer-driver nil 5)))) 826 'itimer-timer-driver nil 5))))
823 827
824 (defun itimer-time-difference (t1 t2) 828 (defun itimer-time-difference (t1 t2)
825 (let (usecs secs 65536-secs carry) 829 (let (usecs secs 65536-secs carry)
840 secs 844 secs
841 (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000))))) 845 (/ usecs (if (featurep 'lisp-float-type) 1e6 1000000)))))
842 846
843 (defun itimer-timer-driver (&rest ignored) 847 (defun itimer-timer-driver (&rest ignored)
844 ;; inhibit quit because if the user quits at an inopportune 848 ;; inhibit quit because if the user quits at an inopportune
845 ;; time, the timer process won't bne launched again and the 849 ;; time, the timer process won't be launched again and the
846 ;; system stops working. itimer-run-expired-timers allows 850 ;; system stops working. itimer-run-expired-timers allows
847 ;; individual timer function to be aborted, so the user can 851 ;; individual timer function to be aborted, so the user can
848 ;; escape a feral timer function. 852 ;; escape a feral timer function.
849 (if (not itimer-inside-driver) 853 (if (not itimer-inside-driver)
850 (let* ((inhibit-quit t) 854 (let* ((inhibit-quit t)
852 (now (current-time)) 856 (now (current-time))
853 (elapsed (itimer-time-difference now itimer-timer-last-wakeup)) 857 (elapsed (itimer-time-difference now itimer-timer-last-wakeup))
854 (sleep nil)) 858 (sleep nil))
855 (setq itimer-timer-last-wakeup now 859 (setq itimer-timer-last-wakeup now
856 sleep (itimer-run-expired-timers elapsed)) 860 sleep (itimer-run-expired-timers elapsed))
857 (disable-timeout itimer-timer) 861 (itimer-disable-timeout itimer-timer)
858 (setq itimer-next-wakeup sleep 862 (setq itimer-next-wakeup sleep
859 itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5))))) 863 itimer-timer (add-timeout sleep 'itimer-timer-driver nil 5)))))
860 864
861 (defun itimer-driver-start () 865 (defun itimer-driver-start ()
862 (if (fboundp 'add-timeout) 866 (if (fboundp 'add-timeout)
865 869
866 (defun itimer-driver-wakeup () 870 (defun itimer-driver-wakeup ()
867 (if (fboundp 'add-timeout) 871 (if (fboundp 'add-timeout)
868 (itimer-timer-wakeup) 872 (itimer-timer-wakeup)
869 (itimer-process-wakeup))) 873 (itimer-process-wakeup)))
870
871 ;;; itimer.el ends here