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

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

fixing errno conflict in pty

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