Hi,
>> * substring/shared is the same as substring in CHICKEN, AFAIK.
>
> That's only called once in the corner cases so it doesn't really matter
> if it wastes a copy. It's just there to stop junk in the tail of the
> buffer being sent to the user.
Attached is new version of my patch which avoids the use of
substring/shared.
Below is a diff between the code with my previous patch and the code
with this new patch.
-----
diff -upr v1.6.4-andyjpb-fix/openssl.scm v1.6.4-andyjpb-fix-2/openssl.scm
--- v1.6.4-andyjpb-fix/openssl.scm 2014-11-23 02:31:54.004264327 +0000
+++ v1.6.4-andyjpb-fix-2/openssl.scm 2014-11-23 13:10:43.801483458 +0000
@@ -446,9 +446,9 @@ EOF
(outbuf (and outbufmax (fx> outbufmax 0) (make-string
outbufmax)))
(outbufsize 0)
(unbuffered-write
- (lambda (buffer)
- (when (> (##sys#size buffer) 0) ; Undefined behaviour
for 0 bytes!
- (let loop ((offset 0) (size (##sys#size buffer)))
+ (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))
@@ -484,7 +484,7 @@ EOF
(when (startup #t)
(if outbuf
(begin
- (unbuffered-write (substring/shared outbuf 0 outbufsize))
+ (unbuffered-write outbuf 0 outbufsize)
(set! outbufsize 0)))
(set! out-open? #f)
(shutdown)))
@@ -492,7 +492,7 @@ EOF
(lambda ()
(when outbuf
(startup)
- (unbuffered-write (substring/shared outbuf 0 outbufsize))
+ (unbuffered-write outbuf 0 outbufsize)
(set! outbufsize 0)))))))
(##sys#setslot in 3 "(ssl)")
(##sys#setslot out 3 "(ssl)")
-----
Regards,
@ndy
--
[email protected]
http://www.ashurst.eu.org/
0x7EBA75FF
diff -upr v1.6.4/openssl.scm v1.6.4-andyjpb-fix-2/openssl.scm
--- v1.6.4/openssl.scm 2014-11-23 00:07:52.324097414 +0000
+++ v1.6.4-andyjpb-fix-2/openssl.scm 2014-11-23 13:10:43.801483458 +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,58 @@ 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 "")))
+ (begin
+ (unbuffered-write outbuf 0 outbufsize)
+ (set! outbufsize 0)))
(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
[email protected]
https://lists.nongnu.org/mailman/listinfo/chicken-users
