From 4848562fb282f2f78dae2ed9884d6f518c317cae Mon Sep 17 00:00:00 2001 From: islam omar ahmed Date: Fri, 20 Jan 2023 22:27:22 +0200 Subject: [PATCH 1/5] Use portable ieee-floats + hton/ntoh --- cl-messagepack.asd | 2 +- cl-messagepack.lisp | 117 ++++++++++++++++++++++---------------------- tests.lisp | 14 +++--- 3 files changed, 67 insertions(+), 66 deletions(-) diff --git a/cl-messagepack.asd b/cl-messagepack.asd index 6b2f679..15ddff8 100644 --- a/cl-messagepack.asd +++ b/cl-messagepack.asd @@ -24,7 +24,7 @@ (asdf:defsystem #:cl-messagepack :serial t - :depends-on (:flexi-streams :babel :closer-mop) + :depends-on (:flexi-streams :babel :closer-mop :ieee-floats :swap-bytes) :description "A Common-Lisp implementation of Message Pack serialization." :author "Miron Brezuleanu" :license "Simplified BSD License" diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index ca98d1b..fd58e6a 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -26,16 +26,6 @@ (declaim (optimize (debug 3))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun mkstr (&rest args) - (format nil "~{~a~}" args)) - (defun mksymb (&rest args) - (intern (apply #'mkstr args))) - (defun speed-for-size (size) - (if (< size (integer-length most-positive-fixnum)) - 3 - 0))) - (defun alistp (l) "Alist predicate" (and (consp l) (consp (car l)) (atom (caar l)))) @@ -44,25 +34,20 @@ "Plist predicate." (and (consp l) (keywordp (car l)) (consp (cdr l)))) -(defmacro signed-unsigned-convertors (size) - `(progn - (defun ,(mksymb 'sb size '-> 'ub size) (sb) - (declare (optimize (debug 0) (safety 0) (speed ,(speed-for-size size))) - (type (integer ,(- (expt 2 (1- size))) ,(1- (expt 2 (1- size)))) sb)) - (if (< sb 0) - (ldb (byte ,size 0) sb) - sb)) - (defun ,(mksymb 'ub size '-> 'sb size) (sb) - (declare (optimize (debug 0) (safety 0) (speed ,(speed-for-size size))) - (type (mod ,(expt 2 size)) sb)) - (if (logbitp (1- ,size) sb) - (- (1+ (logxor (1- (expt 2 ,size)) sb))) - sb)))) - -(signed-unsigned-convertors 8) -(signed-unsigned-convertors 16) -(signed-unsigned-convertors 32) -(signed-unsigned-convertors 64) +;; from DBUS-lisp +(defun signed-to-unsigned (value size) + "Return the unsigned representation of a signed byte with a given +size." + (declare (type integer value size)) + (ldb (byte size 0) value)) + +(defun unsigned-to-signed (value size) + "Return the signed representation of an unsigned byte with a given +size." + (declare (type integer value size)) + (if (logbitp (1- size) value) + (dpb value (byte size 0) -1) + value)) (defun write-hex (data) (let (line) @@ -93,6 +78,46 @@ (and (vectorp data-type) (equal '(unsigned-byte 8) (array-element-type data-type)))) +;; useful types +(deftype uint8 () '(UNSIGNED-BYTE 8)) +(deftype sint8 () '(SIGNED-BYTE 8)) ; +(deftype uint16 () '(UNSIGNED-BYTE 16)) +(deftype sint16 () '(SIGNED-BYTE 16)) +(deftype uint32 () '(UNSIGNED-BYTE 32)) +(deftype sint32 () '(SIGNED-BYTE 32)) +(deftype uint64 () '(UNSIGNED-BYTE 64)) +(deftype sint64 () '(SIGNED-BYTE 64)) + +(defun hton (x x-type) + (declare (type real x)) + (declare (type keyword x-type)) + (ecase x-type + (:uint8 (the uint8 x)) + (:sint8 (the uint8 (signed-to-unsigned x 8))) + (:uint16 (the uint16 (htons x))) + (:sint16 (the uint16 (htons (signed-to-unsigned x 16)))) + (:uint32 (the uint32 (htonl x))) + (:sint32 (the uint32 (htonl (signed-to-unsigned x 32)))) + (:uint64 (the uint64 (htonq x))) + (:sint64 (the uint64 (htonq (signed-to-unsigned x 64)))) + (:float32 (the uint32 (htonl (encode-float32 x)))) + (:float64 (the uint64 (htonq (encode-float64 x)))))) + +(defun ntoh (x x-type) + (declare (type real x)) + (declare (type keyword x-type)) + (ecase x-type + (:uint8 (the uint8 x)) + (:sint8 (the sint8 (unsigned-to-signed x 8))) + (:uint16 (the uint16 (ntohs x))) + (:sint16 (the sint16 (unsigned-to-signed (ntohs x) 16))) + (:uint32 (the uint32 (ntohl x))) + (:sint32 (the sint32 (unsigned-to-signed (ntohl x) 32))) + (:uint64 (the uint64 (ntohq x))) + (:sint64 (the sint64 (unsigned-to-signed (ntohq x) 64))) + (:float32 (the single-float (decode-float32 (ntohl x)))) + (:float64 (the double-float (decode-float64 (ntohq x)))))) + (defmacro store-big-endian (number stream byte-count) (let ((g-number (gensym "number")) (g-stream (gensym "stream"))) @@ -190,37 +215,18 @@ (defun encode-string (data stream) (encode-raw-bytes (babel:string-to-octets data) stream)) -#+sbcl (defun sbcl-encode-float (data stream &optional drop-prefix) +(defun encode-float (data stream &optional drop-prefix) (cond ((equal (type-of data) 'single-float) (unless drop-prefix (write-byte #xca stream)) - (store-big-endian (sb-kernel:single-float-bits data) stream 4)) + (store-big-endian (hton data :float32) stream 4)) ((equal (type-of data) 'double-float) (unless drop-prefix (write-byte #xcb stream)) - (store-big-endian (sb-kernel:double-float-high-bits data) stream 4) - (store-big-endian (sb-kernel:double-float-low-bits data) stream 4)) + (store-big-endian (hton data :float64) stream 8)) (T (error "~s is not a float" data)))) -#+ccl (defun ccl-encode-double-float (data stream &optional drop-prefix) - (cond ((equal (type-of data) 'single-float) - (error "No cl-messagepack support for single precision floats in CCL.")) - ((equal (type-of data) 'double-float) - (unless drop-prefix - (write-byte #xcb stream)) - (multiple-value-bind (hi lo) - (ccl::double-float-bits data) - (store-big-endian hi stream 4) - (store-big-endian lo stream 4))) - (T - (error "~s is not a float" data)))) - -(defun encode-float (data stream &optional drop-prefix) - (or #+sbcl (sbcl-encode-float data stream drop-prefix) - #+ccl (ccl-encode-double-float data stream drop-prefix) - #-(or sbcl ccl) (error "No floating point support yet."))) - (defun encode-each (data stream) (cond ((hash-table-p data) (maphash (lambda (key value) @@ -380,14 +386,9 @@ ((= #xc2 byte) (if *use-false* :false nil)) ((= #xca byte) - (or #+sbcl (sb-kernel:make-single-float (ub32->sb32 (load-big-endian stream 4))) - #-(or sbcl) (error "No floating point support yet."))) + (ntoh (load-big-endian stream 4) :float32)) ((= #xcb byte) - (or #+sbcl (sb-kernel:make-double-float (ub32->sb32 (load-big-endian stream 4)) - (load-big-endian stream 4)) - #+ccl (ccl::double-float-from-bits (load-big-endian stream 4) - (load-big-endian stream 4)) - #-(or sbcl ccl) (error "No floating point support yet."))) + (ntoh (load-big-endian stream 8) :float64)) ((= 5 (ldb (byte 3 5) byte)) (decode-string (ldb (byte 5 0) byte) stream)) ((= #xd9 byte) diff --git a/tests.lisp b/tests.lisp index f2a517b..1325a08 100644 --- a/tests.lisp +++ b/tests.lisp @@ -57,8 +57,8 @@ (test floating-point "Test encoding of single and double precision floating point numbers." - #+sbcl (is (equalp #(#xCA #x3F #x80 #x00 #x00) (mpk:encode 1.0s0))) - #+sbcl (is (equalp #(#xCA #xBF #x80 #x00 #x00) (mpk:encode -1.0s0))) + (is (equalp #(#xCA #x3F #x80 #x00 #x00) (mpk:encode 1.0s0))) + (is (equalp #(#xCA #xBF #x80 #x00 #x00) (mpk:encode -1.0s0))) (is (equalp #(#xCB #x3F #xF0 #x00 #x00 #x00 #x00 #x00 #x00) (mpk:encode 1.0d0))) (is (equalp #(#xCB #xBF #xF0 #x00 #x00 #x00 #x00 #x00 #x00) (mpk:encode -1.0d0)))) @@ -168,12 +168,12 @@ encode properly." (test decoding-floats "Test that (equalp (decode (encode data)) data) for floats." - #+ (or sbcl ccl) (is (eql 100d0 (mpk:decode (mpk:encode 100d0)))) - #+ (or sbcl ccl) (is (eql -100d0 (mpk:decode (mpk:encode -100d0)))) - #+ (or sbcl ccl) (is (eql -1.2345678901234567e19 + (is (eql 100d0 (mpk:decode (mpk:encode 100d0)))) + (is (eql -100d0 (mpk:decode (mpk:encode -100d0)))) + (is (eql -1.2345678901234567e19 (mpk:decode (mpk:encode -1.2345678901234567e19)))) - #+ sbcl (is (eql 102s0 (mpk:decode (mpk:encode 102s0)))) - #+ sbcl (is (eql -102s0 (mpk:decode (mpk:encode -102s0))))) + (is (eql 102s0 (mpk:decode (mpk:encode 102s0)))) + (is (eql -102s0 (mpk:decode (mpk:encode -102s0))))) (test decoding-strings "Test that (equalp (decode (encode data)) data) holds for strings." From 022033069b12e6e464ff6bd43a693d37c2fa5bf6 Mon Sep 17 00:00:00 2001 From: islam omar ahmed Date: Sat, 21 Jan 2023 17:18:16 +0200 Subject: [PATCH 2/5] fix symbols package --- cl-messagepack.lisp | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index fd58e6a..38e18b0 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -94,14 +94,14 @@ size." (ecase x-type (:uint8 (the uint8 x)) (:sint8 (the uint8 (signed-to-unsigned x 8))) - (:uint16 (the uint16 (htons x))) - (:sint16 (the uint16 (htons (signed-to-unsigned x 16)))) - (:uint32 (the uint32 (htonl x))) - (:sint32 (the uint32 (htonl (signed-to-unsigned x 32)))) - (:uint64 (the uint64 (htonq x))) - (:sint64 (the uint64 (htonq (signed-to-unsigned x 64)))) - (:float32 (the uint32 (htonl (encode-float32 x)))) - (:float64 (the uint64 (htonq (encode-float64 x)))))) + (:uint16 (the uint16 (swap-bytes:htons x))) + (:sint16 (the uint16 (swap-bytes:htons (signed-to-unsigned x 16)))) + (:uint32 (the uint32 (swap-bytes:htonl x))) + (:sint32 (the uint32 (swap-bytes:htonl (signed-to-unsigned x 32)))) + (:uint64 (the uint64 (swap-bytes:htonq x))) + (:sint64 (the uint64 (swap-bytes:htonq (signed-to-unsigned x 64)))) + (:float32 (the uint32 (swap-bytes:htonl (ieee-floats:encode-float32 x)))) + (:float64 (the uint64 (swap-bytes:htonq (ieee-floats:encode-float64 x)))))) (defun ntoh (x x-type) (declare (type real x)) @@ -109,14 +109,14 @@ size." (ecase x-type (:uint8 (the uint8 x)) (:sint8 (the sint8 (unsigned-to-signed x 8))) - (:uint16 (the uint16 (ntohs x))) - (:sint16 (the sint16 (unsigned-to-signed (ntohs x) 16))) - (:uint32 (the uint32 (ntohl x))) - (:sint32 (the sint32 (unsigned-to-signed (ntohl x) 32))) - (:uint64 (the uint64 (ntohq x))) - (:sint64 (the sint64 (unsigned-to-signed (ntohq x) 64))) - (:float32 (the single-float (decode-float32 (ntohl x)))) - (:float64 (the double-float (decode-float64 (ntohq x)))))) + (:uint16 (the uint16 (swap-bytes:ntohs x))) + (:sint16 (the sint16 (unsigned-to-signed (swap-bytes:ntohs x) 16))) + (:uint32 (the uint32 (swap-bytes:ntohl x))) + (:sint32 (the sint32 (unsigned-to-signed (swap-bytes:ntohl x) 32))) + (:uint64 (the uint64 (swap-bytes:ntohq x))) + (:sint64 (the sint64 (unsigned-to-signed (swap-bytes:ntohq x) 64))) + (:float32 (the single-float (ieee-floats:decode-float32 (swap-bytes:ntohl x)))) + (:float64 (the double-float (ieee-floats:decode-float64 (swap-bytes:ntohq x)))))) (defmacro store-big-endian (number stream byte-count) (let ((g-number (gensym "number")) From 75941fecaed52bb2d39220bcd3617d4791f95ab0 Mon Sep 17 00:00:00 2001 From: islam omar ahmed Date: Sat, 21 Jan 2023 21:08:50 +0200 Subject: [PATCH 3/5] cleanup --- cl-messagepack.asd | 2 +- cl-messagepack.lisp | 139 ++++++++++++++------------------------------ 2 files changed, 46 insertions(+), 95 deletions(-) diff --git a/cl-messagepack.asd b/cl-messagepack.asd index 15ddff8..f2ac375 100644 --- a/cl-messagepack.asd +++ b/cl-messagepack.asd @@ -24,7 +24,7 @@ (asdf:defsystem #:cl-messagepack :serial t - :depends-on (:flexi-streams :babel :closer-mop :ieee-floats :swap-bytes) + :depends-on (:flexi-streams :babel :closer-mop :ieee-floats) :description "A Common-Lisp implementation of Message Pack serialization." :author "Miron Brezuleanu" :license "Simplified BSD License" diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index 38e18b0..e070c86 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -26,6 +26,16 @@ (declaim (optimize (debug 3))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun mkstr (&rest args) + (format nil "~{~a~}" args)) + (defun mksymb (&rest args) + (intern (apply #'mkstr args))) + (defun speed-for-size (size) + (if (< size (integer-length most-positive-fixnum)) + 3 + 0))) + (defun alistp (l) "Alist predicate" (and (consp l) (consp (car l)) (atom (caar l)))) @@ -34,20 +44,25 @@ "Plist predicate." (and (consp l) (keywordp (car l)) (consp (cdr l)))) -;; from DBUS-lisp -(defun signed-to-unsigned (value size) - "Return the unsigned representation of a signed byte with a given -size." - (declare (type integer value size)) - (ldb (byte size 0) value)) - -(defun unsigned-to-signed (value size) - "Return the signed representation of an unsigned byte with a given -size." - (declare (type integer value size)) - (if (logbitp (1- size) value) - (dpb value (byte size 0) -1) - value)) +(defmacro signed-unsigned-convertors (size) + `(progn + (defun ,(mksymb 'sb size '-> 'ub size) (sb) + (declare (optimize (debug 0) (safety 0) (speed ,(speed-for-size size))) + (type (integer ,(- (expt 2 (1- size))) ,(1- (expt 2 (1- size)))) sb)) + (if (< sb 0) + (ldb (byte ,size 0) sb) + sb)) + (defun ,(mksymb 'ub size '-> 'sb size) (sb) + (declare (optimize (debug 0) (safety 0) (speed ,(speed-for-size size))) + (type (mod ,(expt 2 size)) sb)) + (if (logbitp (1- ,size) sb) + (- (1+ (logxor (1- (expt 2 ,size)) sb))) + sb)))) + +(signed-unsigned-convertors 8) +(signed-unsigned-convertors 16) +(signed-unsigned-convertors 32) +(signed-unsigned-convertors 64) (defun write-hex (data) (let (line) @@ -78,46 +93,6 @@ size." (and (vectorp data-type) (equal '(unsigned-byte 8) (array-element-type data-type)))) -;; useful types -(deftype uint8 () '(UNSIGNED-BYTE 8)) -(deftype sint8 () '(SIGNED-BYTE 8)) ; -(deftype uint16 () '(UNSIGNED-BYTE 16)) -(deftype sint16 () '(SIGNED-BYTE 16)) -(deftype uint32 () '(UNSIGNED-BYTE 32)) -(deftype sint32 () '(SIGNED-BYTE 32)) -(deftype uint64 () '(UNSIGNED-BYTE 64)) -(deftype sint64 () '(SIGNED-BYTE 64)) - -(defun hton (x x-type) - (declare (type real x)) - (declare (type keyword x-type)) - (ecase x-type - (:uint8 (the uint8 x)) - (:sint8 (the uint8 (signed-to-unsigned x 8))) - (:uint16 (the uint16 (swap-bytes:htons x))) - (:sint16 (the uint16 (swap-bytes:htons (signed-to-unsigned x 16)))) - (:uint32 (the uint32 (swap-bytes:htonl x))) - (:sint32 (the uint32 (swap-bytes:htonl (signed-to-unsigned x 32)))) - (:uint64 (the uint64 (swap-bytes:htonq x))) - (:sint64 (the uint64 (swap-bytes:htonq (signed-to-unsigned x 64)))) - (:float32 (the uint32 (swap-bytes:htonl (ieee-floats:encode-float32 x)))) - (:float64 (the uint64 (swap-bytes:htonq (ieee-floats:encode-float64 x)))))) - -(defun ntoh (x x-type) - (declare (type real x)) - (declare (type keyword x-type)) - (ecase x-type - (:uint8 (the uint8 x)) - (:sint8 (the sint8 (unsigned-to-signed x 8))) - (:uint16 (the uint16 (swap-bytes:ntohs x))) - (:sint16 (the sint16 (unsigned-to-signed (swap-bytes:ntohs x) 16))) - (:uint32 (the uint32 (swap-bytes:ntohl x))) - (:sint32 (the sint32 (unsigned-to-signed (swap-bytes:ntohl x) 32))) - (:uint64 (the uint64 (swap-bytes:ntohq x))) - (:sint64 (the sint64 (unsigned-to-signed (swap-bytes:ntohq x) 64))) - (:float32 (the single-float (ieee-floats:decode-float32 (swap-bytes:ntohl x)))) - (:float64 (the double-float (ieee-floats:decode-float64 (swap-bytes:ntohq x)))))) - (defmacro store-big-endian (number stream byte-count) (let ((g-number (gensym "number")) (g-stream (gensym "stream"))) @@ -215,17 +190,13 @@ size." (defun encode-string (data stream) (encode-raw-bytes (babel:string-to-octets data) stream)) -(defun encode-float (data stream &optional drop-prefix) - (cond ((equal (type-of data) 'single-float) - (unless drop-prefix - (write-byte #xca stream)) - (store-big-endian (hton data :float32) stream 4)) - ((equal (type-of data) 'double-float) - (unless drop-prefix - (write-byte #xcb stream)) - (store-big-endian (hton data :float64) stream 8)) - (T - (error "~s is not a float" data)))) +(defun encode-float (data stream) + (cond ((equal (type-of data) 'single-float) + (write-byte #xca stream) + (store-big-endian (ieee-floats:encode-float32 data) stream 4)) + ((equal (type-of data) 'double-float) + (write-byte #xcb stream) + (store-big-endian (ieee-floats:encode-float64 data) stream 8)))) (defun encode-each (data stream) (cond ((hash-table-p data) @@ -386,9 +357,9 @@ size." ((= #xc2 byte) (if *use-false* :false nil)) ((= #xca byte) - (ntoh (load-big-endian stream 4) :float32)) + (ieee-floats:decode-float32 (load-big-endian stream 4))) ((= #xcb byte) - (ntoh (load-big-endian stream 8) :float64)) + (ieee-floats:decode-float64 (load-big-endian stream 8))) ((= 5 (ldb (byte 3 5) byte)) (decode-string (ldb (byte 5 0) byte) stream)) ((= #xd9 byte) @@ -488,7 +459,9 @@ size." ;; A class would have a :allocation :class ... ;; A pointer to the e-t-d would be longer than the int itself. (defclass extension-type () - ((id :reader extension-type-id + ((id :initform (error "need an ID") + :initarg id + :reader extension-type-id :writer (setf extension-type-id) :type (or integer (array (unsigned-byte 8) *)))) (:documentation @@ -498,28 +471,6 @@ size." (print-unreadable-object (obj stream :type T :identity T) (format stream "~a" (extension-type-id obj)))) -(defmethod shared-initialize :after ((extension extension-type) - slot-names - &key ((messagepack-sym:id id)) - &allow-other-keys) - (unless id - (error "Need an ID.")) - ;; Incoming ID arrays might not have the :ELEMENT-TYPE we want/expect; - ;; so be nice and convert, if necessary. - (setf (extension-type-id extension) - (cond - ((typep id '(or integer - (array (unsigned-byte 8) *))) - id) - ((and (typep id '(array T *)) - (every #'integerp id) - (every (lambda (i) (<= 0 i 255)) id)) - ;; equivalent... - (make-array (length id) - :element-type '(unsigned-byte 8) - :initial-contents id)) - (t - "Wrong type for ID")))) (defclass extension-type-description () #. (mapcar (lambda (d) @@ -529,10 +480,10 @@ size." :reader ,name :writer (setf ,name) ,@ rest))) - '((type-number (error "missing") :type (integer 0 127)) - (encode-with (error "missing") :type function) - (decode-with (error "missing") :type function) - (as-numeric (error "missing") :type (member t nil)) + '((type-number nil :type (integer 0 127)) + (encode-with nil :type function) + (decode-with nil :type function) + (as-numeric nil :type (member t nil)) (reg-class nil) ))) From 4cc7fd9561bec7bc3f7adcc769de7dd271cb07e5 Mon Sep 17 00:00:00 2001 From: islam omar ahmed Date: Sat, 21 Jan 2023 21:16:23 +0200 Subject: [PATCH 4/5] cleanup --- cl-messagepack.lisp | 34 +++++++++++++++++++++++++++------- 1 file changed, 27 insertions(+), 7 deletions(-) diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index e070c86..698e0ef 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -459,9 +459,7 @@ ;; A class would have a :allocation :class ... ;; A pointer to the e-t-d would be longer than the int itself. (defclass extension-type () - ((id :initform (error "need an ID") - :initarg id - :reader extension-type-id + ((id :reader extension-type-id :writer (setf extension-type-id) :type (or integer (array (unsigned-byte 8) *)))) (:documentation @@ -471,6 +469,28 @@ (print-unreadable-object (obj stream :type T :identity T) (format stream "~a" (extension-type-id obj)))) +(defmethod shared-initialize :after ((extension extension-type) + slot-names + &key ((messagepack-sym:id id)) + &allow-other-keys) + (unless id + (error "Need an ID.")) + ;; Incoming ID arrays might not have the :ELEMENT-TYPE we want/expect; + ;; so be nice and convert, if necessary. + (setf (extension-type-id extension) + (cond + ((typep id '(or integer + (array (unsigned-byte 8) *))) + id) + ((and (typep id '(array T *)) + (every #'integerp id) + (every (lambda (i) (<= 0 i 255)) id)) + ;; equivalent... + (make-array (length id) + :element-type '(unsigned-byte 8) + :initial-contents id)) + (t + "Wrong type for ID")))) (defclass extension-type-description () #. (mapcar (lambda (d) @@ -480,10 +500,10 @@ :reader ,name :writer (setf ,name) ,@ rest))) - '((type-number nil :type (integer 0 127)) - (encode-with nil :type function) - (decode-with nil :type function) - (as-numeric nil :type (member t nil)) + '((type-number (error "missing") :type (integer 0 127)) + (encode-with (error "missing") :type function) + (decode-with (error "missing") :type function) + (as-numeric (error "missing") :type (member t nil)) (reg-class nil) ))) From 6dd0a8add13a86b86627974e3dbad1938032f6fb Mon Sep 17 00:00:00 2001 From: islam omar ahmed Date: Sun, 22 Jan 2023 01:34:03 +0200 Subject: [PATCH 5/5] conform to msgpack specs --- cl-messagepack.lisp | 96 +++++++++++++++++++++++++++++++++++++-------- tests.lisp | 12 ++++-- 2 files changed, 88 insertions(+), 20 deletions(-) diff --git a/cl-messagepack.lisp b/cl-messagepack.lisp index 698e0ef..3426e3e 100644 --- a/cl-messagepack.lisp +++ b/cl-messagepack.lisp @@ -188,7 +188,9 @@ (encode-string (symbol-name data) stream)) (defun encode-string (data stream) - (encode-raw-bytes (babel:string-to-octets data) stream)) + (setf data (babel:string-to-octets data)) + (encode-sequence-length data stream #xa0 31 #xd9 #xda #xdb) + (write-sequence data stream)) (defun encode-float (data stream) (cond ((equal (type-of data) 'single-float) @@ -222,7 +224,8 @@ (t (error "Not sequence or hash table.")))) (defun encode-sequence-length (data stream - short-prefix short-length + fixed-prefix fixed-length + typecode-8 typecode-16 typecode-32) (let ((len (cond ((hash-table-p data) (hash-table-count data)) ((plistp data) (let ((ln (length data))) @@ -230,12 +233,11 @@ (/ ln 2) (error "Malformed plist ~s. Length should be even." data)))) (t (length data))))) - (cond ((and (<= 0 len short-length) (plusp short-length)) - (write-byte (+ short-prefix len) stream)) - ((and (<= 0 len #xff) (zerop short-length)) - (write-byte short-prefix stream) - (write-byte len stream) - (store-big-endian len stream 1)) + (cond ((and (<= 0 len fixed-length) (plusp fixed-length)) + (write-byte (+ fixed-prefix len) stream)) + ((and (<= 0 len #xff) typecode-8) + (write-byte typecode-8 stream) + (write-byte len stream)) ((<= 0 len 65535) (write-byte typecode-16 stream) (store-big-endian len stream 2)) @@ -244,15 +246,15 @@ (store-big-endian len stream 4))))) (defun encode-hash (data stream) - (encode-sequence-length data stream #x80 15 #xde #xdf) + (encode-sequence-length data stream #x80 15 nil #xde #xdf) (encode-each data stream)) (defun encode-array (data stream) - (encode-sequence-length data stream #x90 15 #xdc #xdd) + (encode-sequence-length data stream #x90 15 nil #xdc #xdd) (encode-each data stream)) (defun encode-raw-bytes (data stream) - (encode-sequence-length data stream #xa0 31 #xda #xdb) + (encode-sequence-length data stream #x0 0 #xc4 #xc5 #xc6) (write-sequence data stream)) (defun encode-integer (data stream) @@ -560,6 +562,30 @@ (parse-big-endian bytes) bytes)))) +(defun encode-fix-ext (fixext-byte type obj stream) + (write-byte fixext-byte stream) + (write-byte type stream) + (write-sequence obj stream)) + +(defun encode-ext8 (len type obj stream) + (write-byte #xC7 stream) + (write-byte len stream) + (write-byte type stream) + (write-sequence obj stream)) + +(defun encode-ext16 (len type obj stream) + (write-byte #xC8 stream) + (store-big-endian len stream 2) + (write-byte type stream) + (write-sequence obj stream)) + +(defun encode-ext32 (len type obj stream) + (write-byte #xC9 stream) + (store-big-endian len stream 4) + (write-byte type stream) + (write-sequence obj stream)) + + (defun try-encode-ext-type (obj stream) (let ((ext-type (find (class-of obj) *extended-types* :test #'eq @@ -572,14 +598,50 @@ (encode-integer id s)) id)) (len (length bytes))) - ;; TODO: in theory the ID might be longer than 256 bytes... + ;; in theory the ID might be longer than 256 bytes... ;; (encode-sequence-length bytes stream #xc7 0 #xc8 #xc9) ;; but we need the type inbetween. - (assert (<= 0 len #xff)) - (write-byte #xc7 stream) - (write-byte len stream) - (write-byte (type-number ext-type) stream) - (write-sequence bytes stream)) + (cond ((= len 1) + (encode-fix-ext #xd4 + (type-number ext-type) + bytes + stream)) + ((= len 2) + (encode-fix-ext #xd5 + (type-number ext-type) + bytes + stream)) + ((= len 4) + (encode-fix-ext #xd6 + (type-number ext-type) + bytes + stream)) + ((= len 8) + (encode-fix-ext #xd7 + (type-number ext-type) + bytes + stream)) + ((= len 16) + (encode-fix-ext #xd8 + (type-number ext-type) + bytes + stream)) + ((< len 256) + (encode-ext8 len + (type-number ext-type) + bytes + stream)) + ((< len 65536) + (encode-ext16 len + (type-number ext-type) + bytes + stream)) + ((< len 4294967296) + (encode-ext32 len + (type-number ext-type) + bytes + stream)) + (t (error "array length is too large.")))) T))) diff --git a/tests.lisp b/tests.lisp index 1325a08..04957da 100644 --- a/tests.lisp +++ b/tests.lisp @@ -68,7 +68,7 @@ since I am interested in using msgpack as a binary JSON). Use strings of various lengths to make sure string length is encoded properly." (is (equalp #(#xAB #x54 #x65 #x73 #x74 #x20 #x73 #x74 #x72 #x69 #x6E #x67) (mpk:encode "Test string"))) - (is (equalp #(#xDA #x00 #x3C #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 + (is (equalp #(#xD9 #x3C #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67 #x73 #x74 #x72 #x69 #x6E #x67) @@ -149,8 +149,14 @@ encode properly." (let ((mpk:*extended-types* (mpk:define-extension-types '(7 type1)))) - (is (equalp #(#xC7 #x01 #x07 #x09) - (mpk:encode (make-instance 'type1 'messagepack-sym:id 9)))))) + (is (equalp #(#xd4 #x07 #x09) + (mpk:encode (make-instance 'type1 'messagepack-sym:id #(9))))) + (is (equalp #(#xd5 #x07 #x01 #x02) + (mpk:encode (make-instance 'type1 'messagepack-sym:id #(1 2))))) + (is (equalp #(#xc7 #x03 #x07 #x01 #x02 #x03) + (mpk:encode (make-instance 'type1 'messagepack-sym:id #(1 2 3))))) + (is (equalp #(#xd6 #x07 #x01 #x02 #x03 #x04) + (mpk:encode (make-instance 'type1 'messagepack-sym:id #(1 2 3 4))))))) (test decoding-integers "Test that (equalp (decode (encode data)) data) for integers (that