;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.24
;;; Reason:
;;;  FQUERY enhancements:
;;;    - If timeout, say "<choice> -- timeout" rather than just "timeout"
;;;    - If reading with :tyi (e.g. y-or-n-p), Clear-Screen will clear the
;;;      screen and reprompt.
;;; Written 3-Jun-88 19:02:22 by pld (Peter L. DeWolf) at site Gigamos Cambridge
;;; while running on Azathoth from band 1
;;; with Experimental System 124.21, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1756, SDU Boot Tape 3.14, SDU ROM 8, the old ones.



; From modified file DJ: L.IO1; FQUERY.LISP#56 at 3-Jun-88 19:03:13
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "


(DEFUN FQUERY (OPTIONS FQUERY-FORMAT-STRING &REST FQUERY-FORMAT-ARGS
					    &AUX MAKE-COMPLETE
					    TYPE TYPE-FUNCTION
					    FQUERY-CHOICES
					    STREAM FQUERY-STREAM
					    FRESH-LINE
					    CONDITION
					    FQUERY-LIST-CHOICES
					    FQUERY-HELP-FUNCTION
					    BEEP-P CLEAR-INPUT
					    HANDLED-P VAL 
					    FQUERY-DEFAULT-VALUE FQUERY-TIMEOUT)
  "Ask a multiple-choice question on *QUERY-IO*.
FQUERY-FORMAT-STRING and FQUERY-FORMAT-ARGS are used to print the question.
Ending the string with /"? /" is often appropriate.
OPTIONS is a PLIST.  Defined indicators are:
:MAKE-COMPLETE boolean.  Send a :MAKE-COMPLETE message to the stream if it understands it.
:TYPE one of :TYI, :READLINE, :MINI-BUFFER-OR-READLINE.
  It says how the answer is gathered and echoed.
:CHOICES a list of choices.
  A choice is either the symbol :ANY or a list.
  If a list, its car is either a possible return value,
    or a list of a possible return value and how to echo it.
  The remaining things in the list are input items that select that return value.
  For a :READLINE type call, they should be strings.
  For a :TYI type call, they should be characters.
  Example choice (for :READLINE): ((:foo /"Foo/") #\F #\space)
:FRESH-LINE boolean.  Send a :FRESH-LINE to the stream initially.
:CONDITION symbol.  Signalled before asking.
:LIST-CHOICES boolean.  If T, a list of choices is printed after the question.
:BEEP boolean.  If T, we beep before printing the message.
:CLEAR-INPUT boolean.  If T, we discard type-ahead before printing the message.
:HELP-FUNCTION specifies a function to be called
  if the user types Help.
  It is called with STREAM, CHOICES and TYPE-FUNCTION as arguments.
:STREAM stream or expression.  Specifies the stream to use.
  If it is a symbol (which is not an io-stream) or a list it is evaluated.
  Default is to use *QUERY-IO*.
:DEFAULT-VALUE value.  Return this if defaulted or timed out.
:TIMEOUT <interval-in-60ths>."
  (SETF (VALUES MAKE-COMPLETE TYPE FQUERY-CHOICES STREAM BEEP-P CLEAR-INPUT
		FRESH-LINE CONDITION FQUERY-LIST-CHOICES FQUERY-HELP-FUNCTION
		FQUERY-DEFAULT-VALUE FQUERY-TIMEOUT)
	(APPLY #'FQUERY-DECODE-OPTIONS OPTIONS))
  (SETQ FQUERY-STREAM (IF STREAM
			  (IF (OR (AND (SYMBOLP STREAM) (NOT (GET STREAM 'SI:IO-STREAM-P)))
				  (CONSP STREAM))
			      (EVAL STREAM)
			    STREAM)
			*QUERY-IO*))
  (SETQ TYPE-FUNCTION (OR (GET TYPE 'FQUERY-FUNCTION)
			  (FERROR NIL "~S is not a valid :TYPE for FQUERY" TYPE)))
  (AND CONDITION
       (OR (NEQ CONDITION 'FQUERY)
	   (EH:CONDITION-NAME-HANDLED-P CONDITION))
       (MULTIPLE-VALUE (HANDLED-P VAL)
	 (SIGNAL-CONDITION
	   (APPLY #'MAKE-CONDITION CONDITION OPTIONS FQUERY-FORMAT-STRING FQUERY-FORMAT-ARGS)
	   '(:NEW-VALUE))))
  (IF HANDLED-P VAL
;     (UNWIND-PROTECT
	(PROGN
;	  (COND ((AND SELECT
;		      (MEMQ :SELECT (SEND FQUERY-STREAM :WHICH-OPERATIONS)))
;		 (SEND FQUERY-STREAM :OUTPUT-HOLD-EXCEPTION)
;		 (SETQ OLD-SELECTED-WINDOW TV:SELECTED-WINDOW)
;		 (SEND FQUERY-STREAM :SELECT)))		      
	  (BLOCK TOP
	    (DO-FOREVER
	      (AND BEEP-P (SEND FQUERY-STREAM :BEEP 'FQUERY))
	      (AND CLEAR-INPUT (SEND FQUERY-STREAM :CLEAR-INPUT))
	      (AND FRESH-LINE (SEND FQUERY-STREAM :FRESH-LINE))
	      (MULTIPLE-VALUE-BIND (TYPEIN TIMEOUT-P)
		  (FUNCALL TYPE-FUNCTION :READ FQUERY-STREAM)
		(cond (timeout-p
		       (format fquery-stream "~A -- timed out." (find-fquery-default))
		       (AND MAKE-COMPLETE
			    (SEND FQUERY-STREAM :SEND-IF-HANDLES :MAKE-COMPLETE))
		       (RETURN-FROM TOP TYPEIN))
		      (t
		       (DOLIST (CHOICE FQUERY-CHOICES)
			 (COND ((EQ CHOICE :ANY)
				(FUNCALL TYPE-FUNCTION :ECHO TYPEIN FQUERY-STREAM)
				(AND MAKE-COMPLETE
				     (SEND FQUERY-STREAM :SEND-IF-HANDLES :MAKE-COMPLETE))
				(RETURN-FROM TOP TYPEIN))
			       ((FUNCALL TYPE-FUNCTION :MEMBER TYPEIN (CDR CHOICE))
				(SETQ CHOICE (CAR CHOICE))
				(WHEN (CONSP CHOICE)
				  (FUNCALL TYPE-FUNCTION :ECHO (CADR CHOICE) FQUERY-STREAM)
				  (SETQ CHOICE (CAR CHOICE)))
				(AND MAKE-COMPLETE
				     (SEND FQUERY-STREAM :SEND-IF-HANDLES :MAKE-COMPLETE))
				(RETURN-FROM TOP CHOICE)))))))
	      (SETQ BEEP-P T
		    CLEAR-INPUT T
		    FRESH-LINE T		;User spazzed, will need fresh line
		    FQUERY-LIST-CHOICES T))))	;and should list options
;	(AND OLD-SELECTED-WINDOW (SEND OLD-SELECTED-WINDOW :SELECT NIL)))
	))

))

; From modified file DJ: L.IO1; FQUERY.LISP#56 at 3-Jun-88 19:03:18
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "


(defun find-fquery-default ()
  (dolist (element fquery-choices)
    (let ((choice (car element)))
      (when (eq fquery-default-value (if (consp choice) (car choice) choice))
	;;We found the default that will be returned.  How does it echo?
	(let ((value (if (consp choice) (cadr choice) (cadr element))))
	  (return (if (and (stringp value)
			   (char= (char value (1- (string-length value))) #/.))
		      ;;Kludge -- strip off period at end.
		      (substring value 0 (1- (string-length value)))
		    value)))))))

))

; From modified file DJ: L.IO1; FQUERY.LISP#56 at 3-Jun-88 19:05:19
#8R FORMAT#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FORMAT")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO1; FQUERY  "

(DEFSELECT TYI-FQUERY-FUNCTION
  (:READ (STREAM)
    (labels ((read-it ()
	      (DO ((CH)) (NIL)
		(FQUERY-PROMPT STREAM)
		(SETQ CH (READ-CHAR STREAM))
		(cond ((AND (CHAR= CH #/HELP) FQUERY-HELP-FUNCTION)
		       (SEND FQUERY-HELP-FUNCTION STREAM FQUERY-CHOICES 'TYI-FQUERY-FUNCTION)
		       (SEND STREAM :FRESH-LINE))
		      ((char= ch #/clear-screen)
		       (send-if-handles stream :clear-screen))
		      (t
		       (RETURN CH))))))

      (if (null fquery-timeout)
	  (read-it)
	(with-timeout (fquery-timeout
			(values fquery-default-value t))
	  (read-it)))))
  (:ECHO (ECHO STREAM)
    (SEND STREAM :STRING-OUT (STRING ECHO)))
  (:MEMBER (CHAR LIST)
; character lossage
    (MEM #'(LAMBDA (X Y) (CHAR-EQUAL X (COERCE Y 'CHARACTER))) CHAR LIST)))

))