home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / timer.shar / timer.el < prev   
Encoding:
Text File  |  1991-01-14  |  19.3 KB  |  552 lines
  1. ;;; Interval timers for GNU Emacs
  2. ;;; Copyright (C) 1988, 1991 Kyle E. Jones
  3. ;;;
  4. ;;; Verbatim copies of this file may be freely redistributed.
  5. ;;;
  6. ;;; Modified versions of this file may be redistributed provided that this
  7. ;;; notice remains unchanged, the file contains prominent notice of
  8. ;;; author and time of modifications, and redistribution of the file
  9. ;;; is not further restricted in any way.
  10. ;;;
  11. ;;; This file is distributed `as is', without warranties of any kind.
  12.  
  13. (provide 'timer)
  14.  
  15. ;; `timer' feature means Emacs-Lisp programers get:
  16. ;;    timerp, timer-value, timer-restart, timer-function,
  17. ;;    set-timer-value, set-timer-restart, set-timer-function
  18. ;;    get-timer, start-timer, read-timer, delete-timer
  19. ;;
  20. ;; Interactive users get these commands:
  21. ;;    edit-timers, list-timers, start-timer
  22. ;;
  23. ;; See the doc strings of these functions for more information.
  24.  
  25. (defvar timer-list nil
  26.   "List of all active timers.")
  27.  
  28. (defvar timer-process nil
  29.   "Process that drives all timers.")
  30.  
  31. ;; This value is maintained internally; it does not determine timer
  32. ;; granularity.  Timer granularity is 1 second, plus delays due to
  33. ;; system and Emacs internal activity that delay dealing with process
  34. ;; output.
  35. (defvar timer-process-next-wakeup 1
  36.   "Timer process will wakeup to service running timers within this
  37. many seconds.")
  38.  
  39. (defvar timer-edit-map nil
  40.   "Keymap used when in Timer Edit mode.")
  41.  
  42. (if timer-edit-map
  43.     ()
  44.   (setq timer-edit-map (make-sparse-keymap))
  45.   (define-key timer-edit-map "s" 'timer-edit-set-field)
  46.   (define-key timer-edit-map "d" 'timer-edit-delete-timer)
  47.   (define-key timer-edit-map "q" 'timer-edit-quit)
  48.   (define-key timer-edit-map "\t" 'timer-edit-next-field)
  49.   (define-key timer-edit-map " " 'next-line)
  50.   (define-key timer-edit-map "n" 'next-line)
  51.   (define-key timer-edit-map "p" 'previous-line)
  52.   (define-key timer-edit-map "\C-?" 'timer-edit-previous-field)
  53.   (define-key timer-edit-map "x" 'start-timer)
  54.   (define-key timer-edit-map "?" 'timer-edit-help))
  55.   
  56. (defvar timer-edit-start-marker nil)
  57.  
  58. ;; macros must come first... or byte-compile'd code will throw back its
  59. ;; head and scream.
  60.  
  61. (defmacro decrement (variable)
  62.   (list 'setq variable (list '1- variable)))
  63.  
  64. (defmacro increment (variable)
  65.   (list 'setq variable (list '1+ variable)))
  66.  
  67. (defmacro signum (n)
  68.   (list 'if (list '> n 0) 1
  69.     (list 'if (list 'zerop n) 0 -1)))
  70.  
  71. ;; Timer access functions should behave as if they were subrs.  These
  72. ;; macros are used to check the arguments to the timer functions and
  73. ;; signal errors appropriately if the arguments are not valid.
  74.  
  75. (defmacro check-timer (var)
  76.   "If VAR is not bound to a timer, signal wrong-type-argument.
  77. This is a macro."
  78.   (list 'setq var
  79.     (list 'if (list 'timerp var) var
  80.           (list 'signal ''wrong-type-argument
  81.             (list 'list ''timerp var)))))
  82.  
  83. (defmacro check-timer-coerce-string (var)
  84.   "If VAR is not bound to a string, look up the timer that it names and
  85. bind VAR to it.  Otherwise if VAR is not bound to a timer, signal
  86. wrong-type-argument.  This is a macro."
  87.   (list 'setq var
  88.     (list 'cond
  89.           (list (list 'timerp var) var)
  90.           (list (list 'stringp var) (list 'get-timer var))
  91.           (list t (list 'signal ''wrong-type-argument
  92.                 (list 'list ''string-or-timer-p var))))))
  93.  
  94. (defmacro check-natnumber (var)
  95.   "If VAR is not bound to a non-negative number, signal wrong-type-argument.
  96. This is a macro."
  97.   (list 'setq var
  98.     (list 'if (list 'natnump var) var
  99.           (list 'signal ''wrong-type-argument
  100.             (list 'list ''natnump var)))))
  101.  
  102. (defmacro check-string (var)
  103.   "If VAR is not bound to a string, signal wrong-type-argument.
  104. This is a macro."
  105.   (list 'setq var
  106.     (list 'if (list 'stringp var) var
  107.           (list 'signal ''wrong-type-argument
  108.             (list 'list ''stringp var)))))
  109.  
  110. ;; Functions to access and modify timer attributes.
  111.  
  112. (defun timerp (obj)
  113.   "Returns non-nil iff OBJ is a timer."
  114.   (and (consp obj) (stringp (car obj)) (eq (length obj) 4)))
  115.  
  116. (defun timer-name (timer)
  117.   "Returns the name of TIMER."
  118.   (check-timer timer)
  119.   (car timer))
  120.  
  121. (defun timer-value (timer)
  122.   "Returns the number of seconds until TIMER expires."
  123.   (check-timer timer)
  124.   (nth 1 timer))
  125.  
  126. (defun timer-restart (timer)
  127.   "Returns the value to which TIMER will be set at restart.
  128. nil is returned if this timer doesn't restart."
  129.   (check-timer timer)
  130.   (nth 2 timer))
  131.  
  132. (defun timer-function (timer)
  133.   "Returns the function of TIMER.
  134. This function is called each time TIMER expires."
  135.   (check-timer timer)
  136.   (nth 3 timer))
  137.  
  138. (defun set-timer-value (timer value &optional nowakeup)
  139.   "Set the timeout value of TIMER to be VALUE.
  140. Timer will expire is this many seconds.
  141. Returns VALUE."
  142. ;; Optional third arg NOWAKEUP non-nil means do not wakeup the timer
  143. ;; process to recompute a correct wakeup time, even if it means this
  144. ;; timer will expire late.  timer-process-filter uses this option.
  145. ;; This is not meant for ordinary usage, which is why it is not
  146. ;; mentioned in the doc string.
  147.   (check-timer timer)
  148.   (check-natnumber value)
  149.   (let ((inhibit-quit t))
  150.     ;; If we're allowed to wakeup the timer process,
  151.     ;; and the timer process's next wakeup needs to be recomputed,
  152.     ;; and the timer is running, then we wakeup the timer process.
  153.     (or (and (not nowakeup) (< value timer-process-next-wakeup)
  154.          (get-timer (timer-name timer))
  155.          (progn (timer-process-wakeup)
  156.             (setcar (cdr timer) value)
  157.             (timer-process-wakeup)))
  158.     (setcar (cdr timer) value))
  159.     value))
  160.  
  161. (defun set-timer-restart (timer restart)
  162.   "Set the restart value of TIMER to be RESTART.
  163. If RESTART is nil, TIMER is will not restart when it expires.
  164. Returns RESTART."
  165.   (check-timer timer)
  166.   (if restart (check-natnumber restart))
  167.   (and restart (< restart 1) (signal 'args-out-of-range (list restart)))
  168.   (setcar (cdr (cdr timer)) restart))
  169.  
  170. (defun set-timer-function (timer function)
  171.   "Set the function of TIMER to be FUNCTION.
  172. FUNCTION will be called when timer expires.
  173. Returns FUNCTION."
  174.   (check-timer timer)
  175.   (setcar (cdr (cdr (cdr timer))) function))
  176.  
  177. (defun get-timer (name)
  178.   "Return timer named NAME, or nil if there is none."
  179.   (check-string name)
  180.   (assoc name timer-list))
  181.  
  182. (defun read-timer (prompt &optional initial-input)
  183.   "Read the name of a timer from the minibuffer and return the timer
  184. associated with that name.  The user is prompted with PROMPT.
  185. Optional second arg INITIAL-INPUT non-nil is inserted into the
  186.   minibuffer as initial user input."
  187.   (get-timer (completing-read prompt timer-list nil 'confirm initial-input)))
  188.  
  189. (defun delete-timer (timer)
  190.   "Deletes TIMER.  TIMER may be a timer or the name of one."
  191.   (check-timer-coerce-string timer)
  192.   (setq timer-list (delq timer timer-list)))
  193.  
  194. (defun start-timer (name function value &optional restart)
  195.   "Start a timer.
  196. Args are NAME, FUNCTION, VALUE &optional RESTART.
  197. NAME is an identifier for the timer.  It must be a string.  If a timer
  198.   already exists with this name, NAME will be modified slightly to until
  199.   it is unique.
  200. FUNCTION should be a function (or symbol naming one) of no arguments.  It
  201.   will be called each time the timer expires.  The function can access
  202.   timer that invoked it through the variable `current-timer'.
  203. VALUE is the number of seconds until this timer expires.
  204. Optional fourth arg RESTART non-nil means that this timer should be
  205.   restarted automatically after its function is called.  Normally a timer
  206.   is deleted at expiration after its function has returned. 
  207.   If non-nil RESTART should be a number indicating the value at which the
  208.   timer should be set at restart time.
  209. Returns the newly created timer."
  210.   (interactive
  211.    (list (completing-read "Start timer: " timer-list)
  212.      (read (completing-read "Timer function: " obarray 'fboundp))
  213.      (let (value)
  214.        (while (not (natnump value))
  215.          (setq value (read-from-minibuffer "Timer value: " nil nil t)))
  216.        value)
  217.      (let ((restart t))
  218.        (while (and restart (not (natnump restart)))
  219.          (setq restart (read-from-minibuffer "Timer restart: " nil nil t)))
  220.        restart)))
  221.   (check-string name)
  222.   (check-natnumber value)
  223.   (if restart (check-natnumber restart))
  224.   ;; Make proposed timer name unique if it's not already.
  225.   (let ((oname name)
  226.     (num 2))
  227.     (while (get-timer name)
  228.       (setq name (concat oname "<" num ">"))
  229.       (increment num)))
  230.   ;; If there's no timer process, start one now.
  231.   ;; Otherwise wake up the timer process so that seconds slept before
  232.   ;; the new timer is created won't be counted against it.
  233.   (if timer-process
  234.       (timer-process-wakeup)
  235.     (timer-process-start))
  236.   (let ((inhibit-quit t))
  237.     ;; add the timer to the global list
  238.     (setq timer-list
  239.       (cons (list name value restart function)
  240.         timer-list))
  241.     ;; If the timer process is scheduled to wake up too late for the timer
  242.     ;; we wake it up to calculate a correct wakeup value giving consideration
  243.     ;; to the newly added timer.
  244.     (if (< value timer-process-next-wakeup)
  245.     (timer-process-wakeup)))
  246.   (car timer-list))
  247.  
  248. ;; User level functions to list and modify existing timers.
  249. ;; Timer Edit major mode, and the editing commands thereof.
  250.  
  251. (defun list-timers ()
  252.   "Pop up a buffer containing a list of all timers.
  253. The major mode of the buffer is Timer Edit mode.  This major mode provides
  254. commands to manipulate timers; see the documentation for
  255. `timer-edit-mode' for more information."
  256.   (interactive)
  257.   (let* ((buf (get-buffer-create "*Timer List*"))
  258.      (opoint (point))
  259.      (standard-output buf)
  260.      (timers (reverse timer-list)))
  261.     (set-buffer buf)
  262.     (timer-edit-mode)
  263.     (setq buffer-read-only nil)
  264.     (erase-buffer)
  265.     (insert "Name                  Value     Restart   Function\n"
  266.         "----                  -----     -------   --------")
  267.     (if (null timer-edit-start-marker)
  268.     (setq timer-edit-start-marker (point)))
  269.     (while timers
  270.       (newline 1)
  271.       (prin1 (timer-name (car timers)))
  272.       (tab-to-tab-stop)
  273.       (prin1 (timer-value (car timers)))
  274.       (tab-to-tab-stop)
  275.       (prin1 (timer-restart (car timers)))
  276.       (tab-to-tab-stop)
  277.       (prin1 (timer-function (car timers)))
  278.       (setq timers (cdr timers)))
  279.     ;; restore point
  280.     (goto-char opoint)
  281.     (if (< (point) timer-edit-start-marker)
  282.     (goto-char timer-edit-start-marker))
  283.     (setq buffer-read-only t)
  284.     (display-buffer buf)))
  285.  
  286. (defun edit-timers ()
  287.   "Display a list of all timers and select it for editing.
  288. The major mode of the buffer containing the listing is Timer Edit mode.
  289. This major mode provides commands to manipulate timers; see the documentation
  290. for `timer-edit-mode' for more information."
  291.   (interactive)
  292.   ;; since user is editing, make sure displayed data is reasonably up-to-date
  293.   (if timer-process
  294.       (timer-process-wakeup))
  295.   (list-timers)
  296.   (select-window (get-buffer-window "*Timer List*"))
  297.   (goto-char timer-edit-start-marker)
  298.   (if timer-list
  299.       (progn
  300.     (forward-sexp 2)
  301.     (backward-sexp)))
  302.   (message "type q to quit, ? for help"))
  303.  
  304. ;; no point in making this interactive.
  305. (defun timer-edit-mode ()
  306.   "Major mode for manipulating timers.
  307. Atrributes of running timers are changed by moving the cursor to the
  308. desired field and typing `s' to set that field.  The field will then be
  309. set to the value read from the minibuffer.
  310.  
  311. Commands:
  312. TAB    move forward a field
  313. DEL    move backward a field
  314. s      set a field
  315. d      delete the selected timer
  316. x      start a new timer
  317. ?      help"
  318.   (kill-all-local-variables)
  319.   (make-local-variable 'tab-stop-list)
  320.   (setq major-mode 'timer-edit-mode
  321.     mode-name "Timer Edit"
  322.     truncate-lines t
  323.     tab-stop-list '(22 32 42))
  324.   (abbrev-mode 0)
  325.   (auto-fill-mode 0)
  326.   (buffer-flush-undo (current-buffer))
  327.   (use-local-map timer-edit-map)
  328.   (set-syntax-table lisp-mode-syntax-table))
  329.  
  330. (put 'timer-edit-mode 'mode-class 'special)
  331.  
  332. (defun timer-edit-help ()
  333.   "Help function for Timer Edit."
  334.   (interactive)
  335.   (if (eq last-command 'timer-edit-help)
  336.       (describe-mode)
  337.     (message "TAB, DEL select fields, (s)et field, (d)elete timer   (type ? for more help)")))
  338.  
  339. (defun timer-edit-quit ()
  340.   "End Timer Edit."
  341.   (interactive)
  342.   (bury-buffer (current-buffer))
  343.   (if (one-window-p t)
  344.       (switch-to-buffer (other-buffer (current-buffer)))
  345.     (delete-window)))
  346.  
  347. (defun timer-edit-set-field ()
  348.   (interactive)
  349.   ;; First two lines in list buffer are headers.
  350.   ;; Cry out against the luser who attempts to change a field there.
  351.   (if (<= (point) timer-edit-start-marker)
  352.       (error ""))
  353.   ;; field-value must be initialized to be something other than a
  354.   ;; number, symbol, or list.
  355.   (let (timer field (field-value ""))
  356.     (setq timer (save-excursion
  357.           ;; read the name of the timer from the beginning of
  358.           ;; the current line.
  359.           (beginning-of-line)
  360.           (get-timer (read (current-buffer))))
  361.       field (save-excursion
  362.           (timer-edit-beginning-of-field)
  363.           (let ((opoint (point))
  364.             (n 0))
  365.             ;; count the number of sexprs until we reach the cursor
  366.             ;; and use this info to determine which field the user
  367.             ;; wants to modify.
  368.             (beginning-of-line)
  369.             (while (and (>= opoint (point)) (< n 4))
  370.               (forward-sexp 2)
  371.               (backward-sexp)
  372.               (increment n))
  373.             (cond ((eq n 1) (error "Cannot change timer name."))
  374.               ((eq n 2) 'value)
  375.               ((eq n 3) 'restart)
  376.               ((eq n 4) 'function)))))
  377.     (cond ((eq field 'value)
  378.        (let ((prompt "Set timer value: "))
  379.          (while (not (natnump field-value))
  380.            (setq field-value (read-from-minibuffer prompt nil nil t)))))
  381.       ((eq field 'restart)
  382.        (let ((prompt "Set timer restart: "))
  383.          (while (and field-value (not (natnump field-value)))
  384.            (setq field-value (read-from-minibuffer prompt nil nil t)))))
  385.       ((eq field 'function)
  386.        (let ((prompt "Set timer function: "))
  387.          (while (not (or (and (symbolp field-value) (fboundp field-value))
  388.                  (and (consp field-value)
  389.                   (memq (car field-value) '(lambda macro)))))
  390.            (setq field-value
  391.              (read (completing-read prompt obarray 'fboundp nil)))))))
  392.     ;; set the timer field
  393.     (funcall (intern (concat "set-timer-" (symbol-name field)))
  394.          timer field-value)
  395.     ;; move to beginning of field to be changed
  396.     (timer-edit-beginning-of-field)
  397.     ;; modify the list buffer to reflect the change.
  398.     (let (buffer-read-only kill-ring)
  399.       (kill-sexp 1)
  400.       (kill-region (point) (progn (skip-chars-forward " \t") (point)))
  401.       (prin1 field-value (current-buffer))
  402.       (if (not (eolp))
  403.       (tab-to-tab-stop))
  404.       (backward-sexp))))
  405.  
  406. (defun timer-edit-delete-timer ()
  407.   (interactive)
  408.   ;; First two lines in list buffer are headers.
  409.   ;; Cry out against the luser who attempts to change a field there.
  410.   (if (<= (point) timer-edit-start-marker)
  411.       (error ""))
  412.   (delete-timer
  413.    (read-timer "Delete timer: "
  414.            (save-excursion (beginning-of-line) (read (current-buffer)))))
  415.   ;; update list information
  416.   (list-timers))
  417.  
  418. (defun timer-edit-next-field (count)
  419.   (interactive "p")
  420.   (timer-edit-beginning-of-field)
  421.   (cond ((> (signum count) 0)
  422.      (while (not (zerop count))
  423.        (forward-sexp)
  424.        ;; wrap from eob to timer-edit-start-marker
  425.        (if (eobp)
  426.            (progn
  427.          (goto-char timer-edit-start-marker)
  428.          (forward-sexp)))
  429.        (forward-sexp)
  430.        (backward-sexp)
  431.        ;; treat fields at beginning of line as if they weren't there.
  432.        (if (bolp)
  433.            (progn
  434.          (forward-sexp 2)
  435.          (backward-sexp)))
  436.        (decrement count)))
  437.     ((< (signum count) 0)
  438.      (while (not (zerop count))
  439.        (backward-sexp)
  440.        ;; treat fields at beginning of line as if they weren't there.
  441.        (if (bolp)
  442.            (backward-sexp))
  443.        ;; wrap from timer-edit-start-marker to field at eob.
  444.        (if (<= (point) timer-edit-start-marker)
  445.            (progn
  446.          (goto-char (point-max))
  447.          (backward-sexp)))
  448.        (increment count)))))
  449.  
  450. (defun timer-edit-previous-field (count)
  451.   (interactive "p")
  452.   (timer-edit-next-field (- count)))
  453.  
  454. (defun timer-edit-beginning-of-field ()
  455.   (let ((forw-back (save-excursion (forward-sexp) (backward-sexp) (point)))
  456.     (back (save-excursion (backward-sexp) (point))))
  457.     (cond ((eq forw-back back) (backward-sexp))
  458.       ((eq forw-back (point)) t)
  459.       (t (backward-sexp)))))
  460.  
  461.  
  462. ;; internals of the timer implementation.
  463.  
  464. (defun timer-process-filter (process string)
  465.   ;; If the timer process dies and generates output while doing
  466.   ;; so, we may be called before the process-sentinel.  Sanity
  467.   ;; check the output just in case...
  468.   (if (not (string-match "^[0-9]" string))
  469.       (message "timer process gave odd output: %s" string)
  470.     ;; if there are no active timers, return quickly.
  471.     (if timer-list
  472.     (let ((time-elapsed (string-to-int string))
  473.           (timers timer-list)
  474.           (timer)
  475.           ;; process filters can be hit by stray C-g's from the user,
  476.           ;; so we must protect this stuff appropriately.
  477.           ;; Quit's are allowed from within timer functions, but we
  478.           ;; catch them.
  479.           (inhibit-quit t))
  480.       (setq timer-process-next-wakeup 600)
  481.       (while timers
  482.         (setq timer (car timers))
  483.         (set-timer-value timer (max 0 (- (timer-value timer) time-elapsed)) t)
  484.         (if (> (timer-value timer) 0)
  485.         (setq timer-process-next-wakeup
  486.               (min timer-process-next-wakeup (timer-value timer)))
  487.           ;; timer has expired, we must call its function.
  488.           ;; protect our local vars from the timer function.
  489.           ;; allow keyboard quit to occur, but catch and report it.
  490.           ;; provide the variable `current-timer' in case the function
  491.           ;; is interested.
  492.           (condition-case condition-data
  493.           (let* ((current-timer timer)
  494.              timer timers time-elapsed
  495.              quit-flag inhibit-quit)
  496.             (funcall (timer-function current-timer)))
  497.         (error (message "timer \"%s\" signaled: %s" (timer-name timer)
  498.                 (prin1-to-string condition-data)))
  499.         (quit (message "timer \"%s\" quit" (timer-name timer))))
  500.           ;; restart the timer if we should, otherwise delete it.
  501.           (if (null (timer-restart timer))
  502.           (delete-timer timer)
  503.         (set-timer-value timer (timer-restart timer) t)
  504.         (setq timer-process-next-wakeup
  505.               (min timer-process-next-wakeup (timer-value timer)))))
  506.         (setq timers (cdr timers)))
  507.       ;; if user is editing timers, update displayed info
  508.       (if (eq major-mode 'timer-edit-mode)
  509.           (list-timers)))
  510.       (setq timer-process-next-wakeup 600))
  511.     ;; tell timer-process when to wakeup again
  512.     (process-send-string timer-process
  513.              (concat (int-to-string timer-process-next-wakeup)
  514.                  "\n"))))
  515.  
  516. (defun timer-process-sentinel (process message)
  517.   (let ((inhibit-quit t))
  518.     (if (eq (process-status process) 'stop)
  519.     (continue-process process)
  520.       ;; not stopped, so it must have died.
  521.       ;; cleanup first...
  522.       (delete-process process)
  523.       (setq timer-process nil)
  524.       ;; now, if there are any active timers then we need to immediately
  525.       ;; start another timer process, otherwise we can wait until the next
  526.       ;; start-timer call,  which will start one automatically.
  527.       (if (null timer-list)
  528.       ()
  529.     ;; there may have been an error message in the echo area;
  530.     ;; give the user at least a little time to read it.
  531.     (sit-for 2)
  532.     (message "timer process %s... respawning." (substring message 0 -1))
  533.     (timer-process-start)))))
  534.  
  535. (defun timer-process-start ()
  536.   (let ((inhibit-quit t)
  537.     (process-connection-type nil))
  538.     (setq timer-process (start-process "timer" nil "timer"))
  539.     (process-kill-without-query timer-process)
  540.     (set-process-filter timer-process 'timer-process-filter)
  541.     (set-process-sentinel timer-process 'timer-process-sentinel)
  542.     ;; Tell timer process to wake up quickly, so that a correct wakeup
  543.     ;; time can be computed.  Zero instead of one here loses because of
  544.     ;; underlying timer implementations that use 0 to mean `disable the
  545.     ;; timer'.
  546.     (setq timer-process-next-wakeup 1)
  547.     (process-send-string timer-process "1\n")))
  548.  
  549. (defun timer-process-wakeup ()
  550.   (interrupt-process timer-process)
  551.   (accept-process-output))
  552.