source: project/release/3/stty/trunk/stty.scm @ 9985

Last change on this file since 9985 was 9985, checked in by Kon Lovett, 12 years ago

Using canonical directory structure.

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