;;; output-buffer: wrap an output-port in a buffer.
;;; can be used to optimize outbound network traffic.
;;; Graham Fawcett, Thomas Chust.

(define (output-buffer target-port #!optional (buffer-size 1500))
  (unless (output-port? target-port)
    (error 'output-buffer "not an output port!"))
  (let* ((buf (make-string buffer-size))
         (buffer-pos 0))
    (define (write-buffered s)
      (let ((len (string-length s)))
        (if (>= (+ buffer-pos len) buffer-size) ; too big for buffer?
            ;; write the buffer, then s.
            (begin (flush-buffer)
                   (write-string s #f target-port))
            ;; else, buffer s.
            (begin (substring-set! buf s buffer-pos) 
                   (set! buffer-pos (+ buffer-pos len))))))
    (define (flush-buffer)
      (when (> buffer-pos 0)
        (write-string (substring buf 0 buffer-pos) #f target-port)
        (set! buffer-pos 0))
      (flush-output target-port))
    (define (close-buffer)
      (flush-buffer)
      (close-output-port target-port)   ; seems the right thing to do.
      (set! buf #f))
    (make-output-port write-buffered close-buffer flush-buffer)))


;;; substring-set! -- an interpreted and a much faster compiled version.

#+ csi
(define (substring-set! buffer replace start #!optional (count #f))
  (let ((buffer-size (string-length buffer))
        (replace-len (string-length replace)))
    (let loop ((current 0))
      (let ((buffer-pos (+ current start)))
        (when (and (< current replace-len)
                   (< buffer-pos buffer-size)
                   (if count (< current count) #t))
          (string-set! buffer buffer-pos (string-ref replace current))
          (loop (add1 current)))))))

; from Thomas Chust
#+ (not csi)
(define (substring-set! buffer replace
                        #!optional (start 0)
                        (count (string-length replace)))
  (if (or (< start 0)
          (< count 0)
          (> start (string-length buffer))
          (> count (string-length replace))
          (> count (- (string-length buffer) start)))
      (error 'substring-set!
             "start and/or count parameters have bad values"
             buffer replace start count))
  ((foreign-lambda* void ((scheme-pointer buffer)
                          (scheme-pointer replace)
                          (integer start) (integer count))
                    "memmove(buffer + start, replace, count);")
   buffer replace start count))