lisp/timer.el

   1 ;;; timer.el --- run a function with args at some time in future
   2
   3 ;; Copyright (C) 1990, 1993, 1994 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This package gives you the capability to run Emacs Lisp commands at
  27 ;; specified times in the future, either as one-shots or periodically.
  28 ;; The single entry point is `run-at-time'.
  29
  30 ;;; Code:
  31
  32 (defvar timer-program (expand-file-name "timer" exec-directory)
  33   "The name of the program to run as the timer subprocess.
  34 It should normally be in the exec-directory.")
  35
  36 (defvar timer-process nil)
  37 (defvar timer-alist ())
  38 (defvar timer-out "")
  39 (defvar timer-dont-exit nil
  40   ;; this is useful for functions which will be doing their own erratic
  41   ;; rescheduling or people who otherwise expect to use the process frequently
  42   "If non-nil, don't exit the timer process when no more events are pending.")
  43
  44 ;; Error symbols for timers
  45 (put 'timer-error 'error-conditions '(error timer-error))
  46 (put 'timer-error 'error-message "Timer error")
  47
  48 (put 'timer-abnormal-termination
  49      'error-conditions
  50      '(error timer-error timer-abnormal-termination))
  51 (put 'timer-abnormal-termination
  52      'error-message
  53      "Timer exited abnormally--all events cancelled")
  54
  55 (put 'timer-filter-error
  56      'error-conditions
  57      '(error timer-error timer-filter-error))
  58 (put 'timer-filter-error
  59      'error-message
  60      "Error in timer process filter")
  61
  62
  63 ;; This should not be necessary, but on some systems, we get
  64 ;; unkillable processes without this.
  65 ;; It may be a kernel bug, but that's not certain.
  66 (defun timer-kill-emacs-hook ()
  67   (if timer-process
  68       (progn
  69         (set-process-sentinel timer-process nil)
  70         (set-process-filter timer-process nil)
  71         (delete-process timer-process))))
  72 (add-hook 'kill-emacs-hook 'timer-kill-emacs-hook)
  73
  74 ;;;###autoload
  75 (defun run-at-time (time repeat function &rest args)
  76   "Run a function at a time, and optionally on a regular interval.
  77 Arguments are TIME, REPEAT, FUNCTION &rest ARGS.
  78 TIME, a string, can be specified absolutely or relative to now.
  79 TIME can also be an integer, a number of seconds.
  80 REPEAT, an integer number of seconds, is the interval on which to repeat
  81 the call to the function.  If REPEAT is nil or 0, call it just once.
  82
  83 Absolute times may be specified in a wide variety of formats;
  84 Something of the form `HOUR:MIN:SEC TIMEZONE MONTH/DAY/YEAR', where
  85 all fields are numbers, works; the format used by the Unix `date'
  86 command works too.
  87
  88 Relative times may be specified as a series of numbers followed by units:
  89   1 min                 denotes one minute from now.
  90   min                   does too.
  91   1 min 5 sec           denotes 65 seconds from now.
  92   1 min 2 sec 3 hour 4 day 5 week 6 fortnight 7 month 8 year
  93                         denotes the sum of all the given durations from now."
  94   (interactive "sRun at time: \nNRepeat interval: \naFunction: ")
  95   (if (equal repeat 0)
  96       (setq repeat nil))
  97   ;; Make TIME a string.
  98   (if (integerp time)
  99       (setq time (format "%d sec" time)))
 100   (cond ((or (not timer-process)
 101              (memq (process-status timer-process) '(exit signal nil)))
 102          (if timer-process (delete-process timer-process))
 103          (setq timer-process
 104                (let ((process-connection-type nil))
 105                  (start-process "timer" nil timer-program))
 106                timer-alist nil)
 107          (set-process-filter   timer-process 'timer-process-filter)
 108          (set-process-sentinel timer-process 'timer-process-sentinel)
 109          (process-kill-without-query timer-process))
 110         ((eq (process-status timer-process) 'stop)
 111          (continue-process timer-process)))
 112   ;; There should be a living, breathing timer process now
 113   (let* ((token (concat (current-time-string) "-" (length timer-alist)))
 114          (elt (list token repeat function args)))
 115     (process-send-string timer-process (concat time "@" token "\n"))
 116     (setq timer-alist (cons elt timer-alist))
 117     elt))
 118
 119 (defun cancel-timer (elt)
 120   "Cancel a timer previously made with `run-at-time'.
 121 The argument should be a value previously returned by `run-at-time'.
 122 Cancelling the timer means that nothing special
 123 will happen at the specified time."
 124   (setcar (cdr elt) nil)
 125   (setcar (cdr (cdr elt)) 'ignore))
 126
 127 (defun timer-process-filter (proc str)
 128   (setq timer-out (concat timer-out str))
 129   (let (do token error)
 130     (while (string-match "\n" timer-out)
 131       (setq token (substring timer-out 0 (match-beginning 0))
 132             do (assoc token timer-alist)
 133             timer-out (substring timer-out (match-end 0)))
 134       (cond
 135        (do
 136         (apply (nth 2 do) (nth 3 do))   ; do it
 137         (if (natnump (nth 1 do))        ; reschedule it
 138             (send-string proc (concat (nth 1 do) " sec@" (car do) "\n"))
 139           (setq timer-alist (delq do timer-alist))))
 140        ((string-match "timer: \\([^:]+\\): \\([^@]*\\)@\\(.*\\)$" token)
 141         (setq error (substring token (match-beginning 1) (match-end 1))
 142               do    (substring token (match-beginning 2) (match-end 2))
 143               token (assoc (substring token (match-beginning 3) (match-end 3))
 144                            timer-alist)
 145               timer-alist (delq token timer-alist))
 146         (or timer-alist
 147             timer-dont-exit
 148             (process-send-eof proc))
 149         ;; Update error message for this particular instance
 150         (put 'timer-filter-error
 151              'error-message
 152              (format "%s for %s; couldn't set at \"%s\""
 153                      error (nth 2 token) do))
 154         (signal 'timer-filter-error (list proc str)))))
 155     (or timer-alist timer-dont-exit (process-send-eof proc))))
 156
 157 (defun timer-process-sentinel (proc str)
 158   (let ((stat (process-status proc)))
 159     (if (eq stat 'stop)
 160         (continue-process proc)
 161       ;; if it exited normally, presumably it was intentional.
 162       ;; if there were no pending events, who cares that it exited?
 163       (or (null timer-alist)
 164           (eq stat 'exit)
 165           (let ((alist timer-alist))
 166             (setq timer-process nil timer-alist nil)
 167             (signal 'timer-abnormal-termination (list proc stat str alist))))
 168       ;; Used to set timer-scratch to "", but nothing uses that var.
 169       (setq timer-process nil timer-alist nil))))
 170
 171 (defun cancel-function-timers (function)
 172   "Cancel all events scheduled by `run-at-time' which would run FUNCTION."
 173   (interactive "aCancel timers of function: ")
 174   (let ((alist timer-alist))
 175     (while alist
 176       (if (eq (nth 2 (car alist)) function)
 177           (setq timer-alist (delq (car alist) timer-alist)))
 178       (setq alist (cdr alist))))
 179   (or timer-alist timer-dont-exit (process-send-eof timer-process)))
 180
 181 (provide 'timer)
 182
 183 ;;; timer.el ends here