thread-aware FD ports pasted by DerGuteMoritz on Wed Oct 24 20:56:39 2012
(define (open-input-fd fd) (make-input-port (lambda () (thread-wait-for-i/o! fd #:input) (string-ref (car (file-read fd 1)) 0)) (lambda () (nth-value 0 (file-select fd #f 0))) (lambda () (file-close fd)))) (define (open-output-fd fd) (let ((port (open-output-file* fd))) (make-output-port (lambda (buffer) (let loop ((buffer buffer) (len (string-length buffer))) (thread-wait-for-i/o! fd #:output) (let ((written (file-write fd buffer))) (unless (= written len) (loop (substring written len) (- len written)))))) (lambda () (close-output-port port)) (lambda () (flush-output port)))))
fixed open-file-fd pasted by DerGuteMoritz on Wed Oct 24 21:00:45 2012
(define (open-output-fd fd)
(let ((port (open-output-file* fd)))
(make-output-port
(lambda (buffer)
(let loop ((buffer buffer) (len (string-length buffer)))
(thread-wait-for-i/o! fd #:output)
(let ((written (file-write fd buffer)))
(unless (= written len)
(loop (substring buffer written len) (- len written))))))
(lambda ()
(close-output-port port))
(lambda ()
(flush-output port)))))
open-output-fd with error handling pasted by DerGuteMoritz on Wed Oct 24 21:18:55 2012
(define (open-output-fd fd)
(let ((port (open-output-file* fd)))
(make-output-port
(lambda (buffer)
(let loop ((buffer buffer) (len (string-length buffer)))
(thread-wait-for-i/o! fd #:output)
(let ((written (file-write fd buffer)))
(if (negative? written)
(case (errno)
((errno/intr errno/again)
(loop buffer len))
(else (error "Error writing to fd" fd (errno))))
(unless (= written len)
(loop (substring buffer written len) (- len written)))))))
(lambda ()
(close-output-port port))
(lambda ()
(flush-output port)))))
possibly really handling errors this time pasted by DerGuteMoritz on Wed Oct 24 21:27:21 2012
(define (open-output-fd fd)
(let ((port (open-output-file* fd)))
(make-output-port
(lambda (buffer)
(let loop ((buffer buffer) (len (string-length buffer)))
(thread-wait-for-i/o! fd #:output)
(let ((written (file-write fd buffer)))
(if (negative? written)
(select (errno)
((errno/intr errno/again)
(loop buffer len))
(else (error "Error writing to fd" fd (errno))))
(unless (= written len)
(loop (substring buffer written len) (- len written)))))))
(lambda ()
(close-output-port port))
(lambda ()
(flush-output port)))))
it's starting to turn into a monster added by DerGuteMoritz on Wed Oct 24 22:38:13 2012
(define (open-input-fd fd) (make-input-port (lambda () (let loop () (thread-wait-for-i/o! fd #:input) (or (condition-case (string-ref (car (file-read fd 1)) 0) (exn (exn i/o file) (select (errno) ((errno/intr errno/again errno/wouldblock) #f) (else (signal exn))))) (loop buffer len)))) (lambda () (nth-value 0 (file-select fd #f 0))) (lambda () (file-close fd)))) (define (open-output-fd fd) (let ((port (open-output-file* fd))) (make-output-port (lambda (buffer) (let loop ((buffer buffer) (len (string-length buffer))) (thread-wait-for-i/o! fd #:output) (let ((written (condition-case (file-write fd buffer) (exn (exn i/o file) (select (errno) ((errno/intr errno/again errno/wouldblock) #f) (else (signal exn))))))) (if written (unless (= written len) (loop (substring buffer written len) (- len written))) (loop buffer len))))) (lambda () (close-output-port port)) (lambda () (flush-output port)))))