Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive In directory clnet:/tmp/cvs-serv5382/src/contrib/eslick/db-lisp/archive Added Files: binary-data.lisp binary-types.lisp lisp-types.lisp octet-stream.lisp serializer3.lisp Log Message: Henrik's fixes and latest db-lisp updates --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-data.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-data.lisp 2007/02/12 20:36:45 1.1 (in-package :db-lisp) ;; ;; Macros ;; (defmacro with-gensyms ((&rest names) &body body) `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) ,@body)) ;; ;; Binary types ;; ;; NOTE: Needs to be made MP safe (defvar *in-progress-objects* nil) (defconstant +null+ (code-char 0)) (defgeneric read-value (type stream &key) (:documentation "Read a value of the given type from the stream.")) (defgeneric write-value (type stream value &key) (:documentation "Write a value as the given type to the stream.")) (defgeneric read-object (object stream) (:method-combination progn :most-specific-last) (:documentation "Fill in the slots of object from stream.")) (defgeneric write-object (object stream) (:method-combination progn :most-specific-last) (:documentation "Write out the slots of object to the stream.")) ;; These may not be needed; design your compound objects so that ;; you can read offsets and parse compound objects ;;(defgeneric read-field-value (type stream &optional base-pos) ;; (:documentation "Index directly to a subfield of a complex type to read ;; from a random underlying stream")) ;; ;;(defgeneric write-field-value (type stream value &optional base-pos) ;; (:documentation "Write an object directly to the subfield of a complex ;; type in the provided field")) ;; ;; Defaults for read-value of binary-object types (defmethod read-value ((type symbol) stream &key) (let ((object (make-instance type))) (read-object object stream) object)) (defmethod write-value ((type symbol) stream value &key) (assert (typep value type)) (write-object value stream)) (defun read-value-at (type stream pos) "Ensure a stream is at a particular offset before reading" (file-position stream pos) (read-value type stream)) (defun write-value-at (type stream pos value) "Ensure a stream is at a particular offset before writing" (file-position stream pos) (write-value type stream value)) ;;; Binary types (defmacro define-binary-type (name (&rest args) &body spec) (with-gensyms (type stream value) `(progn (defmethod read-value ((,type (eql ',name)) ,stream &key ,@args) (declare (ignorable ,@args)) ,(type-reader-body spec stream)) (defmethod write-value ((,type (eql ',name)) ,stream ,value &key ,@args) (declare (ignorable ,@args)) ,(type-writer-body spec stream value))))) (defun type-reader-body (spec stream) (ecase (length spec) (1 (destructuring-bind (type &rest args) (mklist (first spec)) `(read-value ',type ,stream ,@args))) (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) `(let ((,in ,stream)) ,@body))))) (defun type-writer-body (spec stream value) (ecase (length spec) (1 (destructuring-bind (type &rest args) (mklist (first spec)) `(write-value ',type ,stream ,value ,@args))) (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) `(let ((,out ,stream) (,v ,value)) ,@body))))) ;;; Binary classes (defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) (with-gensyms (objectvar streamvar) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'slots) ',(mapcar #'first slots)) (setf (get ',name 'superclasses) ',superclasses)) (defclass ,name ,superclasses ,(mapcar #'slot->defclass-slot slots)) ,read-method (defmethod write-object progn ((,objectvar ,name) ,streamvar) (declare (ignorable ,streamvar)) (with-slots ,(new-class-all-slots slots superclasses) ,objectvar ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) (defmacro define-binary-class (name (&rest superclasses) slots) (with-gensyms (objectvar streamvar) `(define-generic-binary-class ,name ,superclasses ,slots (defmethod read-object progn ((,objectvar ,name) ,streamvar) (declare (ignorable ,streamvar)) (with-slots ,(new-class-all-slots slots superclasses) ,objectvar ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) (defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) (with-gensyms (typevar objectvar streamvar) `(define-generic-binary-class ,name ,superclasses ,slots (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) (let ((,objectvar (make-instance ,@(or (cdr (assoc :dispatch options)) (error "Must supply :disptach form.")) ,@(mapcan #'slot->keyword-arg slots)))) (read-object ,objectvar ,streamvar) ,objectvar)))))) (defun as-keyword (sym) (intern (string sym) :keyword)) (defun normalize-slot-spec (spec) (list (first spec) (mklist (second spec)))) (defun mklist (x) (if (listp x) x (list x))) (defun slot->defclass-slot (spec) (let ((name (first spec))) `(,name :initarg ,(as-keyword name) :accessor ,name))) (defun slot->read-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(setf ,name (read-value ',type ,stream ,@args)))) (defun slot->write-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(write-value ',type ,stream ,name ,@args))) (defun slot->binding (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(,name (read-value ',type ,stream ,@args)))) (defun slot->keyword-arg (spec) (let ((name (first spec))) `(,(as-keyword name) ,name))) ;;; Keeping track of inherited slots (defun direct-slots (name) (copy-list (get name 'slots))) (defun inherited-slots (name) (loop for super in (get name 'superclasses) nconc (direct-slots super) nconc (inherited-slots super))) (defun all-slots (name) (nconc (direct-slots name) (inherited-slots name))) (defun new-class-all-slots (slots superclasses) "Like all slots but works while compiling a new class before slots and superclasses have been saved." (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) ;;; In progress Object stack (defun current-binary-object () (first *in-progress-objects*)) (defun parent-of-type (type) (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) (defmethod read-object :around (object stream) (declare (ignore stream)) (let ((*in-progress-objects* (cons object *in-progress-objects*))) (call-next-method))) (defmethod write-object :around (object stream) (declare (ignore stream)) (let ((*in-progress-objects* (cons object *in-progress-objects*))) (call-next-method))) ;; Copyright (c) 2005, Peter Seibel All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; * Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; * 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. ;; * Neither the name of the Peter Seibel nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "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 COPYRIGHT ;; OWNER OR CONTRIBUTORS 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. --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-types.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-types.lisp 2007/02/12 20:36:45 1.1 (in-package :db-lisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A few basic types (define-binary-type unsigned-integer (bytes) (:reader (in) (loop with value = 0 for shift downfrom (* bytes 8) to 0 by 8 do (setf value (logior (ash (read-byte in) shift) value)) finally (return value))) (:writer (out value) (loop for shift downfrom (* bytes 8) to 0 by 8 do (write-byte (logand (ash value (- shift)) #xFF) out)))) (define-binary-type unsigned-integer-cplx (bytes bits-per-byte) (:reader (in) (loop with value = 0 for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) finally (return value))) (:writer (out value) (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) (define-binary-type u8 () (unsigned-integer :bytes 1)) (define-binary-type u16 () (unsigned-integer :bytes 2)) (define-binary-type u24 () (unsigned-integer :bytes 3)) (define-binary-type u32 () (unsigned-integer :bytes 4)) (define-binary-type u64 () (unsigned-integer :bytes 8)) ;;; Strings (define-binary-type generic-string (length character-type) (:reader (in) (let ((string (make-string length))) (dotimes (i length) (setf (char string i) (read-value character-type in))) string)) (:writer (out string) (dotimes (i length) (write-value character-type out (char string i))))) (define-binary-type generic-terminated-string (terminator character-type) (:reader (in) (with-output-to-string (s) (loop for char = (read-value character-type in) until (char= char terminator) do (write-char char s)))) (:writer (out string) (loop for char across string do (write-value character-type out char) finally (write-value character-type out terminator)))) ;;; ISO-8859-1 strings (define-binary-type iso-8859-1-char () (:reader (in) (let ((code (read-byte in))) (or (code-char code) (error "Character code ~d not supported" code)))) (:writer (out char) (let ((code (char-code char))) (if (<= 0 code #xff) (write-byte code out) (error "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code))))) (define-binary-type iso-8859-1-string (length) (generic-string :length length :character-type 'iso-8859-1-char)) (define-binary-type iso-8859-1-terminated-string (terminator) (generic-terminated-string :terminator terminator :character-type 'iso-8859-1-char)) ;;; UCS-2 (Unicode) strings (i.e. UTF-16 without surrogate pairs, phew.) ;;; Define a binary type for reading a UCS-2 character relative to a ;;; particular byte ordering as indicated by the BOM value. ;; v2.3 specifies that the BOM should be present. v2.2 is silent ;; though it is arguably inherent in the definition of UCS-2) Length ;; is in bytes. On the write side, since we don't have any way of ;; knowing what BOM was used to read the string we just pick one. ;; This does mean roundtrip transparency could be broken. (define-binary-type ucs-2-char (swap) (:reader (in) (let ((code (read-value 'u2 in))) (when swap (setf code (swap-bytes code))) (or (code-char code) (error "Character code ~d not supported" code)))) (:writer (out char) (let ((code (char-code char))) (unless (<= 0 code #xffff) (error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code)) (when swap (setf code (swap-bytes code))) (write-value 'u2 out code)))) (defun swap-bytes (code) (assert (<= code #xffff)) (rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code)) code) (define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil)) (define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t)) (defun ucs-2-char-type (byte-order-mark) (ecase byte-order-mark (#xfeff 'ucs-2-char-big-endian) (#xfffe 'ucs-2-char-little-endian))) (define-binary-type ucs-2-string (length) (:reader (in) (let ((byte-order-mark (read-value 'u2 in)) (characters (1- (/ length 2)))) (read-value 'generic-string in :length characters :character-type (ucs-2-char-type byte-order-mark)))) (:writer (out string) (write-value 'u2 out #xfeff) (write-value 'generic-string out string :length (length string) :character-type (ucs-2-char-type #xfeff)))) (define-binary-type ucs-2-terminated-string (terminator) (:reader (in) (let ((byte-order-mark (read-value 'u2 in))) (read-value 'generic-terminated-string in :terminator terminator :character-type (ucs-2-char-type byte-order-mark)))) (:writer (out string) (write-value 'u2 out #xfeff) (write-value 'generic-terminated-string out string :terminator terminator :character-type (ucs-2-char-type #xfeff)))) ;; Copyright (c) 2005, Peter Seibel All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; * Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; * 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. ;; * Neither the name of the Peter Seibel nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "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 COPYRIGHT ;; OWNER OR CONTRIBUTORS 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. --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/lisp-types.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/lisp-types.lisp 2007/02/12 20:36:45 1.1 (in-package :db-lisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Map lisp types to binary types (defparameter *lisp-binary-typemap* '((fixnum . u32) [7 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/octet-stream.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/octet-stream.lisp 2007/02/12 20:36:45 1.1 [248 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/serializer3.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/serializer3.lisp 2007/02/12 20:36:45 1.1 [381 lines skipped]