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   ((octets-requested :initarg :requested :reader octets-requested)
 109    (octets-remaining :initarg :remaining :reader octets-remaining))
 110   (:report (lambda (condition stream)
 111              (format stream "You requested ~a octets but only ~A are left in the buffer"
 112                      (octets-requested condition)
 113                      (octets-remaining condition))))
 114   (:documentation
 115    "Signals that an INPUT-BUFFER contains less unread bytes than requested."))
 116
 117 (define-condition input-buffer-index-out-of-bounds (dynamic-buffer-input-error) ()
 118   (:documentation
 119    "Signals that DYNAMIC-BUFFER-SEEK-READ-CURSOR on an INPUT-BUFFER was passed an
 120 invalid offset."))
 121
 122 (defgeneric dynamic-buffer-seek-read-cursor (buffer place &optional offset)
 123   (:method ((buffer dynamic-buffer) place &optional offset)
 124     (check-type place (member :start :end :offset) "one of :START, :END or :OFFSET")
 125     (when (eq place :offset)
 126       (check-type offset unsigned-byte "an unsigned-byte"))
 127     (with-accessors ((seq sequence-of) (rcursor read-cursor-of)
 128                      (size size-of)) buffer
 129       (case place
 130         (:start (setf rcursor 0))
 131         (:end   (setf rcursor size))
 132         (:offset
 133          (if (>= offset size)
 134              (error 'input-buffer-index-out-of-bounds :buffer buffer)
 135              (setf rcursor offset)))))))
 136
 137 (defgeneric unread-bytes (buffer)
 138   (:method ((buffer dynamic-buffer))
 139     (- (write-cursor-of buffer) (read-cursor-of buffer))))
 140
 141 (defgeneric check-if-enough-bytes (buffer length)
 142   (:method ((buffer dynamic-buffer) length)
 143     (check-type length unsigned-byte "an unsigned-byte")
 144     (when (< (unread-bytes buffer) length)
 145       (error 'input-buffer-eof
 146              :buffer buffer
 147              :requested length
 148              :remaining (unread-bytes buffer)))))
 149
 150 (defmacro read-ub-be (vector position &optional (length 1))
 151   `(+ ,@(loop :for i :below length
 152               :collect `(ash (aref ,vector (+ ,position ,i))
 153                              ,(* (- length i 1) 8)))))
 154
 155 (defun read-ub16-from-vector (vector position)
 156   (read-ub-be vector position 2))
 157
 158 (defun read-ub32-from-vector (vector position)
 159   (read-ub-be vector position 4))
 160
 161 (defgeneric read-vector (buffer length)
 162   (:method ((buffer dynamic-buffer) length)
 163     (let* ((bytes-to-read (min (unread-bytes buffer) length))
 164            (newvector (make-array bytes-to-read :element-type 'ub8)))
 165       (with-accessors ((seq sequence-of) (pos read-cursor-of)) buffer
 166         (replace newvector seq :start2 pos)
 167         (incf pos bytes-to-read))
 168       (values newvector))))
 169
 170 (defgeneric read-ub8 (buffer)
 171   (:method ((buffer dynamic-buffer))
 172     (check-if-enough-bytes buffer 1)
 173     (prog1
 174         (aref (sequence-of buffer) (read-cursor-of buffer))
 175       (incf (read-cursor-of buffer)))))
 176
 177 (defgeneric read-ub16 (buffer)
 178   (:method ((buffer dynamic-buffer))
 179     (check-if-enough-bytes buffer 2)
 180     (prog1
 181         (read-ub16-from-vector (sequence-of buffer) (read-cursor-of buffer))
 182       (incf (read-cursor-of buffer) 2))))
 183
 184 (defgeneric read-ub32 (buffer)
 185   (:method ((buffer dynamic-buffer))
 186     (check-if-enough-bytes buffer 4)
 187     (prog1
 188         (read-ub32-from-vector (sequence-of buffer) (read-cursor-of buffer))
 189       (incf (read-cursor-of buffer) 4))))