lisp/timer.el

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