;; Copyright (c) 2011 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> A high-level interface to stty and ioctl.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; symbolic representation of attributes
(define stty-lookup (make-hash-table eq?))
(for-each
(lambda (c) (hash-table-set! stty-lookup (car c) (cdr c)))
;; ripped from the stty man page, then trimmed down to what seemed
;; available on most systems
`(;; characters
;;(dsusp char ,VDSUSP) ; CHAR will send a terminal stop signal
(eof char ,VEOF) ; CHAR will send an EOF (terminate input)
(eol char ,VEOL) ; CHAR will end the line
(eol2 char ,VEOL2) ; alternate CHAR for ending the line
(erase char ,VERASE) ; CHAR will erase the last character typed
(intr char ,VINTR) ; CHAR will send an interrupt signal
(kill char ,VKILL) ; CHAR will erase the current line
(lnext char ,VLNEXT) ; CHAR will enter the next character quoted
(quit char ,VQUIT) ; CHAR will send a quit signal
(rprnt char ,VREPRINT) ; CHAR will redraw the current line
(start char ,VSTART) ; CHAR will restart output after stopping it
(stop char ,VSTOP) ; CHAR will stop the output
(susp char ,VSUSP) ; CHAR will send a terminal stop signal
(werase char ,VWERASE) ; CHAR will erase the last word typed
;; special settings
(cols special #f) ; tell the kernel that the terminal has N columns
(columns special #f) ; same as cols N
(ispeed special #f) ; set the input speed to N
(line special #f) ; use line discipline N
(min special #f) ; with -icanon, set N characters minimum for a completed read
(ospeed special #f) ; set the output speed to N
(rows special #f) ; tell the kernel that the terminal has N rows
(size special #f) ; print the number of rows and columns according to the kernel
(speed special #f) ; print the terminal speed
(time special #f) ; with -icanon, set read timeout of N tenths of a second
;; control settings
(clocal control ,CLOCAL) ; disable modem control signals
(cread control ,CREAD) ; allow input to be received
(crtscts control ,CRTSCTS) ; enable RTS/CTS handshaking
(cs5 control ,CS5) ; set character size to 5 bits
(cs6 control ,CS6) ; set character size to 6 bits
(cs7 control ,CS7) ; set character size to 7 bits
(cs8 control ,CS8) ; set character size to 8 bits
(cstopb control ,CSTOPB) ; use two stop bits per character (one with `-')
(hup control ,HUPCL) ; send a hangup signal when the last process closes the tty
(hupcl control ,HUPCL) ; same as [-]hup
(parenb control ,PARENB) ; generate parity bit in output and expect parity bit in input
(parodd control ,PARODD) ; set odd parity (even with `-')
;; input settings
(brkint input ,BRKINT) ; breaks cause an interrupt signal
(icrnl input ,ICRNL) ; translate carriage return to newline
(ignbrk input ,IGNBRK) ; ignore break characters
(igncr input ,IGNCR) ; ignore carriage return
(ignpar input ,IGNPAR) ; ignore characters with parity errors
(imaxbel input ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
(inlcr input ,INLCR) ; translate newline to carriage return
(inpck input ,INPCK) ; enable input parity checking
(istrip input ,ISTRIP) ; clear high (8th) bit of input characters
;;(iuclc input ,IUCLC) ; * translate uppercase characters to lowercase
(ixany input ,IXANY) ; * let any character restart output, not only start character
(ixoff input ,IXOFF) ; enable sending of start/stop characters
(ixon input ,IXON) ; enable XON/XOFF flow control
(parmrk input ,PARMRK) ; mark parity errors (with a 255-0-character sequence)
(tandem input ,IXOFF) ; same as [-]ixoff
;; output settings
;;(bs0 output ,BS0) ; backspace delay style, N in [0..1]
;;(bs1 output ,BS1) ; backspace delay style, N in [0..1]
;;(cr0 output ,CR0) ; carriage return delay style, N in [0..3]
;;(cr1 output ,CR1) ; carriage return delay style, N in [0..3]
;;(cr2 output ,CR2) ; carriage return delay style, N in [0..3]
;;(cr3 output ,CR3) ; carriage return delay style, N in [0..3]
;;(ff0 output ,FF0) ; form feed delay style, N in [0..1]
;;(ff1 output ,FF1) ; form feed delay style, N in [0..1]
;;(nl0 output ,NL0) ; newline delay style, N in [0..1]
;;(nl1 output ,NL1) ; newline delay style, N in [0..1]
(ocrnl output ,OCRNL) ; translate carriage return to newline
;;(ofdel output ,OFDEL) ; use delete characters for fill instead of null characters
;;(ofill output ,OFILL) ; use fill (padding) characters instead of timing for delays
;;(olcuc output ,OLCUC) ; translate lowercase characters to uppercase
(onlcr output ,ONLCR) ; translate newline to carriage return-newline
(onlret output ,ONLRET) ; newline performs a carriage return
(onocr output ,ONOCR) ; do not print carriage returns in the first column
(opost output ,OPOST) ; postprocess output
(tab0 output #f) ; horizontal tab delay style, N in [0..3]
(tab1 output #f) ; horizontal tab delay style, N in [0..3]
(tab2 output #f) ; horizontal tab delay style, N in [0..3]
(tab3 output #f) ; horizontal tab delay style, N in [0..3]
(tabs output #f) ; same as tab0
;;(-tabs output #f) ; same as tab3
;;(vt0 output ,VT0) ; vertical tab delay style, N in [0..1]
;;(vt1 output ,VT1) ; vertical tab delay style, N in [0..1]
;; local settings
(crterase local ,ECHOE) ; echo erase characters as backspace-space-backspace
(crtkill local ,ECHOKE) ; kill all line by obeying the echoprt and echoe settings
;;(-crtkill local #f) ; kill all line by obeying the echoctl and echok settings
(ctlecho local ,ECHOCTL) ; echo control characters in hat notation (`^c')
(echo local ,ECHO) ; echo input characters
(echoctl local ,ECHOCTL) ; same as [-]ctlecho
(echoe local ,ECHOE) ; same as [-]crterase
;;(echok local ,ECHOK) ; echo a newline after a kill character
(echoke local ,ECHOKE) ; same as [-]crtkill
(echonl local ,ECHONL) ; echo newline even if not echoing other characters
;;(echoprt local ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
(icanon local ,ICANON) ; enable erase, kill, werase, and rprnt special characters
;;(iexten local ,IEXTEN) ; enable non-POSIX special characters
(isig local ,ISIG) ; enable interrupt, quit, and suspend special characters
(noflsh local ,NOFLSH) ; disable flushing after interrupt and quit special characters
;;(prterase local ,ECHOPRT) ; same as [-]echoprt
(tostop local ,TOSTOP) ; stop background jobs that try to write to the terminal
;;(xcase local ,XCASE) ; with icanon, escape with `\' for uppercase characters
;; combination settings
(LCASE combine (lcase))
(cbreak combine (not icanon))
(cooked combine (brkint ignpar istrip icrnl ixon opost isig icanon))
; also eof and eol characters
; to their default values
(crt combine (echoe echoctl echoke))
(dec combine (echoe echoctl echoke (not ixany)))
; also intr ^c erase 0177 kill ^u
(decctlq combine (ixany))
(ek combine ()) ; erase and kill characters to their default values
(evenp combine (parenb (not parodd) cs7))
;;(-evenp combine #f) ; same as -parenb cs8
(lcase combine (xcase iuclc olcuc))
(litout combine (cs8 (not parenb istrip opost)))
;;(-litout combine #f) ; same as parenb istrip opost cs7
(nl combine (not icrnl onlcr))
;;(-nl combine #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
(oddp combine (parenb parodd cs7))
(parity combine (evenp)) ; same as [-]evenp
(pass8 combine (cs8 (not parenb istrip)))
;;(-pass8 combine #f) ; same as parenb istrip cs7
(raw combine (not ignbrk brkint ignpar parmrk
inpck istrip inlcr igncr icrnl))
;;(ixon combine (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
;;(time combine #f) ; 0
;;(-raw combine #f) ; same as cooked
(sane combine (cread brkint icrnl imaxbel opost onlcr
isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
echo echoe echoctl echoke ;; iexten echok
(not ignbrk igncr ixoff ixany inlcr ;; iuclc
ocrnl onocr onlret ;; olcuc ofill ofdel
echonl noflsh tostop echoprt))) ;; xcase
; plus all special characters to
; their default values
))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; high-level interface
;;> \subsubsubsection{\scheme{(stty [port] args ...)}}
;;> Set the terminal attributes for \var{port} (default
;;> \scheme{(current-output-port)}) to \var{attrs}.
;;> Attributes are specified symbolically using the
;;> names from the \rawcode{stty(1)} command. In addition,
;;> (not args ...) may be used to negate the listed symbols.
(define (stty . args)
(let* ((port (if (and (pair? args) (port? (car args)))
(car args)
(current-output-port)))
(attr (get-terminal-attributes port)))
;; parse change requests
(let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
(iflag (term-attrs-iflag attr))
(oflag (term-attrs-oflag attr))
(cflag (term-attrs-cflag attr))
(lflag (term-attrs-lflag attr))
(invert? #f)
(return (lambda (iflag oflag cflag lflag)
(term-attrs-iflag-set! attr iflag)
(term-attrs-oflag-set! attr oflag)
(term-attrs-cflag-set! attr cflag)
(term-attrs-lflag-set! attr lflag)
(set-terminal-attributes! port TCSANOW attr))))
(define (join old new)
(if invert? (bitwise-and old (bitwise-not new)) (bitwise-ior old new)))
(cond
((pair? lst)
(let ((command (car lst)))
(cond
((pair? command) ;; recurse on sub-expr
(lp command iflag oflag cflag lflag invert?
(lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
((eq? command 'not) ;; toggle current setting
(lp (cdr lst) iflag oflag cflag lflag (not invert?) return))
(else
(let ((x (hash-table-ref/default stty-lookup command #f)))
(case (and x (car x))
((input)
(lp (cdr lst) (join iflag (cadr x)) oflag cflag lflag invert? return))
((output)
(lp (cdr lst) iflag (join oflag (cadr x)) cflag lflag invert? return))
((control)
(lp (cdr lst) iflag oflag (join cflag (cadr x)) lflag invert? return))
((local)
(lp (cdr lst) iflag oflag cflag (join lflag (cadr x)) invert? return))
((char)
;;(term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
(lp (cddr lst) iflag oflag cflag lflag invert? return))
((combine)
(lp (cadr x) iflag oflag cflag lflag invert?
(lambda (i o c l) (lp (cdr lst) i o c l invert? return))))
((special)
(error "special settings not yet supported" command))
(else
(error "unknown stty command" command))))))))
(else
(return iflag oflag cflag lflag))))))
;;> Run \var{thunk} with the \scheme{stty} \var{setting}s in effect
;;> during its dynamic extent, resetting the original settings
;;> when it returns.
(define (with-stty setting thunk . o)
(let* ((port (if (pair? o) (car o) (current-input-port)))
(orig-attrs (get-terminal-attributes port)))
(cond
(orig-attrs
(dynamic-wind
(lambda () (stty port setting))
thunk
(lambda () (set-terminal-attributes! port TCSANOW orig-attrs))))
(else
;; No terminal attributes means this isn't a tty.
(thunk)))))
;;> Run \var{thunk} with the "raw" (no canonical or echo) options
;;> needed for a terminal application.
(define (with-raw-io port thunk)
(with-stty '(not icanon isig echo) thunk port))
;;> Returns the current terminal width in characters of \var{x},
;;> which must be a port or a file descriptor.
(define (get-terminal-width x)
(let ((ws (ioctl x TIOCGWINSZ)))
(and ws (winsize-col ws))))
;;> Returns the current terminal dimensions, as a list of character width
;;> and height, of \var{x}, which must be a port or a file descriptor.
(define (get-terminal-dimensions x)
(let ((ws (ioctl x TIOCGWINSZ)))
(and ws (list (winsize-col ws) (winsize-row ws)))))