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

#|
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")
   (buf          :initarg :buf
                 :accessor buffer-buf)))


;;Utils by slyrus (http://paste.lisp.org/display/11149)
(defun hex-dump-byte (address)
  (format nil "~2,'0X"
          (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))))


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


;;-- end utils


;;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 (foreign-alloc :uint8 :count capacity)))


(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 (hex-dump-memory (pointer-address buf) limit) nil))))

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


(defmethod remaining((byte-buffer byte-buffer))
  (with-slots (position limit) byte-buffer
    (- limit 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 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 get-string((byte-buffer byte-buffer))
  (flip byte-buffer)
  (with-slots (position limit buf) byte-buffer
    (let ((tmp  (make-uint8-seq (remaining byte-buffer))))
      (inc-position byte-buffer (cffi:mem-read-vector tmp buf :unsigned-char limit))
      (format t " read: ~A~%" (sb-ext:octets-to-string tmp :external-format :ascii))
      tmp)))
    
;;TODO 
;;mem-write-vector (vector ptr type &optional (count (length vector)) (offset 0))
(defmethod bytebuffer-write-string((byte-buffer byte-buffer) str &optional (index 0) (external-format :ascii))
  :documentation "Returns number of bytes written to bytebuffer"
  (bytebuffer-write-vector byte-buffer (sb-ext:string-to-octets str :external-format external-format)))

;;TODO rename
(defmethod bytebuffer-write-vector((byte-buffer byte-buffer) vec &optional (index 0))
  :documentation "Returns number of bytes written to bytebuffer"
  (if (> (remaining byte-buffer) 0)
      0
      (progn    
        (clear byte-buffer)
        (let ((bytes-written (mem-write-vector vec (buffer-buf byte-buffer) :unsigned-char)))
          (format t "bytebuffer-write-vector -  byteswritten: ~A" bytes-written)
          (inc-position byte-buffer bytes-written)
          bytes-written))))


(defmethod map-to-foreign ((byte-buffer byte-buffer) seq &optional (start 0) (end (length seq)))
  "Map SEQ to foreign array."
  (clear byte-buffer)
  (let* ((len (- end start)))
    (loop for i from 0 below len do
         (setf (mem-aref (buffer-buf byte-buffer) :uint8 i) (aref seq (+ start i)))))
  (inc-position byte-buffer end))



(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 2)
    (assert (eql 30 (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~%" (get-string mybuf))

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

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

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