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