timeout on y-or-n-p

[Vincent Keunen <nrb!keunen@relay.EU.net>]

    Date: Tue, 22 Sep 1992 07:14+0200
    From: "Dave Wroblewski" <davew@atqm.advtech.uswest.com>

			  timeout on y-or-n-p
    I would like to write a version of y-or-n-p that "times out" and returns a
    default
    answer if the user has not responded after some time has elapsed. 

    Has anyone done this, or can anyone suggest an approach for this in MCL 2.0f?  
    I'm wondering if there are some nifty but little-known MCL tricks that might
    apply...

    -David Wroblewski
    USWEST Advanced Technologies


This function, along with others, appears in Mkant's
extensions.lisp file.  To get it, consult the lisp-faq or the mcl
cd-rom.



;;; ********************************
;;; Y-OR-N-P-WAIT ******************
;;; ********************************
;;; y-or-n-p-wait is like y-or-n-p, but will timeout
;;; after a specified number of seconds
(defun internal-real-time-in-seconds ()
  (float (/ (get-internal-real-time) 
	    internal-time-units-per-second)))

(defun read-char-wait (&optional (timeout 20) input-stream &aux char)
  (do ((start (internal-real-time-in-seconds)))
      ((or (setq char (read-char-no-hang input-stream)) ;(listen *query-io*)
	   (< (+ start timeout) (internal-real-time-in-seconds)))
       char)))

;;; Lots of lisps, especially those that run on top of UNIX, do not get
;;; their input one character at a time, but a whole line at a time because
;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait
;;; to not always work as expected. 
;;;
;;; I wish lisp did all its own buffering (turning off UNIX input line
;;; buffering by putting the UNIX into CBREAK mode). Of course, this means
;;; that we lose input editing, but why can't the lisp implement this? 

(defvar *use-timeouts* t
  "If T, timeouts in Y-OR-N-P-WAIT are enabled. Otherwise it behaves
   like Y-OR-N-P. This is provided for users whose lisps don't handle
   read-char-no-hang properly.")

(defvar *clear-input-before-query* t
  "If T, y-or-n-p-wait will clear the input before printing the prompt
   and asking the user for input.")

(defun y-or-n-p-wait (&optional (default #\y) (timeout 20) 
				format-string &rest args)
  "Y-OR-N-P-WAIT prints the message, if any, and reads characters from
   *QUERY-IO* until the user enters y, Y or space as an affirmative, or either
   n or N as a negative answer, or the timeout occurs. It asks again if
   you enter any other characters."
  (when *clear-input-before-query* (clear-input *query-io*))
  (when format-string
    (fresh-line *query-io*)
    (apply #'format *query-io* format-string args)
    ;; FINISH-OUTPUT needed for CMU and other places which don't handle
    ;; output streams nicely. This prevents it from continuing and
    ;; reading the query until the prompt has been printed.
    (finish-output *query-io*))
  (loop
   (let* ((read-char (if *use-timeouts*
			 (read-char-wait timeout *query-io*)
			 (read-char *query-io*)))
	  (char (or read-char default)))
     ;; We need to ignore #\newline because otherwise the bugs in 
     ;; clear-input will cause y-or-n-p-wait to print the "Type ..."
     ;; message every time... *sigh*
     ;; Anyway, we might want to use this to ignore whitespace once
     ;; clear-input is fixed.
     (unless (find char '(#\tab #\newline #\return))
       (when (null read-char) 
	 (format *query-io* "~@[~A~]" default)
	 (finish-output *query-io*))
       (cond ((null char) (return t))
	     ((find char '(#\y #\Y #\space) :test #'char=) (return t))
	     ((find char '(#\n #\N) :test #'char=) (return nil))
	     (t 
	      (when *clear-input-before-query* (clear-input *query-io*))
	      (format *query-io* "~&Type \"y\" for yes or \"n\" for no. ")
	      (when format-string
		(fresh-line *query-io*)
		(apply #'format *query-io* format-string args))
	      (finish-output *query-io*)))))))

#|
(y-or-n-p-wait #\y 20 "What? ")
(progn (format t "~&hi") (finish-output)
       (y-or-n-p-wait #\y 10 "1? ")
       (y-or-n-p-wait #\n 10 "2? "))
|#

--

Keunen Vincent                  Network Research Belgium
R&D, Software Engineer          Parc Industriel des Hauts-Sarts
keunen@nrb.be                   2e Avenue, 65
tel: +32 41 407282              B-4040 Herstal
fax: +32 41 481170              BELGIUM