annotate lisp/=timer.el @ 1186:24f248525608

(mail-undo-backslash-quoting): Renamed from undo-... (mail-safe-move-sexp): Renamed from safe-... (mail-variant-method): Renamed from variant-method.
author Richard M. Stallman <rms@gnu.org>
date Mon, 21 Sep 1992 14:52:30 +0000
parents 61c6983219ff
children 45f9cbd79ede
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
657
fec3f9a1e3e5 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 584
diff changeset
1 ;;; timer.el --- run a function with args at some time in future
fec3f9a1e3e5 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 584
diff changeset
2
840
113281b361ec *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 807
diff changeset
3 ;; Copyright (C) 1990 Free Software Foundation, Inc.
113281b361ec *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 807
diff changeset
4
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 657
diff changeset
5 ;; Maintainer: FSF
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
6
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
7 ;; This file is part of GNU Emacs.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
8
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
9 ;; GNU Emacs is free software; you can redistribute it and/or modify
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
10 ;; it under the terms of the GNU General Public License as published by
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 657
diff changeset
11 ;; the Free Software Foundation; either version 2, or (at your option)
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
12 ;; any later version.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
13
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
14 ;; GNU Emacs is distributed in the hope that it will be useful,
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
17 ;; GNU General Public License for more details.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
18
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
19 ;; You should have received a copy of the GNU General Public License
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
22
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 657
diff changeset
23 ;;; Code:
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 657
diff changeset
24
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
25 (defvar timer-process nil)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
26 (defvar timer-alist ())
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
27 (defvar timer-out "")
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
28 (defvar timer-dont-exit nil
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
29 ;; this is useful for functions which will be doing their own erratic
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
30 ;; rescheduling or people who otherwise expect to use the process frequently
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
31 "If non-nil, don't exit the timer process when no more events are pending.")
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
32
584
4cd7543be581 *** empty log message ***
Jim Blandy <jimb@redhat.com>
parents: 45
diff changeset
33 ;;;###autoload
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
34 (defun run-at-time (time repeat function &rest args)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
35 "Run a function at a time, and optionally on a regular interval.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
36 Arguments are TIME, REPEAT, FUNCTION &rest ARGS.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
37 TIME, a string, can be specified absolutely or relative to now.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
38 REPEAT, an integer number of seconds, is the interval on which to repeat
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
39 the call to the function."
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
40 (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
41 (cond ((or (not timer-process)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
42 (memq (process-status timer-process) '(exit signal nil)))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
43 (if timer-process (delete-process timer-process))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
44 (setq timer-process (start-process "timer" nil "timer")
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
45 timer-alist nil)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
46 (set-process-filter timer-process 'timer-process-filter)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
47 (set-process-sentinel timer-process 'timer-process-sentinel)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
48 (process-kill-without-query timer-process))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
49 ((eq (process-status timer-process) 'stop)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
50 (continue-process timer-process)))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
51 ;; There should be a living, breathing timer process now
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
52 (let ((token (concat (current-time-string) "-" (length timer-alist))))
998
61c6983219ff entered into RCS
Jim Blandy <jimb@redhat.com>
parents: 840
diff changeset
53 (send-string timer-process (concat time "@" token "\n"))
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
54 (setq timer-alist (cons (list token repeat function args) timer-alist))))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
55
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
56 (defun timer-process-filter (proc str)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
57 (setq timer-out (concat timer-out str))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
58 (let (do token error)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
59 (while (string-match "\n" timer-out)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
60 (setq token (substring timer-out 0 (match-beginning 0))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
61 do (assoc token timer-alist)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
62 timer-out (substring timer-out (match-end 0)))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
63 (cond
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
64 (do (apply (nth 2 do) (nth 3 do)) ; do it
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
65 (if (natnump (nth 1 do)) ; reschedule it
998
61c6983219ff entered into RCS
Jim Blandy <jimb@redhat.com>
parents: 840
diff changeset
66 (send-string proc (concat (nth 1 do) " sec@" (car do) "\n"))
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
67 (setq timer-alist (delq do timer-alist))))
998
61c6983219ff entered into RCS
Jim Blandy <jimb@redhat.com>
parents: 840
diff changeset
68 ((string-match "timer: \\([^:]+\\): \\([^@]*\\)@\\(.*\\)$" token)
45
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
69 (setq error (substring token (match-beginning 1) (match-end 1))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
70 do (substring token (match-beginning 2) (match-end 2))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
71 token (assoc (substring token (match-beginning 3) (match-end 3))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
72 timer-alist)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
73 timer-alist (delq token timer-alist))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
74 (ding 'no-terminate) ; using error function in process filters is rude
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
75 (message "%s for %s; couldn't set at \"%s\"" error (nth 2 token) do))))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
76 (or timer-alist timer-dont-exit (process-send-eof proc))))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
77
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
78 (defun timer-process-sentinel (proc str)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
79 (let ((stat (process-status proc)))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
80 (if (eq stat 'stop) (continue-process proc)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
81 ;; if it exited normally, presumably it was intentional.
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
82 ;; if there were no pending events, who cares that it exited?
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
83 (if (or (not timer-alist) (eq stat 'exit)) ()
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
84 (ding 'no-terminate)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
85 (message "Timer exited abnormally. All events cancelled."))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
86 (setq timer-process nil timer-alist nil timer-scratch ""))))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
87
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
88 (defun cancel-timer (function)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
89 "Cancel all events scheduled by ``run-at-time'' which would run FUNCTION."
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
90 (interactive "aCancel function: ")
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
91 (let ((alist timer-alist))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
92 (while alist
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
93 (if (eq (nth 2 (car alist)) function)
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
94 (setq timer-alist (delq (car alist) timer-alist)))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
95 (setq alist (cdr alist))))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
96 (or timer-alist timer-dont-exit (process-send-eof timer-process)))
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
97
a55a3ac41924 Initial revision
root <root>
parents:
diff changeset
98 (provide 'timer)
657
fec3f9a1e3e5 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 584
diff changeset
99
fec3f9a1e3e5 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 584
diff changeset
100 ;;; timer.el ends here