source: branches/home/psmith/restructure/src/buffer/buffer.lisp

#|
Copyright (c) 2006 Risto Laakso
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions
are met:
1. Redistributions of source code must retain the above copyright
   notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
   notice, this list of conditions and the following disclaimer in the
   documentation and/or other materials provided with the distribution.
3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|#

(in-package :nio-buffer)


;;NIO-buffers - to simplify operations on buffers.
;;
;; Will support direct(external to the vm) and non-direct buffers
;;

(declaim (optimize (debug 3) (speed 3) (space 0)))

(defclass buffer ()
  ((capacity     :initarg :capacity
                 :initform 0
                 :accessor buffer-capacity
                 :documentation "Buffer capacity")
   (limit        :initarg :limit
                 :initform 0
                 :accessor buffer-limit
                 :documentation "Index of first element the should *not* be read or written 0 <= limit <= capacity")
   (position     :initarg :position
                 :initform 0
                 :accessor buffer-position
                 :documentation "Index of next element to be read/written 0<=position<=limit")
   (mark         :initarg :position
                 :initform 0
                 :documentation "A marked position")
   (buf          :initarg :buf
                 :accessor buffer-buf)))


;;Utils by slyrus (http://paste.lisp.org/display/11149)
(defun hex-dump-byte (address)
  (format nil "~2,'0X" (byte-value address)))

(defun byte-value (address)
  (sb-alien:deref
   (sb-alien:sap-alien
    (sb-alien::int-sap address)
    (* (sb-alien:unsigned 8)))))

(defun hex-dump-memory (start-address length)
  (loop for i from start-address below (+ start-address length)
     collect (format nil (hex-dump-byte i))))

;;-- end utils

(defun get-readable-char (char-code)
  (if (<= char-code 32)
      (code-char 46)
      (if (> char-code 127)
          (code-char 46)
          (code-char char-code))))

(defun pretty-hex-dump (start-address length)
;  (format t "start: ~A length ~A~%" start-address length)
  (with-output-to-string (str)
    (let ((rows (floor (/ length 16))))
;      (format t "rows: ~A remainder ~A~%" rows remainder)
      (dotimes (row-index (+ 1 rows))
        (format str "~A~%"
                (with-output-to-string (readable)
                  (dotimes (column-index 16)
                    (let ((address (+ start-address (* row-index 16) column-index)))
                                        ;           (format t "Current address : ~A~%" address)
                      (if (>= address (+ start-address length)) 
                          (progn 
                            (format str (if (eql column-index 7) "   " ".. "))
                            (format readable "."))
                          (progn 
                            (format str (if (eql column-index 7) "~A   " "~A ") (hex-dump-byte address))
                            (format readable "~A" (get-readable-char (byte-value address)))))))))))))

(defun make-uint8-seq (size)
  "Make uint8 sequence."
  (make-sequence '(vector (unsigned-byte 8)) size :initial-element 0))

;;A buffer that deals with bytes
(defclass byte-buffer (buffer)())

(defun byte-buffer (capacity)
  (make-instance 'byte-buffer :capacity capacity :limit capacity :position 0 :buf (cffi:foreign-alloc :uint8 :count capacity)))

;Gets a pointer to the address in the native memory of the position index
(defmethod buffer-pointer ((bb byte-buffer))
  (cffi:make-pointer (+ (cffi:pointer-address (buffer-buf bb)) (buffer-position bb))))

(defmethod print-object ((byte-buffer byte-buffer) stream)
  (with-slots (capacity position limit buf) byte-buffer
    (format stream "<byte-buffer :capacity ~A :position ~A :limit ~A :buf ~%~A>~%" capacity position limit (if buf (pretty-hex-dump (cffi:pointer-address buf) limit) nil))))

(defmethod free-buffer((byte-buffer byte-buffer))
  (with-slots (capacity position limit buf) byte-buffer
    (cffi:foreign-free buf)
    (setf buf NIL)
    (setf capacity 0)
    (setf limit 0)
    (setf position 0)))

;bytes between the position and the limit
(defmethod remaining((byte-buffer byte-buffer))
  (with-slots (position limit) byte-buffer
    (- limit position)))

;bytes between the current position and capacity
(defmethod remaining-capacity((byte-buffer byte-buffer))
  (with-slots (position capacity) byte-buffer
    (- capacity position)))

(defmethod inc-position((byte-buffer byte-buffer) num-bytes)
  (with-slots (position limit) byte-buffer
    (let ((new-pos (+ position num-bytes)))
      (assert (<= new-pos limit))
      (setf position new-pos))))

(defmethod flip((byte-buffer byte-buffer))
  :documentation "make buffer ready for relative get operation"
  (with-slots (position limit) byte-buffer
    (setf limit position)
    (setf position 0)))

(defmethod unflip((byte-buffer byte-buffer))
  :documentation "make buffer ready for relative write operation. Used on partial read to reset the buffer for writing"
  (with-slots (position limit capacity) byte-buffer
    (setf position limit)
    (setf limit capacity)))

(defmethod clear((byte-buffer byte-buffer))
  :documentation "Reset the position to 0 and the limit to capacity"
  (with-slots (position limit capacity) byte-buffer
    (setf limit capacity)
    (setf position 0)
    byte-buffer))

(defmethod compact((byte-buffer byte-buffer))
  :documentation "copy remaining bytes to the beginning of this buffer and set position to number of bytes copied (ready for a new put"
  (with-slots (buf position limit capacity) byte-buffer
    (let ((remaining (remaining byte-buffer)))
      (%memcpy buf (cffi:make-pointer (+ (cffi:pointer-address buf) position)) remaining)
      (setf position remaining)
      (setf limit capacity))))

(defmethod mark((bb byte-buffer))
  :documentation "mark a position in the buffer for subsequent use with reset"
  (with-slots (position mark) bb
    (setf mark position)))

(defmethod reset((bb byte-buffer))
  (with-slots (position mark) bb
    (setf position mark)))
  


;Used to signal either an attempt has been made to write data to a buffer that is too small using a write (overflow)
; or an incomming packet doesn't have enough room to fit
(define-condition buffer-too-small-error (error) 
  ((recommended-size :initarg :recommended-size
                     :accessor recommended-size)))

(defun buffer-too-small-error(recommended-size)
  (make-instance 'buffer-too-small-error :recommended-size recommended-size))



;reads bytes from byte-buffer and returns a vector (unsigned-byte 8)
(defmethod bytebuffer-read-vector((bb byte-buffer) &optional (num-bytes-to-read (remaining bb)))
  (let ((vec  (make-uint8-seq num-bytes-to-read)))
    (with-slots (buf position) bb
      (inc-position bb (cffi:mem-read-vector vec buf :unsigned-char num-bytes-to-read position)))
    vec))

; Read bytes from bytebuffer abd return a string using the supplied decoding
;TODO move octets-to-string into nio-compat
(defmethod bytebuffer-read-string((bb byte-buffer) &optional (num-bytes-to-read (remaining bb)) (external-format :utf-8))
  (sb-ext:octets-to-string (bytebuffer-read-vector bb num-bytes-to-read) :external-format external-format))

; Read a byte from bytebuffer and return it incrementing the byte-buffers position
(defmethod bytebuffer-read-8((bb byte-buffer))
  (let ((val (cffi:mem-ref (cffi:make-pointer (+ (cffi:pointer-address (buffer-buf bb)) (buffer-position bb))) :unsigned-char )))
    (inc-position bb 1)
    val))

; Read a 32 bit integer from bytebuffer and return it incrementing the byte-buffers position
(defmethod bytebuffer-read-32((bb byte-buffer))
  (let ((val (cffi:mem-ref (cffi:make-pointer (+ (cffi:pointer-address (buffer-buf bb)) (buffer-position bb))) :unsigned-int )))
    (inc-position bb 4)
    val))

;write an 8 bit value and up date position in buffer
(defmethod bytebuffer-write-8 ((bb byte-buffer) value)
  (when (< (remaining bb) 1) (error 'buffer-too-small-error))
  (setf (cffi:mem-ref (buffer-buf bb) :unsigned-char (buffer-position bb)) value)
  (inc-position bb 1))

;write a 32 bit value and up date position in buffer
(defmethod bytebuffer-write-32 ((bb byte-buffer) value)
  (when (< (remaining bb) 4) (error 'buffer-too-small-error))
  (setf (cffi:mem-ref (buffer-buf bb) :unsigned-int (buffer-position bb)) value)
  (inc-position bb 4))

;insert an 8 bit value
(defmethod bytebuffer-insert-8 ((bb byte-buffer) value byte-position)
  (setf (cffi:mem-ref (buffer-buf bb) :unsigned-char byte-position) value))

;insert a 32 bit value
(defmethod bytebuffer-insert-32 ((bb byte-buffer) value byte-position)
  (setf (cffi:mem-ref (buffer-buf bb) :unsigned-int byte-position) value))


;; Write bytes from vector vec to bytebuffer
(defmethod bytebuffer-write-vector((bb byte-buffer) vec)
  :documentation "Returns number of bytes written to bytebuffer"
#+nio-debug    (format t "bytebuffer-write-vector - called with ~A ~A"bb vec)
    (when (< (remaining bb) (length vec)) (error 'buffer-too-small-error))
    (let ((bytes-written (cffi:mem-write-vector vec (buffer-buf bb) :unsigned-char (length vec) (buffer-position bb))))
#+nio-debug       (format t "bytebuffer-write-vector -  byteswritten: ~A~%" bytes-written)
      (inc-position bb bytes-written)
      bytes-written))


;; Writes data from string str to bytebuffer using specified encoding
;TODO move string-to-octets into nio-compat
(defmethod bytebuffer-write-string((bb byte-buffer) str &optional (external-format :utf-8))
  :documentation "Returns number of bytes written to bytebuffer"
  (bytebuffer-write-vector bb (sb-ext:string-to-octets str :external-format external-format)))



(defmethod copy-buffer ((old byte-buffer) (new byte-buffer))
  (assert (<= (buffer-capacity old) (buffer-capacity new)))
  (%memcpy (buffer-buf new) (buffer-buf old) (buffer-capacity old))
  (setf (buffer-position new) (buffer-position old))
  (setf (buffer-limit new) (buffer-capacity new)))

;void *memcpy(void *dest, const void *src, size_t n);
(cffi:defcfun ("memcpy" %memcpy) :pointer
  (dest :pointer)
  (src :pointer)
  (len :int))

;void *memset(void *s, int c, size_t n);
(cffi:defcfun ("memset" %memset) :pointer
  (buffer :pointer)
  (byte :int)
  (len :int))

(defun test-buffer()
  (let ((mybuf (byte-buffer 32)))
    (format t "Mybuf: ~A~%" mybuf)
    (assert (eql 32 (remaining mybuf)))
    (inc-position mybuf 4)
    (assert (eql 28 (remaining mybuf)))
    (format t "Mybuf: ~A~%" mybuf)

 (%memset (buffer-buf mybuf) 78 4)

    (format t "Mybuf (after memset): ~A~%" mybuf)
    (flip mybuf)
    (format t "Mybuf (after flip): ~A~%" mybuf)


    (format t "Remaining ~A~%" (remaining mybuf))

    (format t "mybuf string ~A~%" (bytebuffer-read-string mybuf))

    (format t "Mybuf (after get-string): ~A~%" mybuf)

    (let ((test-copy (byte-buffer 1024)))
      (copy-buffer mybuf test-copy)
      (format t "new copy: ~A~%" test-copy))

    (setf (buffer-position mybuf) 0)
    (format t "bytebuffer-read-32 ~X~%" (bytebuffer-read-32 mybuf))

    (format t "Mybuf (after clear): ~A~%" (clear mybuf))

    ;test accessors
    (setf (buffer-position mybuf) 11)
    (bytebuffer-write-8 mybuf 243)
    (assert (eql (buffer-position mybuf) 12))
    (setf (buffer-position mybuf) 11)
    (assert (eql (bytebuffer-read-8 mybuf) 243))
    (format t "Mybuf (after r/w 8bit): ~A~%" mybuf)

    (setf (buffer-position mybuf) 11)
    (bytebuffer-write-32 mybuf 2147483649)
    (assert (eql (buffer-position mybuf) 15))
    (setf (buffer-position mybuf) 11)
    (assert (eql (bytebuffer-read-32 mybuf) 2147483649))
    (format t "Mybuf (after r/w 32bit): ~A~%" mybuf)

    (setf (buffer-position mybuf) 11)

    (compact mybuf)
    (format t "Mybuf (after compact): ~A~%" mybuf)
    (assert (eql (buffer-position mybuf) (- 32 11)))
    (flip mybuf)
    (format t "Mybuf (flip): ~A~%" mybuf)
    (assert (eql (bytebuffer-read-32 mybuf) 2147483649))

    (free-buffer mybuf)
    (format t "Mybuf after free: ~A~%" mybuf)))