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 +dns-datagram-size+))
  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                                         :adjustable t :fill-pointer 0)))
  41       (t (setf size (- (length seq) start)
  42                wcursor (- (length seq) start))
  43          (let ((newseq (make-array size :element-type 'ub8
  44                                    :adjustable t :fill-pointer size)))
  45            (replace newseq seq :start2 start)
  46            (setf seq newseq))))))
  47
  48 (defun ub16-to-vector (value)
  49   (vector (ldb (byte 8 8) value)
  50           (ldb (byte 8 0) value)))
  51
  52 (defun ub32-to-vector (value)
  53   (vector (ldb (byte 8 32) value)
  54           (ldb (byte 8 16) value)
  55           (ldb (byte 8 8) value)
  56           (ldb (byte 8 0) value)))
  57
  58 (defvar *buffer-growth-margin* 50)
  59
  60 (defun maybe-grow-buffer (buffer vector)
  61   (declare (type dynamic-buffer buffer)
  62            (type array vector))
  63   (with-accessors ((seq sequence-of) (wcursor write-cursor-of)
  64                    (size size-of)) buffer
  65     (let* ((vlen (length vector))
  66            (newsize (+ size vlen *buffer-growth-margin*)))
  67       (when (< size (+ wcursor vlen))
  68         (setf seq (adjust-array seq newsize))
  69         (setf size newsize))))
  70   (values buffer))
  71
  72 (defgeneric write-vector (buffer vector)
  73   (:method ((buffer dynamic-buffer) (vector array))
  74     (maybe-grow-buffer buffer vector)
  75     (with-accessors ((seq sequence-of) (wcursor write-cursor-of)) buffer
  76       (let ((vlen (length vector)))
  77         (incf (fill-pointer seq) vlen)
  78         (replace seq vector :start1 wcursor)
  79         (incf wcursor vlen)))
  80     (values buffer)))
  81
  82 (defgeneric write-ub8 (buffer vector)
  83   (:method ((buffer dynamic-buffer) (value integer))
  84     (write-vector buffer (vector value))))
  85
  86 (defgeneric write-ub16 (buffer vector)
  87   (:method ((buffer dynamic-buffer) (value integer))
  88     (write-vector buffer (ub16-to-vector value))))
  89
  90 (defgeneric write-ub32 (buffer vector)
  91   (:method ((buffer dynamic-buffer)
  92             (value integer))
  93     (write-vector buffer (ub32-to-vector value))))
  94
  95 (defmacro with-dynamic-buffer ((var &key size) &body body)
  96   `(let ((,var ,(if size
  97                     `(make-instance 'dynamic-buffer
  98                                     :size ,size)
  99                     `(make-instance 'dynamic-buffer))))
 100      ,@body
 101      ,var))
 102
 103 (define-condition dynamic-buffer-input-error (error)
 104   ((buffer :initform (error "Must supply buffer")
 105            :initarg :buffer :reader buffer-of)))
 106
 107 (define-condition input-buffer-eof (dynamic-buffer-input-error)
 108   ((bytes-requested :initarg :requested :reader bytes-requested)
 109    (bytes-remaining :initarg :remaining :reader bytes-remaining))
 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))))