#lang scheme
(require
 scheme/foreign)

(unsafe!)

(define strerror
  (get-ffi-obj
   "strerror" #f
   (_fun [errno : _int] -> [desc : _string])))

(define dup2
  (get-ffi-obj
   "dup2" #f
   (_fun #:save-errno 'posix
         [from : _int] [to : _int]
         -> [ok : _int]
         -> (when (negative? ok)
              (let ([errno (saved-errno)])
                (error 'dup2 "~a (~v)" (strerror errno) errno))))))

(define pipe
  (get-ffi-obj
   "pipe" #f
   (_fun #:save-errno 'posix
         [fds : (_ptr o (_list-struct _int _int))]
         -> [ok : _int]
         -> (if (not (negative? ok))
                (apply values fds)
                (let ([errno (saved-errno)])
                  (error 'pipe "~a (~v)" (strerror errno) errno))))))

(define make-fd-input-port
  (get-ffi-obj
   "scheme_make_fd_input_port" #f
   (_fun [fd : _int] [name : _scheme] [regular-file? : _bool] [win-textmode? : _bool]
         -> [port : _scheme])))

(define (capture-stdout!)
  (let-values ([(fd-in fd-out) (pipe)])
    (dup2 fd-out 1)
    (make-fd-input-port fd-in 'stdout #f #t)))

(define (redirect-stdout! [out (current-output-port)])
  (let ([in (capture-stdout!)])
    (thread (λ () (copy-port in out)))
    (void)))

(define puts
  (get-ffi-obj
   "puts" #f
   (_fun #:save-errno 'posix
         [msg : _string]
         -> [ok : _int]
         -> (when (negative? ok)
              (let ([errno (saved-errno)])
                (error 'puts "~a (~v)" (strerror errno) errno))))))

(provide
 capture-stdout!
 redirect-stdout!
 puts)