chibi-scheme/lib/chibi/pty.sld

(define-library (chibi pty)
  (import (scheme base)
          (chibi filesystem)
          (chibi process)
          (chibi string)
          (chibi stty)
          (only (chibi) fileno?))
  (export open-pty fork-pty login-tty
          open-pty-process call-with-pty-process-io)
  (include-shared "pty")
  (begin
    (define (winsize-arg o)
      (cond
       ((and (pair? o) (integer? (car o)))
        (unless (and (pair? (cdr o)) (integer? (cadr o)))
          (error "open-pty expects integer width and height" o))
        (make-winsize (car o) (cadr o)))
       ((and (pair? o) (pair? (cdr o)))  (cadr o))
       (else #f)))
    (define (open-pty . o)
      (let ((termios (and (pair? o) (car o)))
            (winsize (winsize-arg (if (pair? o) (cdr o) '()))))
        (openpty termios winsize)))
    (define (fork-pty . o)
      (let ((termios (and (pair? o) (car o)))
            (winsize (winsize-arg (if (pair? o) (cdr o) '()))))
        (forkpty termios winsize)))
    (define (open-pty-process command . o)
      (let* ((command (if (and (string? command)
                               (string-find? command #\space))
                          (string-split command)
                          command))
             (pty (apply fork-pty o)))
        (cond
         ((not (and (pair? pty) (integer? (car pty))
                    (not (negative? (car pty)))
                    (pair? (cdr pty)) (fileno? (cadr pty))))
          (error "failed to fork-pty" pty))
         ((zero? (car pty))  ; child
          (execute (car command) command))
         (else               ; parent
          pty))))
    (define (call-with-pty-process-io command proc . o)
      (unless (procedure? proc)
        (error "call-with-pty-process-io expected procedure" proc))
      (let ((pty (apply open-pty-process command o)))
        (if (and (pair? pty)
                 (integer? (car pty))
                 (not (negative? (car pty)))
                 (fileno? (cadr pty)))
            (let* ((pid (car pty))
                   (fd (cadr pty))
                   (name (and (pair? (cddr pty)) (car (cddr pty))))
                   (in (open-input-file-descriptor fd))
                   (out (open-output-file-descriptor fd))
                   (res (proc pid in out name)))
              (close-input-port in)
              (close-output-port out)
              (close-file-descriptor fd)
              res)
            (error "couldn't open-pty-process" command o pty))))))