1;;; -*- mode:scheme; coding: utf-8 -*- 2;;; 3;;; sagittarius/stty.scm - STTY 4;;; 5;;; Copyright (c) 2015 Takashi Kato <ktakashi@ymail.com> 6;;; 7;;; Redistribution and use in source and binary forms, with or without 8;;; modification, are permitted provided that the following conditions 9;;; are met: 10;;; 11;;; 1. Redistributions of source code must retain the above copyright 12;;; notice, this list of conditions and the following disclaimer. 13;;; 14;;; 2. Redistributions in binary form must reproduce the above copyright 15;;; notice, this list of conditions and the following disclaimer in the 16;;; documentation and/or other materials provided with the distribution. 17;;; 18;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 24;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 25;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 26;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 27;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 28;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29;;; 30 31;; the API names are taken from Chibi Scheme 32(library (sagittarius stty) 33 (export stty with-stty with-raw-io) 34 (import (rnrs) 35 (sagittarius) 36 (sagittarius termios)) 37 38;; borrowed from Chibi 39;; Copyright (c) 2011 Alex Shinn. All rights reserved. 40;; BSD-style license: http://synthcode.com/license.txt 41(define stty-lookup 42 (let ((ht (make-eq-hashtable))) 43 (for-each 44 (lambda (c) 45 (let ((type (cadr c)) 46 (value (car (cddr c)))) 47 (hashtable-set! ht (car c) (cdr c)))) 48 49 ;; We only support what POSIX requires (which is what our Windows 50 ;; platform porting supports) 51 ;; Reference 52 ;; http://pubs.opengroup.org/onlinepubs/009696799/utilities/stty.html 53 54 `(;; Control Modes 55 (parenb control ,PARENB) ; Enable parity generation 56 (parodd control ,PARODD) ; Select odd parity 57 (cs5 control ,CS5) ; character size 5 bits 58 (cs6 control ,CS6) ; character size 6 bits 59 (cs7 control ,CS7) ; character size 7 bits 60 (cs8 control ,CS8) ; character size 8 bits 61 (ispeed special #f) ; not supported yet 62 (ospeed special #f) ; not supported yet 63 (hupcl control ,HUPCL) ; Stop asserting modem control line 64 (cstopb control ,CSTOPB) ; Use two (one) stop bits per character 65 (cread control ,CREAD) ; Enable the receiver 66 (clocal control ,CLOCAL) ; Assume a line without modem control 67 68 ;; Input Modes 69 (ignbrk input ,IGNBRK) ; Ignore break on input 70 (brkint input ,BRKINT) ; Signal INTR on break 71 (ignpar input ,IGNPAR) ; Ignore bytes with parity errors 72 (parmrk input ,PARMRK) ; Mark parity errors 73 (inpck input ,INPCK) ; Enable input parity checking 74 (istrip input ,ISTRIP) ; Strip input characters to seven bits 75 (inlcr input ,INLCR) ; Map NL to CR on input 76 (igncr input ,IGNCR) ; Ignore CR on input 77 (icrnl input ,ICRNL) ; Map CR to NL on input 78 (ixon input ,IXON) ; Enable START/STOP output control 79 (ixany input ,IXANY) ; Allow any character to restart output 80 (ixoff input ,IXOFF) ; Request that the system send STOP 81 ; character when the input queue is 82 ; nearly full and START characters 83 ; to resume data transmission 84 85 ;; Output Modes 86 (opost output ,OPOST) ; Post-process output 87 (ocrnl output ,OCRNL) ; Map CR to NL on output 88 (onocr output ,ONOCR) ; Do not output CR at column zero 89 (onlret output ,ONLRET) ; The terminal newline key performs 90 ; the CR function 91 (ofill output ,OFILL) ; Use fill characters for delays 92 ;; this isn't on POSIX-2004 93 ;; (ofdel output ,OFDEL) ; Fill characters are DELs 94 (cr0 output ,CR0) ; Select the style of delay for CRs 95 (cr1 output ,CR1) 96 (cr2 output ,CR2) 97 (cr3 output ,CR3) 98 (nl0 output ,NL0) ; Select the style of delay for NL 99 (nl1 output ,NL1) 100 (tab0 output ,TAB0) ; Select the style of delay for 101 (tab1 output ,TAB1) ; horizontal tabs 102 (tab2 output ,TAB2) 103 (tab3 output ,TAB3) 104 (tabs output (tab0)) ; Synonym for tab0 105 (ff0 output ,FF0) ; Select the style of delay for 106 (ff1 output ,FF1) ; from-feeds 107 (vt0 output ,VT0) ; Select the style of delay for 108 (vt1 output ,VT1) ; vertical-tabs 109 110 ;; Local Modes 111 (isig local ,ISIG) ; Enable the checking of characters 112 ; against the special control 113 ; characters INTR, QUIT and SUSP 114 (icanon local ,ICANON) ; Enable canonical input (ERACE and 115 ; KILL processing) 116 (iexten local ,IEXTEN) ; Enable any implementation-defined 117 ; special control characters not 118 ; controlled by icanon, isig, ixon 119 ; or ixoff 120 (echo local ,ECHO) ; Echo back every character typed 121 (echoe local ,ECHOE) ; The ERACE character visually erases 122 ; the last character in the current 123 ; line from the display, if possible 124 (echok local ,ECHOK) ; Echo NL after KILL character 125 (echonl local ,ECHONL) ; Echo NL, even if echo is disabled 126 (noflsh local ,NOFLSH) ; Disable flush after INTR, QUIT, SUSP 127 (tostop local ,TOSTOP) ; Send SIGTTOU for background output 128 129 ;; Special Control Character Assignments 130 (eof char ,VEOF) ; EOF character 131 (eol char ,VEOL) ; EOL character 132 (erase char ,VERASE) ; ERASE character 133 (intr char ,VINTR) ; INTR character 134 (kill char ,VKILL) ; KILL character 135 (quit char ,VQUIT) ; QUIT character 136 (susp char ,VSUSP) ; SUSP character 137 (star char ,VSTART) ; START character 138 (stop char ,VSTOP) ; STOP character 139 (min special #f) ; not supported yet 140 (time special #f) ; not supported yet 141 142 ;; Combination Modes 143 (evenp combine (parity)) ; Enable parenb and cs7, disable parodd 144 (parity combine (parenb cs7 (not parodd))) 145 (oddp combine (parenb cs7 parodd)) ; Enable parenb, cs7 and parodd 146 ;; Enable raw input and output 147 (raw combine (not ignbrk brkint ignpar parmrk 148 inpck istrip inlcr igncr icrnl)) 149 (cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon)) 150 (nl combine (not icrnl onlcr)) ; Disable icrnl 151 (ek combine ()) ; Reset ERACE and KILL characters 152 ; back to system default 153 ;; Reset all modes to some reasonabl, unspecified, values 154 (sane combine (cread brkint icrnl opost onlcr 155 isig icanon nl0 cr0 bs0 vt0 ff0 tab0 156 echo echoe iexten echok 157 (not ignbrk igncr ixoff ixany inlcr 158 ocrnl onocr onlret 159 echonl noflsh tostop))) 160 161 ;; extra combination modes (from Chibi's definition) 162 (litout combine (cs8 (not parenb istrip opost))) 163 ;; -parity? 164 (pass8 combine (cs8 (not parenb istrip))) 165 ;; well, duplicated value... 166 ;; (ixon combine (ixoff ixany opost isig icanon)) 167 )) 168 ht)) 169 170(define (stty port setting) 171 (let ((attr (sys-tcgetattr port))) 172 (let lp ((lst setting) 173 (iflag (termios-iflag attr)) 174 (oflag (termios-oflag attr)) 175 (cflag (termios-cflag attr)) 176 (lflag (termios-lflag attr)) 177 (cc (termios-cc attr)) 178 (invert? #f) 179 (return (lambda (iflag oflag cflag lflag cc) 180 (termios-iflag-set! attr iflag) 181 (termios-oflag-set! attr oflag) 182 (termios-cflag-set! attr cflag) 183 (termios-lflag-set! attr lflag) 184 (termios-cc-set! attr cc) 185 (sys-tcsetattr! port TCSANOW attr)))) 186 (define (join old new) 187 (if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new))) 188 (cond 189 ((pair? lst) 190 (let ((command (car lst))) 191 (cond 192 ((pair? command) ;; recurse on sub-expr 193 (lp command iflag oflag cflag lflag cc invert? 194 (lambda (i o c l cc) (lp (cdr lst) i o c l cc invert? return)))) 195 ((eq? command 'not) ;; toggle current setting 196 (lp (cdr lst) iflag oflag cflag lflag cc (not invert?) return)) 197 (else 198 (let ((x (hashtable-ref stty-lookup command #f))) 199 (case (and x (car x)) 200 ((input) 201 (lp (cdr lst) (join iflag (cadr x)) 202 oflag cflag lflag cc invert? return)) 203 ((output) 204 (lp (cdr lst) iflag (join oflag (cadr x)) 205 cflag lflag cc invert? return)) 206 ((control) 207 (lp (cdr lst) iflag oflag (join cflag (cadr x)) 208 lflag cc invert? return)) 209 ((local) 210 (lp (cdr lst) iflag oflag cflag 211 (join lflag (cadr x)) cc invert? return)) 212 ((char) 213 ;; must be a char 214 (let ((c (or (cadr lst) #\null))) 215 (unless (char? c) 216 (error 'stty "char property must be followed by character " 217 c)) 218 (vector-set! cc (cadr x) c)) 219 ;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0)) 220 (lp (cddr lst) iflag oflag cflag lflag cc invert? return)) 221 ((combine) 222 (lp (cadr x) iflag oflag cflag lflag cc invert? 223 (lambda (i o c l cc) 224 (lp (cdr lst) i o c l cc invert? return)))) 225 ((special) 226 (error 'stty "special settings not yet supported" command)) 227 (else 228 (error 'stty "unknown stty command" command)))))))) 229 (else 230 (return iflag oflag cflag lflag cc)))))) 231 232(define (with-stty setting thunk :optional (port (current-input-port))) 233 (cond ((sys-tcgetattr port) => 234 (lambda (attr) 235 (dynamic-wind 236 (lambda () (stty port setting)) 237 thunk 238 (lambda () (sys-tcsetattr! port TCSANOW attr))))) 239 (else (thunk)))) 240 241(define (with-raw-io port thunk) 242 (with-stty '(not icanon echo isig) thunk port)) 243 244 245;; TODO 246;; get-terminal-width 247;; get-terminal-dimensions 248) 249 250