On 23/11/14 18:38, Florian Zumbiehl wrote: > Hi, > >> ;; close >> (lambda () >> (when (startup #t) >> (if outbuf >> - (begin >> - (output outbuf) >> - (set! outbuf ""))) >> + (begin >> + (unbuffered-write outbuf 0 outbufsize) >> + (set! outbufsize 0))) >> (set! out-open? #f) >> (shutdown))) > > AFAICS, this makes it impossible to close the file descriptors behind ports > where the remote end has closed the connection while there is still data > queued for transmission.
Find a new version of the patch attached. This is version (3) and is against v1.6.4. A diff against versiion (2) is here: ----- diff -upr v1.6.4-andyjpb-fix-2/openssl.scm v1.6.4-andyjpb-fix-3/openssl.scm --- v1.6.4-andyjpb-fix-2/openssl.scm 2014-11-23 13:10:43.801483458 +0000 +++ v1.6.4-andyjpb-fix-3/openssl.scm 2014-11-25 15:53:35.035152667 +0000 @@ -481,13 +481,17 @@ EOF (unbuffered-write buffer))) ;; close (lambda () - (when (startup #t) - (if outbuf - (begin - (unbuffered-write outbuf 0 outbufsize) - (set! outbufsize 0))) - (set! out-open? #f) - (shutdown))) + (dynamic-wind + void + (lambda () + (when (startup #t) + (if outbuf + (begin + (unbuffered-write outbuf 0 outbufsize) + (set! outbufsize 0))))) + (lambda () + (set! out-open? #f) + (shutdown)))) ;; flush (lambda () (when outbuf ----- Regards, @ndy -- andy...@ashurst.eu.org http://www.ashurst.eu.org/ 0x7EBA75FF
diff -upr v1.6.4/openssl.scm v1.6.4-andyjpb-fix-3/openssl.scm --- v1.6.4/openssl.scm 2014-11-23 00:07:52.324097414 +0000 +++ v1.6.4-andyjpb-fix-3/openssl.scm 2014-11-25 15:53:35.035152667 +0000 @@ -45,7 +45,7 @@ ##sys#check-string ##sys#expand-home-path)) -(use srfi-18 tcp) +(use srfi-13 srfi-18 tcp) #> #include <errno.h> @@ -442,43 +442,62 @@ EOF "SSL read timed out"))) buffer)))) (out - (let* ((outbufsize (tcp-buffer-size)) - (outbuf (and outbufsize (fx> outbufsize 0) "")) - (output - (lambda (buffer) - (startup) - (when (> (##sys#size buffer) 0) ; Undefined behaviour for 0 bytes! - (let loop ((offset 0) (size (##sys#size buffer))) + (let* ((outbufmax (tcp-buffer-size)) + (outbuf (and outbufmax (fx> outbufmax 0) (make-string outbufmax))) + (outbufsize 0) + (unbuffered-write + (lambda (buffer #!optional (offset 0) (size (##sys#size buffer))) + (when (> size 0) ; Undefined behaviour for 0 bytes! + (let loop ((offset offset) (size size)) (let ((ret (ssl-call/timeout 'ssl-write (lambda () (ssl-write ssl buffer offset size)) fd (tcp-write-timeout) "SSL write timed out"))) (when (fx< ret size) ; Partial write (loop (fx+ offset ret) (fx- size ret))))))))) + + (define (buffered-write data #!optional (start 0)) + (let* ((size (- (##sys#size data) start)) + (to-copy (min (- outbufmax outbufsize) size)) + (left-over (- size to-copy))) + + (string-copy! outbuf outbufsize data start (+ start to-copy)) + (set! outbufsize (+ outbufsize to-copy)) + + (if (= outbufsize outbufmax) + (begin + (unbuffered-write outbuf) + (set! outbufsize 0))) + + (if (> left-over 0) + (buffered-write data (+ start to-copy))))) + (make-output-port ;; write (lambda (buffer) + (startup) (if outbuf - (begin - (set! outbuf (string-append outbuf buffer)) - (when (fx>= (string-length outbuf) outbufsize) - (output outbuf) - (set! outbuf ""))) - (output buffer))) + (buffered-write buffer) + (unbuffered-write buffer))) ;; close (lambda () - (when (startup #t) - (if outbuf - (begin - (output outbuf) - (set! outbuf ""))) - (set! out-open? #f) - (shutdown))) + (dynamic-wind + void + (lambda () + (when (startup #t) + (if outbuf + (begin + (unbuffered-write outbuf 0 outbufsize) + (set! outbufsize 0))))) + (lambda () + (set! out-open? #f) + (shutdown)))) ;; flush (lambda () (when outbuf - (output outbuf) - (set! outbuf ""))))))) + (startup) + (unbuffered-write outbuf 0 outbufsize) + (set! outbufsize 0))))))) (##sys#setslot in 3 "(ssl)") (##sys#setslot out 3 "(ssl)") ;; first "reserved" slot
_______________________________________________ Chicken-users mailing list Chicken-users@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-users