diff --git a/scsh/pty.scm b/scsh/pty.scm new file mode 100644 index 0000000..2953bfd --- /dev/null +++ b/scsh/pty.scm @@ -0,0 +1,104 @@ +;;; Pseudo terminals +;;; Copyright (c) 1995 by Olin Shivers. + +;;; (fork-job/pty thunk) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Fork the process with stdio (fd's 0, 1, & 2 and also the current i/o ports) +;;; bound to a tty device. In the parent process, returns four values: +;;; [process pty-inport pty-outport ttyname] +;;; - PROCESS is a process object for the child. +;;; - PTY-{IN,OUT}PORT are input and output ports open on the controlling pty +;;; device. PTY-OUTPORT is unbuffered. +;;; - TTYNAME is the name of the child's tty, e.g. "/dev/ttyk4". +;;; +;;; The subprocess is placed in its own session, and the tty device +;;; becomes the control tty for the new session/process-group/process. +;;; The child runs with stio hooked up to the tty; the (error-output-port) +;;; port is unbuffered. + +(define (fork-job/pty thunk) + (receive (pty-in ttyname) (open-pty) + (let* ((process (fork (lambda () + (become-session-leader) + (let ((tty (open-control-tty ttyname + open/read+write))) + (move->fdes tty 0) + (dup->outport tty 1) + (set-port-buffering (dup->outport tty 2) + bufpol/none)) + + ;; No good -- leaves old ones around: + (stdio->stdports thunk)))) + (pty-out (dup->outport pty-in))) + + (set-port-buffering pty-out bufpol/none) + (values process pty-in pty-out ttyname)))) + +;;; (open-pty) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Returns two values: [pty-inport ttyname] +;;; PTY-PORT is a port open on the pty. +;;; TTYNAME is the name of the tty, e.g., "/dev/ttyk4" +;;; +;;; Scheme doesn't allow bidirectional ports, so the returned port +;;; is an input port -- however, the underlying file descriptor is +;;; opened read+write, and you can use DUP->OUTPORT to map it to +;;; corresponding output ports. + +(define (open-pty) + (let ((next-pty (make-pty-generator))) + (let loop () + (cond ((next-pty) => + (lambda (pty-name) + (cond ((with-errno-handler ((errno packet) (else #f)) + (open-file pty-name open/read+write)) => + (lambda (pty) ; Score! + (values pty (pty-name->tty-name pty-name)))) + + (else (loop))))) ; Open failed; try another pty. + + (else (error "open-pty: could not open new pty")))))) + +;;; The following code may in fact be system dependent. +;;; If so, we'll move it out to the architecture specific directories. + +;;; Map between corresponding pty and tty filenames. + +(define (pty/tty-name-mapper char) + (lambda (name) + (let ((ans (string-copy name))) + (string-set! ans 5 char) ; Change X in "/dev/Xtyzz" to CHAR. + ans))) + +(define pty-name->tty-name (pty/tty-name-mapper #\t)) ;/dev/ttyk3 -> /dev/ptyk3 +(define tty-name->pty-name (pty/tty-name-mapper #\p)) ;/dev/ptyk3 -> /dev/ttyk3 + + +;;; Generator for the set of possible pty names. + +(define (make-pty-generator) + (let* ((pattern (string-copy"/dev/ptyLN")) ; L=letter N=number + (l-pos 8) + (n-pos 9) + +; (letters "pqrstuvwxyzPQRST") ; From telnetd source in BSD4.4. +; (numbers "0123456789abcdef") + (letters "pq") ; From telnetd source in BSD4.4. + (numbers "0123456789abcdef") + (num-letters (string-length letters)) + (num-numbers (string-length numbers)) + + (l num-letters) ; Generator's state vars. The value + (n 0)) ; of the last elt that was generated. + ; (We count backwards to (0,0); n fastest.) + (lambda () + (call-with-current-continuation + (lambda (abort) + (if (zero? n) + (if (zero? l) (abort #f) ; No more. + (begin (set! l (- l 1)) + (set! n (- num-numbers 1)) + (string-set! pattern l-pos (string-ref letters l)))) + (set! n (- n 1))) + (string-set! pattern n-pos (string-ref numbers n)) + (string-copy pattern))))))