1;;; 2;;; gauche/listener - listerner utility 3;;; 4;;; Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org> 5;;; 6;;; Redistribution and use in source and binary forms, with or without 7;;; modification, are permitted provided that the following conditions 8;;; are met: 9;;; 10;;; 1. Redistributions of source code must retain the above copyright 11;;; notice, this list of conditions and the following disclaimer. 12;;; 13;;; 2. Redistributions in binary form must reproduce the above copyright 14;;; notice, this list of conditions and the following disclaimer in the 15;;; documentation and/or other materials provided with the distribution. 16;;; 17;;; 3. Neither the name of the authors nor the names of its contributors 18;;; may be used to endorse or promote products derived from this 19;;; software without specific prior written permission. 20;;; 21;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32;;; 33 34;; provides functions useful to implement a repl listener 35 36(define-module gauche.listener 37 (use srfi-13) 38 (export <listener> 39 listener-read-handler 40 listener-show-prompt 41 complete-sexp?) ;now built-in, exported for the compatibility 42 ) 43(select-module gauche.listener) 44 45;; Listener class 46;; 47;; <listener> is a single-buffered, that is, only the input is 48;; buffered until it consists a valid S-expression. The output 49;; is directly sent to the output port. It's enough to handle 50;; usual situation. 51;; 52;; A possible variant of <listener> is a double-buffered listener, 53;; that buffers output as well, which will be sent to the output 54;; port whenever it is ready. 55 56(define-class <listener> () 57 ((input-port :init-keyword :input-port :init-form (current-input-port)) 58 (output-port :init-keyword :output-port :init-form (current-output-port)) 59 (error-port :init-keyword :error-port :init-form (current-error-port)) 60 (reader :init-keyword :reader :init-form read) 61 (evaluator :init-keyword :evaluator :init-form eval) 62 (printer :init-keyword :printer 63 :init-form (lambda args 64 (for-each (^r (write r) (newline)) args))) 65 (prompter :init-keyword :prompter 66 :init-form (cut display "listener> ")) 67 (environment :init-keyword :environment 68 :init-form (interaction-environment)) 69 (finalizer :init-keyword :finalizer :init-form #f) 70 (error-handler :init-keyword :error-handler 71 :init-form report-error) 72 (fatal-handler :init-keyword :fatal-handler 73 :init-form #f) 74 ;; Private 75 (rbuf :init-value "") 76 (original-input-port) ; capture std ports when listener-read-handler is 77 (original-output-port) ; called. 78 (original-error-port) ; 79 )) 80 81(define-method listener-show-prompt ((self <listener>)) 82 (guard (e [(sigpipe? e) 83 (or (listener-fatal self e) 84 (listener-finalize self)) 85 #f]) 86 (with-output-to-port (ref self 'output-port) 87 (^[] 88 ((ref self 'prompter)) 89 (flush) 90 #t)))) 91 92;; Returns a thunk which should be called whenever input is 93;; available. 94 95;; Error handling is rather convoluted, for we have to deal with 96;; a few different cases: 97;; 98;; - I/O errors with reading/writing the client is regarded a 99;; fatal error. The fatal-handler is called if the listener 100;; has any. If the fatal-handler returns #f or the listener 101;; doesn't have one, the finalizer is called. Usually these 102;; handlers removes listener to be called again. 103;; 104;; - Errors during fatal handler or finalizer are "passed through" 105;; to the caller of the listener handler. Usually it has a 106;; fatal consequence. The fatal-handler and finalizer should 107;; be written so that foreseeable errors are properly handled 108;; within them. 109;; 110;; - Other errors (e.g. read error while reading provided S-expr, 111;; or evaluation error) are handled by listener's error-handler. 112;; Double fault is regarded as a fatal error. 113 114(define-method listener-read-handler ((self <listener>)) 115 116 (define (body return) 117 (define (finish) 118 (guard (e [else (return e)]) 119 (listener-finalize self) 120 (return #f))) 121 (define (abort e) 122 (guard (e [else (return e)]) 123 (or (listener-fatal self e) (listener-finalize self)) 124 (return #f))) 125 126 (let1 chunk (guard (e [else (abort e)]) 127 (read-block 8192 (ref self 'input-port))) 128 (when (eof-object? chunk) (finish)) 129 (with-ports 130 (ref self 'input-port) 131 (ref self 'output-port) 132 (ref self 'error-port) 133 (^[] 134 (update! (ref self 'rbuf) (cut string-append <> chunk)) 135 (string-incomplete->complete (ref self 'rbuf)) 136 (guard (e [else 137 (set! (ref self 'rbuf) "") 138 (guard (e1 [else (abort e1)]) 139 ((ref self 'error-handler) e) 140 (listener-show-prompt self) 141 #f)]) 142 (let loop () 143 (update! (ref self 'rbuf) (cut string-trim <> #[\s])) 144 (and (not (string-null? (ref self 'rbuf))) 145 (complete-sexp? (ref self 'rbuf)) 146 (begin 147 (with-input-from-string (ref self 'rbuf) 148 (^[] 149 (let1 expr ((ref self 'reader)) 150 (when (eof-object? expr) (finish)) 151 (receive r 152 ((ref self 'evaluator) expr 153 (ref self 'environment)) 154 (guard (e [(sigpipe? e) (abort e)]) 155 (apply (ref self 'printer) r) 156 (flush))) 157 (set! (ref self 'rbuf) 158 (get-remaining-input-string 159 (current-input-port)))))) 160 (and (listener-show-prompt self) 161 (loop)))))))))) 162 163 ;; Capture std ports when the handler is created 164 (set! (ref self 'original-input-port) (current-input-port)) 165 (set! (ref self 'original-output-port) (current-output-port)) 166 (set! (ref self 'original-error-port) (current-error-port)) 167 168 ;; Returns a handler closure. 169 (^[] 170 (cond [(call/cc body) => raise] 171 [else #t])) 172 ) 173 174;;; 175;;; Private utils 176;;; 177 178(define-method listener-finalize ((self <listener>)) 179 (and-let* ([f (ref self 'finalizer)]) 180 (with-ports 181 (ref self 'original-input-port) 182 (ref self 'original-output-port) 183 (ref self 'original-error-port) 184 f))) 185 186(define-method listener-fatal ((self <listener>) e) 187 (and-let* ([f (ref self 'fatal-handler)]) 188 (with-ports 189 (ref self 'original-input-port) 190 (ref self 'original-output-port) 191 (ref self 'original-error-port) 192 (cut f e)))) 193 194(define (sigpipe? e) 195 (cond-expand 196 [gauche.os.windows #f] 197 [else (and (<unhandled-signal-error> e) 198 (eqv? (ref e 'signal) SIGPIPE))])) 199 200