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 -- andy...@ashurst.eu.org 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 Chicken-users@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-users