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
