sockets/dns/dynamic-buffer.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Indent-tabs-mode: NIL -*-
   2 ;;;
   3 ;;; dynamic-buffer.lisp --- Read/write adjustable buffer.
   4 ;;;
   5 ;;; Copyright (C) 2006-2007, Stelian Ionescu  <sionescu@common-lisp.net>
   6 ;;;
   7 ;;; This code is free software; you can redistribute it and/or
   8 ;;; modify it under the terms of the version 2.1 of
   9 ;;; the GNU Lesser General Public License as published by
  10 ;;; the Free Software Foundation, as clarified by the
  11 ;;; preamble found here:
  12 ;;;     http://opensource.franz.com/preamble.html
  13 ;;;
  14 ;;; This program is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU Lesser General
  20 ;;; Public License along with this library; if not, write to the
  21 ;;; Free Software Foundation, Inc., 51 Franklin St, Fifth Floor,
  22 ;;; Boston, MA 02110-1301, USA
  23
  24 (in-package :net.sockets)
  25
  26 (defclass dynamic-buffer ()
  27   ((sequence     :initform nil  :initarg :sequence
  28                  :accessor sequence-of)
  29    (read-cursor  :initform 0    :accessor read-cursor-of)
  30    (write-cursor :initform 0    :accessor write-cursor-of)
  31    (size         :initarg :size :accessor size-of))
  32   (:default-initargs :size 128))
  33
  34 (defmethod initialize-instance :after ((buffer dynamic-buffer) &key (start 0))
  35   (with-accessors ((seq sequence-of) (size size-of)
  36                    (wcursor write-cursor-of)) buffer
  37     (check-type seq (or null ub8-vector) "either NIL or a (VECTOR UNSIGNED-BYTE)")
  38     (cond
  39       ((null seq) (setf seq (make-array size :element-type 'ub8)))
  40       (t (setf size (- (length seq) start)
  41                wcursor (- (length seq) start))
  42          (let ((newseq (make-array size :element-type 'ub8)))
  43            (replace newseq seq :start2 start)
  44            (setf seq newseq))))))
  45
  46 (defun ub16-to-vector (value)
  47   (vector (ldb (byte 8 8) value)
  48           (ldb (byte 8 0) value)))
  49
  50 (defun ub32-to-vector (value)
  51   (vector (ldb (byte 8 32) value)
  52           (ldb (byte 8 16) value)
  53           (ldb (byte 8 8) value)
  54           (ldb (byte 8 0) value)))
  55
  56 (defun maybe-grow-buffer (buffer vector)
  57   (declare (type dynamic-buffer buffer)
  58            (type array vector))
  59   (with-accessors ((seq sequence-of) (wcursor write-cursor-of)
  60                    (size size-of))
  61       buffer
  62     (let ((vlen (length vector)))
  63       (when (< size (+ wcursor vlen))
  64         (let ((newsize (* 3/2 (+ size vlen))))
  65           (setf seq (adjust-array seq newsize))
  66           (setf size newsize)))))
  67   (values buffer))
  68
  69 (defgeneric write-vector (buffer vector)
  70   (:method ((buffer dynamic-buffer) (vector array))
  71     (maybe-grow-buffer buffer vector)
  72     (with-accessors ((seq sequence-of) (wcursor write-cursor-of)) buffer
  73       (let ((vlen (length vector)))
  74         (replace seq vector :start1 wcursor)
  75         (incf wcursor vlen)))
  76     (values buffer)))
  77
  78 (defgeneric write-ub8 (buffer vector)
  79   (:method ((buffer dynamic-buffer) (value integer))
  80     (write-vector buffer (vector value))))
  81
  82 (defgeneric write-ub16 (buffer vector)
  83   (:method ((buffer dynamic-buffer) (value integer))
  84     (write-vector buffer (ub16-to-vector value))))
  85
  86 (defgeneric write-ub32 (buffer vector)
  87   (:method ((buffer dynamic-buffer)
  88             (value integer))
  89     (write-vector buffer (ub32-to-vector value))))
  90
  91 (defmacro with-dynamic-buffer ((var &key size) &body body)
  92   `(let ((,var ,(if size
  93                     `(make-instance 'dynamic-buffer
  94                                     :size ,size)
  95                     `(make-instance 'dynamic-buffer))))
  96      ,@body
  97      ,var))
  98
  99 (define-condition dynamic-buffer-input-error (error)
 100   ((buffer :initform (error "Must supply buffer")
 101            :initarg :buffer :reader buffer-of)))
 102
 103 (define-condition input-buffer-eof (dynamic-buffer-input-error)
 104   ((octets-requested :initarg :requested :reader octets-requested)
 105    (octets-remaining :initarg :remaining :reader octets-remaining))
 106   (:report (lambda (condition stream)
 107              (format stream "You requested ~a octets but only ~A are left in the buffer"
 108                      (octets-requested condition)
 109                      (octets-remaining condition))))
 110   (:documentation
 111    "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
 112
 113 (define-condition input-buffer-index-out-of-bounds (dynamic-buffer-input-error) ()
 114   (:documentation
 115    "Signals that DYNAMIC-BUFFER-SEEK-READ-CURSOR on an INPUT-BUFFER was passed an
 116 invalid offset."))
 117
 118 (defgeneric dynamic-buffer-seek-read-cursor (buffer place &optional offset)
 119   (:method ((buffer dynamic-buffer) place &optional offset)
 120     (check-type place (member :start :end :offset) "one of :START, :END or :OFFSET")
 121     (when (eq place :offset)
 122       (check-type offset unsigned-byte "an unsigned-byte"))
 123     (with-accessors ((seq sequence-of) (rcursor read-cursor-of)
 124                      (size size-of)) buffer
 125       (case place
 126         (:start (setf rcursor 0))
 127         (:end   (setf rcursor size))
 128         (:offset
 129          (if (>= offset size)
 130              (error 'input-buffer-index-out-of-bounds :buffer buffer)
 131              (setf rcursor offset)))))))
 132
 133 (defgeneric unread-bytes (buffer)
 134   (:method ((buffer dynamic-buffer))
 135     (- (write-cursor-of buffer) (read-cursor-of buffer))))
 136
 137 (defgeneric check-if-enough-bytes (buffer length)
 138   (:method ((buffer dynamic-buffer) length)
 139     (check-type length unsigned-byte "an unsigned-byte")
 140     (when (< (unread-bytes buffer) length)
 141       (error 'input-buffer-eof
 142              :buffer buffer
 143              :requested length
 144              :remaining (unread-bytes buffer)))))
 145
 146 (defmacro read-ub-be (vector position &optional (length 1))
 147   `(+ ,@(loop :for i :below length
 148               :collect `(ash (aref ,vector (+ ,position ,i))
 149                              ,(* (- length i 1) 8)))))
 150
 151 (defun read-ub16-from-vector (vector position)
 152   (read-ub-be vector position 2))
 153
 154 (defun read-ub32-from-vector (vector position)
 155   (read-ub-be vector position 4))
 156
 157 (defgeneric read-vector (buffer length)
 158   (:method ((buffer dynamic-buffer) length)
 159     (let* ((bytes-to-read (min (unread-bytes buffer) length))
 160            (newvector (make-array bytes-to-read :element-type 'ub8)))
 161       (with-accessors ((seq sequence-of) (pos read-cursor-of)) buffer
 162         (replace newvector seq :start2 pos)
 163         (incf pos bytes-to-read))
 164       (values newvector))))
 165
 166 (defgeneric read-ub8 (buffer)
 167   (:method ((buffer dynamic-buffer))
 168     (check-if-enough-bytes buffer 1)
 169     (prog1
 170         (aref (sequence-of buffer) (read-cursor-of buffer))
 171       (incf (read-cursor-of buffer)))))
 172
 173 (defgeneric read-ub16 (buffer)
 174   (:method ((buffer dynamic-buffer))
 175     (check-if-enough-bytes buffer 2)
 176     (prog1
 177         (read-ub16-from-vector (sequence-of buffer) (read-cursor-of buffer))
 178       (incf (read-cursor-of buffer) 2))))
 179
 180 (defgeneric read-ub32 (buffer)
 181   (:method ((buffer dynamic-buffer))
 182     (check-if-enough-bytes buffer 4)
 183     (prog1
 184         (read-ub32-from-vector (sequence-of buffer) (read-cursor-of buffer))
 185       (incf (read-cursor-of buffer) 4))))