source: project/release/4/stty/trunk/stty.scm @ 28337

Last change on this file since 28337 was 28337, checked in by Alex Shinn, 8 years ago

Fixing typo in nested (not <output-sepcifier>) stty specifiers.

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(define-foreign-variable ECHOPRT unsigned-long)
156(define-foreign-variable ECHOCTL unsigned-long)
157(define-foreign-variable ISIG unsigned-long)
158(define-foreign-variable ICANON unsigned-long)
159;; (define-foreign-variable ALTWERASE unsigned-long)
160(define-foreign-variable IEXTEN unsigned-long)
161;; (define-foreign-variable EXTPROC unsigned-long)
162(define-foreign-variable TOSTOP unsigned-long)
163(define-foreign-variable FLUSHO unsigned-long)
164;; (define-foreign-variable NOKERNINFO unsigned-long)
165(define-foreign-variable PENDIN unsigned-long)
166(define-foreign-variable NOFLSH unsigned-long)
167
168(define-foreign-variable VEOF unsigned-long)
169(define-foreign-variable VEOL unsigned-long)
170(define-foreign-variable VEOL2 unsigned-long)
171(define-foreign-variable VERASE unsigned-long)
172;; (define-foreign-variable VERASE2 unsigned-long)
173(define-foreign-variable VWERASE unsigned-long)
174(define-foreign-variable VINTR unsigned-long)
175(define-foreign-variable VKILL unsigned-long)
176(define-foreign-variable VQUIT unsigned-long)
177(define-foreign-variable VSUSP unsigned-long)
178(define-foreign-variable VSTART unsigned-long)
179(define-foreign-variable VSTOP unsigned-long)
180;; (define-foreign-variable VDSUSP unsigned-long)
181(define-foreign-variable VLNEXT unsigned-long)
182(define-foreign-variable VREPRINT unsigned-long)
183(define-foreign-variable VSTATUS unsigned-long)
184
185;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
186;; basic interface
187
188(define get-term-attrs
189  (foreign-lambda* int ((int fd) (c-pointer t))
190    "return(tcgetattr(fd, (struct termios*) t));"))
191
192(define (get-terminal-attributes port . o)
193  (let* ((t (if (pair? o) (car o) (make-term-attrs)))
194         (fd (if (port? port) (port->fileno port) port))
195         (ok? (zero? (get-term-attrs fd t))))
196    ;; free and return #f on failure
197    (if (and (not ok?) (null? o))
198        (free-term-attrs t))
199    (and ok? t)))
200
201(define set-term-attrs!
202  (foreign-lambda* int ((int fd) (int action) (c-pointer t))
203    "return(tcsetattr(fd, action, (struct termios*) t));"))
204
205(define (set-terminal-attributes! port action t)
206  (set-term-attrs! (if (port? port) (port->fileno port) port) action t))
207
208;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
209;; symbolic representation of attributes
210
211(define stty-lookup (make-hash-table eq?))
212
213(for-each
214 (lambda (c)
215   (let ((type (cadr c))
216         (value (caddr c)))
217     (hash-table-set! stty-lookup (car c) (cdr c))))
218
219 ;; ripped from the stty man page, then trimmed down to what seemed
220 ;; available on most systems
221
222 `(;; characters
223;;    (dsusp    char     ,VDSUSP)   ; CHAR will send a terminal stop signal
224   (eof      char     ,VEOF)     ; CHAR will send an EOF (terminate input)
225   (eol      char     ,VEOL)     ; CHAR will end the line
226   (eol2     char     ,VEOL2)    ; alternate CHAR for ending the line
227   (erase    char     ,VERASE)   ; CHAR will erase the last character typed
228   (intr     char     ,VINTR)    ; CHAR will send an interrupt signal
229   (kill     char     ,VKILL)    ; CHAR will erase the current line
230   (lnext    char     ,VLNEXT)   ; CHAR will enter the next character quoted
231   (quit     char     ,VQUIT)    ; CHAR will send a quit signal
232   (rprnt    char     ,VREPRINT) ; CHAR will redraw the current line
233   (start    char     ,VSTART)   ; CHAR will restart output after stopping it
234   (stop     char     ,VSTOP)    ; CHAR will stop the output
235   (susp     char     ,VSUSP)    ; CHAR will send a terminal stop signal
236   (werase   char     ,VWERASE)  ; CHAR will erase the last word typed
237
238   ;; special settings
239   (cols     special  #f) ; tell the kernel that the terminal has N columns
240   (columns  special  #f) ; same as cols N
241   (ispeed   special  #f) ; set the input speed to N
242   (line     special  #f) ; use line discipline N
243   (min      special  #f) ; with -icanon, set N characters minimum for a completed read
244   (ospeed   special  #f) ; set the output speed to N
245   (rows     special  #f) ; tell the kernel that the terminal has N rows
246   (size     special  #f) ; print the number of rows and columns according to the kernel
247   (speed    special  #f) ; print the terminal speed
248   (time     special  #f) ; with -icanon, set read timeout of N tenths of a second
249
250   ;; control settings
251   (clocal   control  ,CLOCAL)  ; disable modem control signals
252   (cread    control  ,CREAD)   ; allow input to be received
253   (crtscts  control  ,CRTSCTS) ; enable RTS/CTS handshaking
254   (cs5      control  ,CS5)     ; set character size to 5 bits
255   (cs6      control  ,CS6)     ; set character size to 6 bits
256   (cs7      control  ,CS7)     ; set character size to 7 bits
257   (cs8      control  ,CS8)     ; set character size to 8 bits
258   (cstopb   control  ,CSTOPB)  ; use two stop bits per character (one with `-')
259   (hup      control  ,HUPCL)   ; send a hangup signal when the last process closes the tty
260   (hupcl    control  ,HUPCL)   ; same as [-]hup
261   (parenb   control  ,PARENB)  ; generate parity bit in output and expect parity bit in input
262   (parodd   control  ,PARODD)  ; set odd parity (even with `-')
263
264   ;; input settings
265   (brkint   input    ,BRKINT)  ; breaks cause an interrupt signal
266   (icrnl    input    ,ICRNL)   ; translate carriage return to newline
267   (ignbrk   input    ,IGNBRK)  ; ignore break characters
268   (igncr    input    ,IGNCR)   ; ignore carriage return
269   (ignpar   input    ,IGNPAR)  ; ignore characters with parity errors
270   (imaxbel  input    ,IMAXBEL) ; * beep and do not flush a full input buffer on a character
271   (inlcr    input    ,INLCR)   ; translate newline to carriage return
272   (inpck    input    ,INPCK)   ; enable input parity checking
273   (istrip   input    ,ISTRIP)  ; clear high (8th) bit of input characters
274;;    (iuclc    input    ,IUCLC)   ; * translate uppercase characters to lowercase
275   (ixany    input    ,IXANY)   ; * let any character restart output, not only start character
276   (ixoff    input    ,IXOFF)   ; enable sending of start/stop characters
277   (ixon     input    ,IXON)    ; enable XON/XOFF flow control
278   (parmrk   input    ,PARMRK)  ; mark parity errors (with a 255-0-character sequence)
279   (tandem   input    ,IXOFF)   ; same as [-]ixoff
280
281   ;; output settings
282;;    (bs0      output   ,BS0) ; backspace delay style, N in [0..1]
283;;    (bs1      output   ,BS1) ; backspace delay style, N in [0..1]
284;;    (cr0      output   ,CR0) ; carriage return delay style, N in [0..3]
285;;    (cr1      output   ,CR1) ; carriage return delay style, N in [0..3]
286;;    (cr2      output   ,CR2) ; carriage return delay style, N in [0..3]
287;;    (cr3      output   ,CR3) ; carriage return delay style, N in [0..3]
288;;    (ff0      output   ,FF0) ; form feed delay style, N in [0..1]
289;;    (ff1      output   ,FF1) ; form feed delay style, N in [0..1]
290;;    (nl0      output   ,NL0) ; newline delay style, N in [0..1]
291;;    (nl1      output   ,NL1) ; newline delay style, N in [0..1]
292   (ocrnl    output   ,OCRNL) ; translate carriage return to newline
293;;    (ofdel    output   ,OFDEL) ; use delete characters for fill instead of null characters
294;;    (ofill    output   ,OFILL) ; use fill (padding) characters instead of timing for delays
295;;    (olcuc    output   ,OLCUC) ; translate lowercase characters to uppercase
296   (onlcr    output   ,ONLCR) ; translate newline to carriage return-newline
297   (onlret   output   ,ONLRET) ; newline performs a carriage return
298   (onocr    output   ,ONOCR) ; do not print carriage returns in the first column
299   (opost    output   ,OPOST) ; postprocess output
300   (tab0     output   #f) ; horizontal tab delay style, N in [0..3]
301   (tab1     output   #f) ; horizontal tab delay style, N in [0..3]
302   (tab2     output   #f) ; horizontal tab delay style, N in [0..3]
303   (tab3     output   #f) ; horizontal tab delay style, N in [0..3]
304   (tabs     output   #f) ; same as tab0
305   ;;(-tabs    output   #f) ; same as tab3
306;;    (vt0      output   ,VT0) ; vertical tab delay style, N in [0..1]
307;;    (vt1      output   ,VT1) ; vertical tab delay style, N in [0..1]
308
309   ;; local settings
310   (crterase local    ,ECHOE)   ; echo erase characters as backspace-space-backspace
311   (crtkill  local    ,ECHOKE)  ; kill all line by obeying the echoprt and echoe settings
312   ;;(-crtkill local    #f) ; kill all line by obeying the echoctl and echok settings
313   (ctlecho  local    ,ECHOCTL) ; echo control characters in hat notation (`^c')
314   (echo     local    ,ECHO)    ; echo input characters
315   (echoctl  local    ,ECHOCTL) ; same as [-]ctlecho
316   (echoe    local    ,ECHOE)   ; same as [-]crterase
317;;    (echok    local    ,ECHOK)   ; echo a newline after a kill character
318   (echoke   local    ,ECHOKE)  ; same as [-]crtkill
319   (echonl   local    ,ECHONL)  ; echo newline even if not echoing other characters
320   (echoprt  local    ,ECHOPRT) ; echo erased characters backward, between `\' and '/'
321   (icanon   local    ,ICANON)  ; enable erase, kill, werase, and rprnt special characters
322;;   (iexten   local    ,IEXTEN)  ; enable non-POSIX special characters
323   (isig     local    ,ISIG)    ; enable interrupt, quit, and suspend special characters
324   (noflsh   local    ,NOFLSH)  ; disable flushing after interrupt and quit special characters
325   (prterase local    ,ECHOPRT) ; same as [-]echoprt
326   (tostop   local    ,TOSTOP)  ; stop background jobs that try to write to the terminal
327;;    (xcase    local    ,XCASE)   ; with icanon, escape with `\' for uppercase characters
328
329   ;; combination settings
330   (LCASE    combine  (lcase))
331   (cbreak   combine  (not icanon))
332   (cooked   combine  (brkint ignpar istrip icrnl ixon opost isig icanon))
333                                        ; also eof and eol characters
334                                        ; to their default values
335   (crt      combine  (echoe echoctl echoke))
336   (dec      combine  (echoe echoctl echoke (not ixany)))
337                                        ; also intr ^c erase 0177 kill ^u
338   (decctlq  combine  (ixany))
339   (ek       combine  ()) ; erase and kill characters to their default values
340   (evenp    combine  (parenb (not parodd) cs7))
341   ;;(-evenp combine  #f) ; same as -parenb cs8
342   (lcase    combine  (xcase iuclc olcuc))
343   (litout   combine  (cs8 (not parenb istrip opost)))
344   ;;(-litout  combine  #f) ; same as parenb istrip opost cs7
345   (nl       combine  (not icrnl onlcr))
346   ;;(-nl      combine  #f) ; same as icrnl -inlcr -igncr onlcr -ocrnl -onlret
347   (oddp     combine  (parenb parodd cs7))
348   (parity   combine  (evenp)) ; same as [-]evenp
349   (pass8    combine  (cs8 (not parenb istrip)))
350   ;;(-pass8   combine  #f) ; same as parenb istrip cs7
351   (raw      combine  (not ignbrk brkint ignpar parmrk
352                           inpck istrip inlcr igncr icrnl))
353   (ixon     combine  (ixoff ixany imaxbel opost isig icanon)) ;; xcase iuclc
354   ;;(time     combine  #f) ; 0
355   ;;(-raw     combine  #f) ; same as cooked
356   (sane     combine  (cread brkint icrnl imaxbel opost onlcr
357                       isig icanon ;; nl0 cr0 bs0 vt0 ff0 ; tab0
358                       echo echoe echoctl echoke ;; iexten echok
359                       (not ignbrk igncr ixoff ixany inlcr ;; iuclc
360                            ocrnl onocr onlret ;; olcuc ofill ofdel
361                            echonl noflsh tostop echoprt))) ;; xcase
362                                        ; plus all special characters to
363                                        ; their default values
364   ))
365
366;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
367;; high-level interface
368
369(define (stty . args)
370
371  (let* ((port (if (and (pair? args) (port? (car args)))
372                   (car args)
373                   (current-input-port)))
374         (attr (get-terminal-attributes port))
375         (iflag (term-attrs-iflag attr))
376         (oflag (term-attrs-oflag attr))
377         (cflag (term-attrs-cflag attr))
378         (lflag (term-attrs-lflag attr)))
379
380    ;; parse change requests
381    (let lp ((lst (if (and (pair? args) (port? (car args))) (cdr args) args))
382             (flag #t))
383      (cond
384       ((pair? lst)
385        (let ((command (car lst)))
386          (cond
387           ((pair? command) ;; recurse on sub-expr
388            (lp command flag)
389            (lp (cdr lst) flag))
390           ((eq? command 'not) ;; toggle current setting
391            (lp (cdr lst) (not flag)))
392           (else
393            (let* ((x (hash-table-ref/default stty-lookup command #f))
394                   (type (if (pair? x) (car x) #f)))
395              (case type
396                ((input)
397                 (if flag
398                     (set! iflag (bitwise-ior iflag (cadr x)))
399                     (set! iflag (bitwise-and iflag (bitwise-not (cadr x)))))
400                 (lp (cdr lst) flag))
401                ((output)
402                 (if flag
403                     (set! oflag (bitwise-ior oflag (cadr x)))
404                     (set! oflag (bitwise-and oflag (bitwise-not (cadr x)))))
405                 (lp (cdr lst) flag))
406                ((control)
407                 (if flag
408                     (set! cflag (bitwise-ior cflag (cadr x)))
409                     (set! cflag (bitwise-and cflag (bitwise-not (cadr x)))))
410                 (lp (cdr lst) flag))
411                ((local)
412                 (if flag
413                     (set! lflag (bitwise-ior lflag (cadr x)))
414                     (set! lflag (bitwise-and lflag (bitwise-not (cadr x)))))
415                 (lp (cdr lst) flag))
416                ((special)
417                 (error "special settings not yet supported"))
418                ((char)
419                 (term-attrs-cc-set! attr (cadr x) (or (cadr lst) 0))
420                 (lp (cddr lst) flag))
421                ((combine) ;; recurse on def of this command
422                 (lp (cadr x) flag)
423                 (lp (cdr lst) flag))
424                (else
425                 (warning "unknown stty command" command)
426                 (lp (cdr lst) flag))))))))))
427
428    ;; set new values
429    (term-attrs-iflag-set! attr iflag)
430    (term-attrs-oflag-set! attr oflag)
431    (term-attrs-cflag-set! attr cflag)
432    (term-attrs-lflag-set! attr lflag)
433    (set-terminal-attributes! port TCSANOW attr)
434    (free-term-attrs attr)))
435
436(define (with-stty setting thunk)
437  (let* ((port (current-input-port))
438         (orig-attrs (get-terminal-attributes port)))
439    (dynamic-wind
440        (lambda ()
441          (stty setting))
442        thunk
443        (lambda ()
444          (set-terminal-attributes! port TCSANOW orig-attrs)
445          (free-term-attrs orig-attrs)))))
446
447)
Note: See TracBrowser for help on using the repository browser.