source: project/release/4/pty/trunk/pty.scm @ 27071

Last change on this file since 27071 was 27071, checked in by Alex Shinn, 9 years ago

need to include <termios.h> for struct winsize

File size: 9.0 KB
Line 
1;;;; pty.scm -- Easy Pseudo-Terminal Interface
2;;
3;; Copyright (c) 2006-2012 Alex Shinn. All rights reserved.
4;; BSD-style license: http://synthcode.com/license.txt
5
6(declare
7  (usual-integrations)
8  (fixnum-arithmetic)
9  (no-bound-checks)
10  (no-procedure-checks))
11
12(require-library posix)
13
14#+linux        (foreign-declare "#include <pty.h>\n")
15#+(not linux)  (foreign-declare "#include <util.h>\n")
16(foreign-declare "#include <utmp.h>\n")
17(foreign-declare "#include <fcntl.h>\n")
18(foreign-declare "#include <errno.h>\n")
19(foreign-declare "#include <termios.h>\n")
20(foreign-declare "#include <sys/types.h>\n")
21(foreign-declare "#include <sys/wait.h>\n")
22
23(module pty
24  (fcntl-ref fcntl-set! file-select-one file-read/maybe
25   open-file-io/non-blocking process-alive?
26   open-pty open-pty-process login-tty
27   with-pty-process-io call-with-pty-process-io)
28
29(import scheme chicken data-structures ports posix foreign)
30
31;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
32;; Create non-blocking ports from a general file descriptor.
33
34(define (yield)
35  (##sys#call-with-current-continuation
36   (lambda (return)
37     (let ((ct ##sys#current-thread))
38       (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
39       (##sys#schedule) ) ) ) )
40
41(define fcntl-ref
42  (foreign-lambda* int ((int fd))
43   "return(fcntl(fd, F_GETFL));"))
44
45(define fcntl-set!
46  (foreign-lambda* bool ((int fd) (int arg))
47    "int val = fcntl(fd, F_GETFL, 0);"
48    "if (val == -1) return(0);"
49    "return(fcntl(fd, F_SETFL, val | arg) != -1);") )
50
51;; Identical to ##NET#SELECT, could also be done less efficiently with
52;; FILE-SELECT from posix.
53(define file-select-one
54  (foreign-lambda* int ((int fd))
55    "fd_set in;
56     struct timeval tm;
57     int rv;
58     FD_ZERO(&in);
59     FD_SET(fd, &in);
60     tm.tv_sec = tm.tv_usec = 0;
61     rv = select(fd + 1, &in, NULL, NULL, &tm);
62     if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
63     return(rv);") )
64
65;; Alternately use FILE-READ and trap errors?
66(define file-read/maybe
67  (foreign-lambda int "read" int scheme-pointer int))
68
69(define-constant +input-buffer-size+ 1024)
70
71(define-foreign-variable error-number int "errno")
72(define-foreign-variable strerror c-string "strerror(errno)")
73
74(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
75(define-foreign-variable _eagain int "EAGAIN")
76
77(define-inline (file-error msg fd)
78  (##sys#update-errno)
79  (##sys#signal-hook #:file-error (##sys#string-append msg strerror) fd))
80
81(define (open-file-io/non-blocking fd . o)
82  (let* ((buf (make-string +input-buffer-size+))
83         (buflen 0)
84         (bufindex 0)
85         (iclosed #f)
86         (oclosed #f)
87         (more? (if (pair? o) (car o) (lambda () #t))))
88    (fcntl-set! fd open/nonblock)
89    (list
90
91     ;; INPUT
92     (make-input-port
93      (lambda () ; read-char
94        (if (>= bufindex buflen) ; clear and refill buffer
95          (let ((n (let loop ()
96                     (let ((n (file-read/maybe fd buf +input-buffer-size+)))
97                       (if (< n 1)
98                         (if (or (eq? n 0)
99                                 (eq? error-number _ewouldblock)
100                                 (eq? error-number _eagain))
101                           (if (more?)
102                             (begin
103;                                (##sys#thread-block-for-i/o!
104;                                       ##sys#current-thread fd #t)
105                               (yield)
106                               (loop))
107                             ;; no more, try to read one last time to
108                             ;; guard against race conditions
109                             (let ((n (file-read/maybe fd buf +input-buffer-size+)))
110                               (if (= n -1)
111                                 (if (or (eq? error-number _ewouldblock)
112                                         (eq? error-number _eagain))
113                                   0
114                                   (file-error "can't read from FD - " fd))
115                                 n)))
116                           (file-error "can't read from FD - " fd))
117                         n)))))
118            (cond ((zero? n)
119                   #!eof)
120                  (else
121                   (set! buflen n)
122                   (set! bufindex 1)
123                   (##core#inline "C_subchar" buf 0))))
124          (let ((c (##core#inline "C_subchar" buf bufindex)))
125            (set! bufindex (+ bufindex 1))
126            c)))
127      (lambda () ; char-ready?
128        (or (< bufindex buflen)
129            (let ((f (file-select-one fd)))
130              (when (eq? f -1)
131                (file-error "can't select from FD - " fd))
132              (eq? f 1))))
133      (lambda () ; close-input-port
134        (unless iclosed
135          (set! iclosed #t)
136          (file-close fd))))
137
138     ;; OUTPUT (simple, unbuffered)
139     (make-output-port
140      (lambda (s) 
141        (when (> (##sys#size s) 0)
142          (file-write fd s)))
143      (lambda ()
144        (unless oclosed
145          (set! oclosed #t)
146          (when (and iclosed (eq? -1 (file-close fd)))
147            (file-error "can't close FD output port - " fd))))))))
148
149(define process-alive?
150  (foreign-lambda* bool ((int pid))
151     "int status;
152      return(! waitpid(pid, &status, WNOHANG)
153               || ! (WIFEXITED(status) || WIFSIGNALED(status)));"))
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156;; Low-level utilities
157
158;; create a new pty and return the master and slave file descriptors
159(define raw-open-pty
160  (foreign-lambda* int ((c-string name) (int width) (int height))
161   "int amaster, aslave, err;
162    struct winsize ws;
163    if (width && height) {
164      ws.ws_row = width;
165      ws.ws_col = height;
166      ws.ws_xpixel = 1;
167      ws.ws_ypixel = 1;
168      err = openpty(&amaster, &aslave, name, NULL, &ws);
169    } else {
170      err = openpty(&amaster, &aslave, name, NULL, NULL);
171    }
172    if (err) {
173      return(0);
174    } else {
175      return(amaster*1024 + aslave);
176    }"))
177
178;; Friendlier open-pty which allows setting the width and height of the
179;; pty.  Consider using a keyword-based API and adding termios options.
180(define (open-pty . o)
181  (let-optionals* o ((name #f)
182                     (width 0)
183                     (height 0))
184    (let ((res (raw-open-pty name width height)))
185      (and-let* (((integer? res))
186                 ((positive? res))
187                 (master-fd (quotient res 1024))
188                 (slave-fd (remainder res 1024)))
189        (list master-fd slave-fd)))))
190
191;; Login to a tty, setting current in/out/err ports accordingly.  Used
192;; by the slave process.
193(define login-tty
194  (foreign-lambda int "login_tty" int))
195
196;; Run COMMAND as a subprocess in a new pty, and return a list of two
197;; values, the master FD of the new pty, and the slave PID.
198(define (open-pty-process command . o)
199  (let ((res (apply open-pty o))
200        (command (if (and (string? command) (substring-index " " command))
201                   (string-split command)
202                   command)))
203    (when (and (pair? res) (integer? (car res)) (integer? (cadr res)))
204      ;; run slave process
205      (let* ((master (car res))
206             (slave (cadr res))
207             (pid (process-fork
208                  (lambda ()
209                    (file-close master)
210                    (login-tty slave)
211                    (if (pair? command)
212                      (process-execute (car command) (cdr command))
213                      (process-execute command))))))
214        ;; make non-blocking
215        (fcntl-set! master open/nonblock)
216        ;; return master I/O and child PID
217        (list master pid)))))
218
219
220;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221;; High-level interface
222
223;; Call and return the result of PROC with three arguments: the input,
224;; output and PID of the sub-process COMMAND running in a new PTY.
225;; Ensures the sub-process is terminated on completion.  Any additional
226;; arguments are passed to OPEN-PTY-PROCESS.
227(define (call-with-pty-process-io command proc . o)
228  (unless (procedure? proc)
229    (error 'call-with-pty-process-io "invalid procedure" proc))
230  (let ((pty (apply open-pty-process command o)))
231    (if (and (pair? pty)
232             (integer? (car pty)) (not (negative? (car pty)))
233             (integer? (cadr pty)) (not (zero? (cadr pty))))
234      (let* ((fd (car pty))
235             (pid (cadr pty))
236             (ports (open-file-io/non-blocking
237                     fd
238                     (lambda () (process-alive? pid))))
239             (in (car ports))
240             (out (cadr ports))
241             (res (proc in out pid)))
242        (file-close fd)
243        ;; Probably a bad idea
244        ;;(if (process-alive? pid)
245        ;;  (process-signal pid))
246        res)
247      (error "couldn't open-pty-process" command o pty))))
248
249;; As above but bind to current input/output ports and only pass PROC
250;; one argument, the child PID.
251(define (with-pty-process-io command proc . o)
252  (unless (procedure? proc)
253    (error 'with-pty-process-io "invalid procedure" proc))
254  (apply call-with-pty-process-io
255         command
256         (lambda (in out pid)
257           (with-input-from-port in
258             (lambda () (with-output-to-port out (proc pid)))))
259         o))
260
261)
Note: See TracBrowser for help on using the repository browser.