source: project/release/4/stty/tags/0.2.4/stty.scm @ 30638

Last change on this file since 30638 was 30638, checked in by Alex Shinn, 7 years ago

No ECHOPRT on windows.

File size: 19.9 KB
Line 
1;;;; stty.scm -- stty-like interface to termios
2;;
3;; Copyright (c) 2007-2009 Alex Shinn.  All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6;;;;; High-level interface
7;;
8;; Procedure: (stty [port] settings ...)
9;;
10;;   Sets the terminal attributes for PORT (defaulting to
11;;   current-input-port) according to the SETTINGS, which should be a
12;;   list of symbols corresponding to modes in the stty(1) man page,
13;;   or one or more symbols wrapped in a (not ...) list.
14;;
15;;   To enable a character setting, use a list of the setting name
16;;   followed by the character (or #f to disable), as in
17;;
18;;      (stty (erase #\delete))
19;;
20;;   The following settings are supported:
21;;
22;;      clocal cread crtscts cs5 cs6 cs7 cs8 cstopb hup hupcl parenb
23;;      parodd brkint icrnl ignbrk igncr ignpar imaxbel inpck istrip
24;;      ixany ixoff ixon parmrk tandem ocrnl onlcr onlret onocr opost
25;;      tab0 tab1 tab2 tab3 tabs crterase crtkill ctlecho echo echoctl
26;;      echoe echoke echonl echoprt icanon iexten isig noflsh prterase
27;;      tostop xcase eof eol eol2 erase intr kill lnext quit rprnt
28;;      start stop susp werase raw sane
29
30;; Procedure: (with-stty '(setting ...) thunk)
31;;
32;;   Sets the terminal attributes with STTY, evaluates THUNK, then
33;;   restores the original attributes and returns the value from
34;;   THUNK.
35;;
36;;   Example:
37;;
38;;   (define (read-password prompt)
39;;     (display prompt)
40;;     (with-stty '(not echo) read-line))
41
42;;;;; Low-level interface
43;;
44;; You shouldn't need to use this.
45;;
46;; Procedure: (get-terminal-attributes [port-or-fd])
47;; Procedure: (set-terminal-attributes! port-or-fd action attrs)
48;;
49;; Procedure: (make-term-attrs)
50;; Procedure: (free-term-attrs attrs)
51;; Procedure: (term-attrs-iflag attrs)
52;; Procedure: (term-attrs-oflag attrs)
53;; Procedure: (term-attrs-cflag attrs)
54;; Procedure: (term-attrs-lflag attrs)
55;; Procedure: (term-attrs-cc attrs i)
56;; Procedure: (term-attrs-iflag-set! attrs int)
57;; Procedure: (term-attrs-oflag-set! attrs int)
58;; Procedure: (term-attrs-cflag-set! attrs int)
59;; Procedure: (term-attrs-lflag-set! attrs int)
60;; Procedure: (term-attrs-cc-set! attrs i char)
61
62;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
63
64(require-library srfi-69 foreigners posix)
65
66(module stty
67 (stty with-stty
68  get-terminal-attributes set-terminal-attributes!
69  make-term-attrs free-term-attrs
70  term-attrs-iflag term-attrs-iflag-set!
71  term-attrs-oflag term-attrs-oflag-set!
72  term-attrs-cflag term-attrs-cflag-set!
73  term-attrs-lflag term-attrs-lflag-set!
74  term-attrs-cc term-attrs-cc-set!
75  term-attrs-ispeed term-attrs-ispeed-set!
76  term-attrs-ospeed term-attrs-ospeed-set!
77  TCSANOW TCSADRAIN TCSAFLUSH)
78
79;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80
81(import scheme chicken extras posix srfi-69 foreign foreigners)
82
83(declare (foreign-declare "#include <termios.h>\n"))
84(declare (foreign-declare "typedef struct termios struct_termios;\n"))
85
86(define-foreign-record-type (term-attrs struct_termios)
87  (constructor: make-term-attrs)
88  (destructor: free-term-attrs)
89  (unsigned-long c_iflag term-attrs-iflag term-attrs-iflag-set!)
90  (unsigned-long c_oflag term-attrs-oflag term-attrs-oflag-set!)
91  (unsigned-long c_cflag term-attrs-cflag term-attrs-cflag-set!)
92  (unsigned-long c_lflag term-attrs-lflag term-attrs-lflag-set!)
93  (unsigned-char (c_cc 22) term-attrs-cc term-attrs-cc-set!)
94  (unsigned-long c_ispeed term-attrs-ispeed term-attrs-ispeed-set!)
95  (unsigned-long c_ospeed term-attrs-ospeed term-attrs-ospeed-set!)
96  )
97
98;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99;; constants
100
101(define-foreign-variable TCSANOW_ int "TCSANOW")
102(define-foreign-variable TCSADRAIN_ int "TCSADRAIN")
103(define-foreign-variable TCSAFLUSH_ int "TCSAFLUSH")
104;; (define-foreign-variable TCSASOFT_ int "TCSASOFT")
105
106(define TCSANOW TCSANOW_)
107(define TCSADRAIN TCSADRAIN_)
108(define TCSAFLUSH TCSAFLUSH_)
109;; (define TCSASOFT TCSASOFT_)
110
111(define-foreign-variable IGNBRK unsigned-long)
112(define-foreign-variable BRKINT unsigned-long)
113(define-foreign-variable IGNPAR unsigned-long)
114(define-foreign-variable PARMRK unsigned-long)
115(define-foreign-variable INPCK unsigned-long)
116(define-foreign-variable ISTRIP unsigned-long)
117(define-foreign-variable INLCR unsigned-long)
118(define-foreign-variable IGNCR unsigned-long)
119(define-foreign-variable ICRNL unsigned-long)
120(define-foreign-variable IXON unsigned-long)
121(define-foreign-variable IXOFF unsigned-long)
122(define-foreign-variable IXANY unsigned-long)
123(define-foreign-variable IMAXBEL unsigned-long)
124;; (define-foreign-variable IUCLC unsigned-long)
125
126(define-foreign-variable OPOST unsigned-long)
127(define-foreign-variable ONLCR unsigned-long)
128;; (define-foreign-variable OXTABS unsigned-long)
129;; (define-foreign-variable ONOEOT unsigned-long)
130(define-foreign-variable OCRNL unsigned-long)
131;; (define-foreign-variable OLCUC unsigned-long)
132(define-foreign-variable ONOCR unsigned-long)
133(define-foreign-variable ONLRET unsigned-long)
134
135(define-foreign-variable CSIZE unsigned-long)
136(define-foreign-variable CS5 unsigned-long)
137(define-foreign-variable CS6 unsigned-long)
138(define-foreign-variable CS7 unsigned-long)
139(define-foreign-variable CS8 unsigned-long)
140(define-foreign-variable CSTOPB unsigned-long)
141(define-foreign-variable CREAD unsigned-long)
142(define-foreign-variable PARENB unsigned-long)
143(define-foreign-variable PARODD unsigned-long)
144(define-foreign-variable HUPCL unsigned-long)
145(define-foreign-variable CLOCAL unsigned-long)
146;; (define-foreign-variable CCTS_OFLOW unsigned-long)
147(define-foreign-variable CRTSCTS unsigned-long)
148;; (define-foreign-variable CRTS_IFLOW unsigned-long)
149;; (define-foreign-variable MDMBUF unsigned-long)
150
151(define-foreign-variable ECHOKE unsigned-long)
152(define-foreign-variable ECHOE unsigned-long)
153(define-foreign-variable ECHO unsigned-long)
154(define-foreign-variable ECHONL unsigned-long)
155(cond-expand
156 (windows (define ECHOPRT 0))
157 (else (define-foreign-variable ECHOPRT unsigned-long)))
158(define-foreign-variable ECHOCTL unsigned-long)
159(define-foreign-variable ISIG unsigned-long)
160(define-foreign-variable ICANON unsigned-long)
161;; (define-foreign-variable ALTWERASE unsigned-long)
162(define-foreign-variable IEXTEN unsigned-long)
163;; (define-foreign-variable EXTPROC unsigned-long)
164(define-foreign-variable TOSTOP unsigned-long)
165(define-foreign-variable FLUSHO unsigned-long)
166;; (define-foreign-variable NOKERNINFO unsigned-long)
167(define-foreign-variable PENDIN unsigned-long)
168(define-foreign-variable NOFLSH unsigned-long)
169
170(define-foreign-variable VEOF unsigned-long)
171(define-foreign-variable VEOL unsigned-long)
172(define-foreign-variable VEOL2 unsigned-long)
173(define-foreign-variable VERASE unsigned-long)
174;; (define-foreign-variable VERASE2 unsigned-long)
175(define-foreign-variable VWERASE unsigned-long)
176(define-foreign-variable VINTR unsigned-long)
177(define-foreign-variable VKILL unsigned-long)
178(define-foreign-variable VQUIT unsigned-long)
179(define-foreign-variable VSUSP unsigned-long)
180(define-foreign-variable VSTART unsigned-long)
181(define-foreign-variable VSTOP unsigned-long)
182;; (define-foreign-variable VDSUSP unsigned-long)
183(define-foreign-variable VLNEXT unsigned-long)
184(define-foreign-variable VREPRINT unsigned-long)
185(define-foreign-variable VSTATUS unsigned-long)
186
187;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
188;; basic interface
189
190(define get-term-attrs
191  (foreign-lambda* int ((int fd) (c-pointer t))
192    "return(tcgetattr(fd, (struct termios*) t));"))
193
194(define (get-terminal-attributes port . o)
195  (let* ((t (if (pair? o) (car o) (make-term-attrs)))
196         (fd (if (port? port) (port->fileno port) port))
197         (ok? (zero? (get-term-attrs fd t))))
198    ;; free and return #f on failure
199    (if (and (not ok?) (null? o))
200        (free-term-attrs t))
201    (and ok? t)))
202
203(define set-term-attrs!
204  (foreign-lambda* int ((int fd) (int action) (c-pointer t))
205    "return(tcsetattr(fd, action, (struct termios*) t));"))
206
207(define (set-terminal-attributes! port action t)
208  (set-term-attrs! (if (port? port) (port->fileno port) port) action t))
209
210;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
211;; symbolic representation of attributes
212
213(define stty-lookup (make-hash-table eq?))
214
215(for-each
216 (lambda (c)
217   (let ((type (cadr c))
218         (value (caddr c)))
219     (hash-table-set! stty-lookup (car c) (cdr c))))
220
221 ;; ripped from the stty man page, then trimmed down to what seemed
222 ;; available on most systems
223
224 `(;; characters
225;;    (dsusp    char     ,VDSUSP)   ; CHAR will send a terminal stop signal
226   (eof      char     ,VEOF)     ; CHAR will send an EOF (terminate input)
227   (eol      char     ,VEOL)     ; CHAR will end the line
228   (eol2     char     ,VEOL2)    ; alternate CHAR for ending the line
229   (erase    char     ,VERASE)   ; CHAR will erase the last character typed
230   (intr     char     ,VINTR)    ; CHAR will send an interrupt signal
231   (kill     char     ,VKILL)    ; CHAR will erase the current line
232   (lnext    char     ,VLNEXT)   ; CHAR will enter the next character quoted
233   (quit     char     ,VQUIT)    ; CHAR will send a quit signal
234   (rprnt    char     ,VREPRINT) ; CHAR will redraw the current line
235   (start    char     ,VSTART)   ; CHAR will restart output after stopping it
236   (stop     char     ,VSTOP)    ; CHAR will stop the output
237   (susp     char     ,VSUSP)    ; CHAR will send a terminal stop signal
238   (werase   char     ,VWERASE)  ; CHAR will erase the last word typed
239
240   ;; special settings
241   (cols     special  #f) ; tell the kernel that the terminal has N columns
242   (columns  special  #f) ; same as cols N
243   (ispeed   special  #f) ; set the input speed to N
244   (line     special  #f) ; use line discipline N
245   (min      special  #f) ; with -icanon, set N characters minimum for a completed read
246   (ospeed   special  #f) ; set the output speed to N
247   (rows     special  #f) ; tell the kernel that the terminal has N rows
248   (size     special  #f) ; print the number of rows and columns according to the kernel
249   (speed    special  #f) ; print the terminal speed
250   (time     special  #f) ; with -icanon, set read timeout of N tenths of a second
251
252   ;; control settings
253   (clocal   control  ,CLOCAL)  ; disable modem control signals
254   (cread    control  ,CREAD)   ; allow input to be received
255   (crtscts  control  ,CRTSCTS) ; enable RTS/CTS handshaking
256   (cs5      control  ,CS5)     ; set character size to 5 bits
257   (cs6      control  ,CS6)     ; set character size to 6 bits
258   (cs7      control  ,CS7)     ; set character size to 7 bits
259   (cs8      control  ,CS8)     ; set character size to 8 bits
260   (cstopb   control  ,CSTOPB)  ; use two stop bits per character (one with `-')
261   (hup      control  ,HUPCL)   ; send a hangup signal when the last process closes the tty
262   (hupcl    control  ,HUPCL)   ; same as [-]hup
263   (parenb   control  ,PARENB)  ; generate parity bit in output and expect parity bit in input
264   (parodd   control  ,PARODD)  ; set odd parity (even with `-')
265
266   ;; input settings
267   (brkint   input    ,BRKINT)  ; breaks cause an interrupt signal
268   (icrnl    input    ,ICRNL)   ; translate carriage return to newline
269   (ignbrk   input    ,IGNBRK)  ; ignore break characters
270   (igncr    input    ,IGNCR)   ; ignore carriage return
271   (ignpar   input    ,IGNPAR)  ; ignore characters with parity errors
272   (imaxbel  input    ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
273   (inlcr    input    ,INLCR)   ; translate newline to carriage return
274   (inpck    input    ,INPCK)   ; enable input parity checking
275   (istrip   input    ,ISTRIP)  ; clear high (8th) bit of input characters
276;;    (iuclc    input    ,IUCLC)   ; * translate uppercase characters to lowercase
277   (ixany    input    ,IXANY)   ; * let any character restart output, not only start character
278   (ixoff    input    ,IXOFF)   ; enable sending of start/stop characters
279   (ixon     input    ,IXON)    ; enable XON/XOFF flow control
280   (parmrk   input    ,PARMRK)  ; mark parity errors (with a 255-0-character sequence)
281   (tandem   input    ,IXOFF)   ; same as [-]ixoff
282
283   ;; output settings
284;;    (bs0      output   ,BS0) ; backspace delay style, N in [0..1]
285;;    (bs1      output   ,BS1) ; backspace delay style, N in [0..1]
286;;    (cr0      output   ,CR0) ; carriage return delay style, N in [0..3]
287;;    (cr1      output   ,CR1) ; carriage return delay style, N in [0..3]
288;;    (cr2      output   ,CR2) ; carriage return delay style, N in [0..3]
289;;    (cr3      output   ,CR3) ; carriage return delay style, N in [0..3]
290;;    (ff0      output   ,FF0) ; form feed delay style, N in [0..1]
291;;    (ff1      output   ,FF1) ; form feed delay style, N in [0..1]
292;;    (nl0      output   ,NL0) ; newline delay style, N in [0..1]
293;;    (nl1      output   ,NL1) ; newline delay style, N in [0..1]
294   (ocrnl    output   ,OCRNL) ; translate carriage return to newline
295;;    (ofdel    output   ,OFDEL) ; use delete characters for fill instead of null characters
296;;    (ofill    output   ,OFILL) ; use fill (padding) characters instead of timing for delays
297;;    (olcuc    output   ,OLCUC) ; translate lowercase characters to uppercase
298   (onlcr    output   ,ONLCR) ; translate newline to carriage return-newline
299   (onlret   output   ,ONLRET) ; newline performs a carriage return
300   (onocr    output   ,ONOCR) ; do not print carriage returns in the first column
301   (opost    output   ,OPOST) ; postprocess output
302   (tab0     output   #f) ; horizontal tab delay style, N in [0..3]
303   (tab1     output   #f) ; horizontal tab delay style, N in [0..3]
304   (tab2     output   #f) ; horizontal tab delay style, N in [0..3]
305   (tab3     output   #f) ; horizontal tab delay style, N in [0..3]
306   (tabs     output   #f) ; same as tab0
307   ;;(-tabs    output   #f) ; same as tab3
308;;    (vt0      output   ,VT0) ; vertical tab delay style, N in [0..1]
309;;    (vt1      output   ,VT1) ; vertical tab delay style, N in [0..1]
310
311   ;; local settings
312   (crterase local    ,ECHOE)   ; echo erase characters as backspace-space-backspace
313   (crtkill  local    ,ECHOKE)  ; kill all line by obeying the echoprt and echoe settings
314   ;;(-crtkill local    #f) ; kill all line by obeying the echoctl and echok settings
315   (ctlecho  local    ,ECHOCTL) ; echo control characters in hat notation (`^c')
316   (echo     local    ,ECHO)    ; echo input characters
317   (echoctl  local    ,ECHOCTL) ; same as [-]ctlecho
318   (echoe    local    ,ECHOE)   ; same as [-]crterase
319;;    (echok    local    ,ECHOK)   ; echo a newline after a kill character
320   (echoke   local    ,ECHOKE)  ; same as [-]crtkill
321   (echonl   local    ,ECHONL)  ; echo newline even if not echoing other characters
322   (echoprt  local    ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
323   (icanon   local    ,ICANON)  ; enable erase, kill, werase, and rprnt special characters
324;;   (iexten   local    ,IEXTEN)  ; enable non-POSIX special characters
325   (isig     local    ,ISIG)    ; enable interrupt, quit, and suspend special characters
326   (noflsh   local    ,NOFLSH)  ; disable flushing after interrupt and quit special characters
327   (prterase local    ,ECHOPRT) ; same as [-]echoprt
328   (tostop   local    ,TOSTOP)  ; stop background jobs that try to write to the terminal
329;;    (xcase    local    ,XCASE)   ; with icanon, escape with `\' for uppercase characters
330
331   ;; combination settings
332   (LCASE    combine  (lcase))
333   (cbreak   combine  (not icanon))
334   (cooked   combine  (brkint ignpar istrip icrnl ixon opost isig icanon))
335                                        ; also eof and eol characters
336                                        ; to their default values
337   (crt      combine  (echoe echoctl echoke))
338   (dec      combine  (echoe echoctl echoke (not ixany)))
339                                        ; also intr ^c erase 0177 kill ^u
340   (decctlq  combine  (ixany))
341   (ek       combine  ()) ; erase and kill characters to their default values
342   (evenp    combine  (parenb (not parodd) cs7))
343   ;;(-evenp combine  #f) ; same as -parenb cs8
344   (lcase    combine  (xcase iuclc olcuc))
345   (litout   combine  (cs8 (not parenb istrip opost)))
346   ;;(-litout  combine  #f) ; same as parenb istrip opost cs7
347   (nl       combine  (not icrnl onlcr))
348   ;;(-nl      combine  #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
349   (oddp     combine  (parenb parodd cs7))
350   (parity   combine  (evenp)) ; same as [-]evenp
351   (pass8    combine  (cs8 (not parenb istrip)))
352   ;;(-pass8   combine  #f) ; same as parenb istrip cs7
353   (raw      combine  (not ignbrk brkint ignpar parmrk
354                           inpck istrip inlcr igncr icrnl))
355   (ixon     combine  (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
356   ;;(time     combine  #f) ; 0
357   ;;(-raw     combine  #f) ; same as cooked
358   (sane     combine  (cread brkint icrnl imaxbel opost onlcr
359                       isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
360                       echo echoe echoctl echoke ;; iexten echok
361                       (not ignbrk igncr ixoff ixany inlcr ;; iuclc
362                            ocrnl onocr onlret ;; olcuc ofill ofdel
363                            echonl noflsh tostop echoprt))) ;; xcase
364                                        ; plus all special characters to
365                                        ; their default values
366   ))
367
368;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
369;; high-level interface
370
371(define (stty . args)
372
373  (let* ((port (if (and (pair? args) (port? (car args)))
374                   (car args)
375                   (current-input-port)))
376         (attr (get-terminal-attributes port))
377         (iflag (term-attrs-iflag attr))
378         (oflag (term-attrs-oflag attr))
379         (cflag (term-attrs-cflag attr))
380         (lflag (term-attrs-lflag attr)))
381
382    ;; parse change requests
383    (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
384             (flag #t))
385      (cond
386       ((pair? lst)
387        (let ((command (car lst)))
388          (cond
389           ((pair? command) ;; recurse on sub-expr
390            (lp command flag)
391            (lp (cdr lst) flag))
392           ((eq? command 'not) ;; toggle current setting
393            (lp (cdr lst) (not flag)))
394           (else
395            (let* ((x (hash-table-ref/default stty-lookup command #f))
396                   (type (if (pair? x) (car x) #f)))
397              (case type
398                ((input)
399                 (if flag
400                     (set! iflag (bitwise-ior iflag (cadr x)))
401                     (set! iflag (bitwise-and iflag (bitwise-not (cadr x)))))
402                 (lp (cdr lst) flag))
403                ((output)
404                 (if flag
405                     (set! oflag (bitwise-ior oflag (cadr x)))
406                     (set! oflag (bitwise-and oflag (bitwise-not (cadr x)))))
407                 (lp (cdr lst) flag))
408                ((control)
409                 (if flag
410                     (set! cflag (bitwise-ior cflag (cadr x)))
411                     (set! cflag (bitwise-and cflag (bitwise-not (cadr x)))))
412                 (lp (cdr lst) flag))
413                ((local)
414                 (if flag
415                     (set! lflag (bitwise-ior lflag (cadr x)))
416                     (set! lflag (bitwise-and lflag (bitwise-not (cadr x)))))
417                 (lp (cdr lst) flag))
418                ((special)
419                 (error "special settings not yet supported"))
420                ((char)
421                 (term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
422                 (lp (cddr lst) flag))
423                ((combine) ;; recurse on def of this command
424                 (lp (cadr x) flag)
425                 (lp (cdr lst) flag))
426                (else
427                 (warning "unknown stty command" command)
428                 (lp (cdr lst) flag))))))))))
429
430    ;; set new values
431    (term-attrs-iflag-set! attr iflag)
432    (term-attrs-oflag-set! attr oflag)
433    (term-attrs-cflag-set! attr cflag)
434    (term-attrs-lflag-set! attr lflag)
435    (set-terminal-attributes! port TCSANOW attr)
436    (free-term-attrs attr)))
437
438(define (with-stty setting thunk)
439  (let* ((port (current-input-port))
440         (orig-attrs (get-terminal-attributes port)))
441    (dynamic-wind
442        (lambda ()
443          (stty setting))
444        thunk
445        (lambda ()
446          (set-terminal-attributes! port TCSANOW orig-attrs)
447          (free-term-attrs orig-attrs)))))
448
449)
Note: See TracBrowser for help on using the repository browser.