;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 124.24 ;;; Reason: ;;; FQUERY enhancements: ;;; - If timeout, say " -- 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 ." (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))) ))