(defmethod reinitialize-object (object (message protobuf-message))
(dolist (field (proto-fields message))
- (reinitialize-field object field message))
+ (reinitialize-field object message field))
object)
-(defmethod reinitialize-field (object field (message protobuf-message))
+(defmethod reinitialize-field (object (message protobuf-message) field)
(macrolet ((write-slot (object slot writer value)
`(if ,writer
(funcall ,writer ,object ,value)
(slot-makunbound object slot)
(write-slot object slot writer default)))))))
-(defmethod reinitialize-slot (object slot (message protobuf-message))
+(defmethod reinitialize-slot (object (message protobuf-message) slot)
(let ((field (find slot (proto-fields message) :key #'proto-value)))
- (reinitialize-field object field message)))
+ (reinitialize-field object message field)))
\f
;;; A Python-like, Protobufs2-compatible API
(buffer (or buffer (make-byte-vector size))))
(assert (>= (length buffer) size) ()
"The buffer ~S is not large enough to hold ~S" buffer object)
- (serialize-object object type buffer start visited)
- buffer))))
+ (multiple-value-bind (nbuf nend)
+ (serialize-object object type buffer start visited)
+ (declare (ignore nbuf))
+ nend)))))
(defgeneric merge-from-array (object buffer &optional start end)
(:documentation
(let ((schema (parse-schema-from-file protobuf-file)))
(with-open-file (stream lisp-file
:direction :output
- :if-exists :supersede)
+ :if-exists :supersede
+ :external-format :utf-8
+ :element-type 'character)
(write-schema schema :stream stream :type :lisp)))
lisp-file)
:type (if enum (class-name->proto ename) type)
:class (if enum etype pclass)
:required reqd
- :index index
- :value (slot-definition-name slot)
- :reader (let ((reader (find-slot-definition-reader class slot)))
- ;; Only use the reader if it is "interesting"
- (unless (string= (symbol-name reader)
- (format nil "~A-~A"
- (class-name class) (slot-definition-name slot)))
- reader))
+ :index index
+ :value (slot-definition-name slot)
+ :reader (let ((reader (find-slot-definition-reader class slot)))
+ ;; Only use the reader if it is "interesting"
+ (unless (string= (symbol-name reader)
+ (format nil "~A-~A"
+ (class-name class) (slot-definition-name slot)))
+ reader))
:default default
:packed packed)))
(values field nil enum)))))))
`(:type (list-of ,type)
:initform ())))
,@(and reader
- `(:reader ,reader))
+ `(:accessor ,reader))
:initarg ,(kintern (symbol-name slot)))))
(mfield (make-instance 'protobuf-field
:name (slot-name->proto slot)
#||
;; A pretty useful subset of geographic business data
(defclass geodata ()
+ ;; This one stores the data in lists
((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries)
(regions :type (proto:list-of qres-core::region) :initform () :initarg :regions)
(cities :type (proto:list-of qres-core::city) :initform () :initarg :cities)
(airports :type (proto:list-of qres-core::airport) :initform () :initarg :airports)))
-(setq bizd-schema (proto:generate-schema-for-classes
- '(qres-core::country
- qres-core::region
- qres-core::region-key
- qres-core::city
- qres-core::airport
- qres-core::timezone
- qres-core::tz-variation
- qres-core::currency
- qres-core::country-currencies
- qres-core::carrier
- geodata)
- :install t))
-
-(proto:write-schema bizd-schema)
-(proto:write-schema bizd-schema :type :lisp)
+(defclass geodata-v ()
+ ;; This one stores the data in vectors
+ ((countries :type (proto:vector-of qres-core::country) :initform #() :initarg :countries)
+ (regions :type (proto:vector-of qres-core::region) :initform #() :initarg :regions)
+ (cities :type (proto:vector-of qres-core::city) :initform #() :initarg :cities)
+ (airports :type (proto:vector-of qres-core::airport) :initform #() :initarg :airports)))
+
+(setq *geodata* (proto:generate-schema-for-classes
+ '(qres-core::country
+ qres-core::region
+ qres-core::region-key
+ qres-core::city
+ qres-core::airport
+ qres-core::timezone
+ qres-core::tz-variation
+ qres-core::currency
+ qres-core::country-currencies
+ qres-core::carrier
+ geodata geodata-v)
+ :install t))
+
+(proto:write-schema *geodata*)
+(proto:write-schema *geodata* :type :lisp)
;; Load the data
(let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v)))
:countries countries
:regions regions
:cities cities
- :airports airports)))
+ :airports airports)
+ geodata-v (make-instance 'geodata-v
+ :countries (make-array (length countries) :fill-pointer t :initial-contents countries)
+ :regions (make-array (length regions) :fill-pointer t :initial-contents regions)
+ :cities (make-array (length cities) :fill-pointer t :initial-contents cities)
+ :airports (make-array (length airports) :fill-pointer t :initial-contents airports))))
(dolist (class '(qres-core::country
qres-core::region
qres-core::currency
qres-core::country-currencies
qres-core::carrier
- geodata))
- (let ((message (proto-impl:find-message bizd-schema class)))
+ geodata geodata-v))
+ (let ((message (proto-impl:find-message *geodata* class)))
(eval (proto-impl:generate-object-size message))
(eval (proto-impl:generate-serializer message))
(eval (proto-impl:generate-deserializer message))))
(equalp gser (proto:serialize-object-to-stream
(proto:deserialize-object 'geodata gser)
'geodata :stream nil))
+
+(time (progn (setq gser-v (proto:serialize-object-to-stream geodata-v 'geodata-v :stream nil)) nil))
+(time (proto:deserialize-object 'geodata-v gser-v))
+
+(equalp gser-v (proto:serialize-object-to-stream
+ (proto:deserialize-object 'geodata-v gser-v)
+ 'geodata-v :stream nil))
+
+(equalp gser gser-v)
||#
(eq (proto-message-type f) :group)
(eq (proto-message-type f) :extends))))
-(defmethod empty-default-p (field)
+(defmethod empty-default-p ((field protobuf-field))
(let ((default (proto-default field)))
(or (eq default $empty-default)
(eq default $empty-list)
- (eq default $empty-vector))))
+ (eq default $empty-vector)
+ ;; Special handling for imported CLOS classes
+ (and (not (eq (proto-required field) :optional))
+ (or (null default) (equal default #()))))))
+
+(defmethod vector-field-p ((field protobuf-field))
+ (let ((default (proto-default field)))
+ (or (eq default $empty-vector)
+ (and (vectorp default) (not (stringp default))))))
;; An extension range within a message
(and (not (zerop indentation)) indentation) required)
(write-schema-as :proto msg stream :indentation indentation :index index :arity required))
(t
- (let* ((defaultp (not (empty-default-p field)))
+ (let* ((defaultp (if (proto-alias-for message)
+ ;; Special handling for imported CLOS classes
+ (if (eq (proto-required field) :optional)
+ nil
+ (and (proto-default field)
+ (not (equalp (proto-default field) #()))
+ (not (empty-default-p field))))
+ (not (empty-default-p field))))
(default (proto-default field))
(default (and defaultp
(cond ((and (typep msg 'protobuf-enum)
(eq (proto-message-type msg) :group))
(write-schema-as :lisp msg stream :indentation indentation :index index :arity required))
(t
- (let* ((defaultp (not (empty-default-p field)))
+ (let* ((defaultp (if (proto-alias-for message)
+ (if (eq (proto-required field) :optional)
+ nil
+ (and (proto-default field)
+ (not (equalp (proto-default field) #()))
+ (not (empty-default-p field))))
+ (not (empty-default-p field))))
(default (proto-default field))
(default (and defaultp
(cond ((and (typep msg 'protobuf-enum)
(setq index (skip-element buffer index tag))
;;--- Check for mismatched wire type, running past end of buffer, etc
(cond ((and field (eq (proto-required field) :repeated))
- (let ((vectorp (eq (proto-default field) $empty-vector)))
+ (let ((vectorp (vector-field-p field)))
(cond ((and (proto-packed field) (packed-type-p type))
(multiple-value-bind (values idx)
(deserialize-packed type buffer index)
(index (proto-index field)))
(when reader
(cond ((eq (proto-required field) :repeated)
- (let ((iterator (if (eq (proto-default field) $empty-vector) 'dovector 'dolist)))
+ (let ((iterator (if (vector-field-p field) 'dovector 'dolist)))
(cond ((and (proto-packed field) (packed-type-p class))
(collect-serializer
(let ((tag (make-tag class index)))
(multiple-value-bind (,vval idx)
(deserialize-packed ,class ,vbuf ,vidx)
(setq ,vidx idx)
- ,@(when (eq (proto-default field) $empty-vector)
+ ,@(when (vector-field-p field)
`((setq ,vval (make-array (length ,vval)
:fill-pointer t :adjustable t
:initial-contents ,vval))))
for temp in rtemps
as slot = (proto-value field)
as writer = (proto-writer field)
- collect (cond ((eq (proto-default field) $empty-vector)
+ collect (cond ((vector-field-p field)
(if writer
`(funcall ,writer ,vobj (make-array (length ,temp)
:fill-pointer t :adjustable t
(index (proto-index field)))
(when reader
(cond ((eq (proto-required field) :repeated)
- (let ((iterator (if (eq (proto-default field) $empty-vector) 'dovector 'dolist)))
+ (let ((iterator (if (vector-field-p field) 'dovector 'dolist)))
(cond ((and (proto-packed field) (packed-type-p class))
(collect-sizer
(let ((tag (make-tag class index)))
(defvar *golden-directory*
#.(make-pathname
- :directory (pathname-directory (or *compile-file-truename* *load-truename*))))
+ :directory (pathname-directory (or *load-truename* *compile-file-truename*))))
-(defvar *golden-pathname* (merge-pathnames "golden.data" *golden-directory*)
-(defvar *serial-pathname* (merge-pathnames "serialized.data" *golden-directory*)
+(defvar *golden-pathname* (merge-pathnames "golden.data" *golden-directory*))
+(defvar *serial-pathname* (merge-pathnames "serialized.data" *golden-directory*))
(qtest:define-test default-and-clear ()
;; Check that required strings are made unbound by 'clear'
(proto:clear p)
(qtest:assert-true (string-equal (pbtest::opt-string p) "opt"))
(setf (pbtest::opt-string p) "x")
- (proto:clear-field p 'opt-string)
+ (proto:clear-field p 'pbtest::opt-string)
(qtest:assert-true (string-equal (pbtest::opt-string p) "opt"))))
(qtest:define-test test-pb-write ()
- (let ((p (make-instance 'pbtest::test1-proto)))
+ (let ((p (make-instance 'pbtest::test1proto)))
;; Default settings
(qtest:assert-equal (pbtest::d-int32 p) 12)
(qtest:assert-true (string-equal (pbtest::d-string p) "foo"))
;; Test is-initialized
(qtest:assert-false (pbtest::is-initialized p))
(setf (pbtest::o-a p) 20)
- (qtest:assert-true (pbtest::is-initialized p))
+ (qtest:assert-false (pbtest::is-initialized p))
;; Set some unrepeated things
(setf (pbtest::u-int32 p) 20)
(setf (pbtest::u-double p) 3.14159265d0)
(setf (pbtest::u-string p) "foo")
(setf (pbtest::u-vardata p) "bar")
+ (setf (pbtest::u-msg p) (make-instance 'pbtest::test1msg))
(setf (pbtest::foo (pbtest::u-msg p)) 12)
+ (qtest:assert-true (pbtest::is-initialized p))
;; Set some repeated things
- (PUSH -20 (pbtest::r-int32 p))
- (PUSH -30 (pbtest::r-int32 p))
- (PUSH 20 (pbtest::r-int64 p))
- (PUSH 30 (pbtest::r-int64 p))
- (PUSH 12345678900 (pbtest::r-uint64 p))
- (PUSH 98765432100 (pbtest::r-uint64 p))
- (PUSH 12345 (pbtest::r-fixed32 p))
- (PUSH 23456 (pbtest::r-fixed32 p))
- (PUSH 12345678900 (pbtest::r-fixed64 p))
- (PUSH 98765432100 (pbtest::r-fixed64 p))
- (PUSH nil (pbtest::r-bool p))
- (PUSH t (pbtest::r-bool p))
- (PUSH 1.5f0 (pbtest::r-float p))
- (PUSH -1.75f0 (pbtest::r-float p))
- (PUSH 3.3d0 (pbtest::r-double p))
- (PUSH -1.2d0 (pbtest::r-double p))
- (PUSH "foo" (pbtest::r-string p))
- (PUSH "bar" (pbtest::r-string p))
- (PUSH "ping" (pbtest::r-vardata p))
- (PUSH "pong" (pbtest::r-vardata p))
-
- (let ((x (make-instance 'pbtest::test1-msg))
- (y (make-instance 'pbtest::test1-msg)))
+ (push -30 (pbtest::r-int32 p))
+ (push -20 (pbtest::r-int32 p))
+
+ (push 30 (pbtest::r-int64 p))
+ (push 20 (pbtest::r-int64 p))
+
+ (push 98765432100 (pbtest::r-uint64 p))
+ (push 12345678900 (pbtest::r-uint64 p))
+
+ (push 23456 (pbtest::r-fixed32 p))
+ (push 12345 (pbtest::r-fixed32 p))
+
+ (push 98765432100 (pbtest::r-fixed64 p))
+ (push 12345678900 (pbtest::r-fixed64 p))
+
+ (push t (pbtest::r-bool p))
+ (push nil (pbtest::r-bool p))
+
+ (push -1.75f0 (pbtest::r-float p))
+ (push 1.5f0 (pbtest::r-float p))
+
+ (push -1.2d0 (pbtest::r-double p))
+ (push 3.3d0 (pbtest::r-double p))
+
+ (push "bar" (pbtest::r-string p))
+ (push "foo" (pbtest::r-string p))
+
+ (push "pong" (pbtest::r-vardata p))
+ (push "ping" (pbtest::r-vardata p))
+
+ (let ((x (make-instance 'pbtest::test1msg))
+ (y (make-instance 'pbtest::test1msg)))
(setf (pbtest::foo x) 12)
(setf (pbtest::foo y) 13)
- (PUSH x (pbtest::r-msg p))
- (PUSH y (pbtest::r-msg p)))
+ (push y (pbtest::r-msg p))
+ (push x (pbtest::r-msg p)))
- (let ((x (make-instance 'pbtest::test1-proto-test-group1))
- (y (make-instance 'pbtest::test1-proto-test-group2))
- (z (make-instance 'pbtest::test1-proto-test-group2)))
+ (let ((x (make-instance 'pbtest::test-group1))
+ (y (make-instance 'pbtest::test-group2))
+ (z (make-instance 'pbtest::test-group2)))
(setf (pbtest::a x) 80)
(setf (pbtest::b y) 100)
(setf (pbtest::b z) 130)
- (PUSH x (pbtest::test-group1 p))
- (PUSH y (pbtest::test-group2 p))
- (PUSH z (pbtest::test-group2 p)))
+ (push z (pbtest::test-group2 p))
+ (push y (pbtest::test-group2 p))
+ (push x (pbtest::test-group1 p)))
;; int32 tests
(loop for x in (list (1- (ash 1 31)) (- (ash 1 31)) 1 0 -1)
- do (PUSH x (pbtest::r-int32 p)))
+ do (setf (pbtest::r-int32 p) (append (pbtest::r-int32 p) (list x))))
;; int64 tests
(loop for x in (list (1- (ash 1 63)) (- (ash 1 63)) 1 0 -1)
- do (PUSH x (pbtest::r-int64 p)))
+ do (setf (pbtest::r-int64 p) (append (pbtest::r-int64 p) (list x))))
;; fixed32 tests
(loop for x in (list #xffffffff (1- (ash 1 31)) 0 1)
- do (PUSH x (pbtest::r-fixed32 p)))
+ do (setf (pbtest::r-fixed32 p) (append (pbtest::r-fixed32 p) (list x))))
;; fixed64 tests
(loop for x in (list #xffffffffffffffff (1- (ash 1 63)) 0 1)
- do (PUSH x (pbtest::r-fixed64 p)))
+ do (setf (pbtest::r-fixed64 p) (append (pbtest::r-fixed64 p) (list x))))
;; uint64 tests
(loop for x in (list (1- (ash 1 64)) (1- (ash 1 63)) 0 1)
- do (PUSH x (pbtest::r-uint64 p)))
+ do (setf (pbtest::r-uint64 p) (append (pbtest::r-uint64 p) (list x))))
;; write buffer to a file
(let ((size (proto:octet-size p)))
- (let* ((output-buffer (make-byte-vector size))
- (end (proto:serialize p output-buffer 0 size)))
+ (let* ((buffer (make-byte-vector size))
+ (end (proto:serialize p buffer 0 size)))
(qtest:assert-equal end size)
- (with-open-file (output-stream +test-file-name+ :direction :output
- :if-exists :supersede :element-type 'unsigned-byte)
- (write-sequence output-buffer output-stream)))
+ (with-open-file (output-stream *serial-pathname*
+ :direction :output
+ :if-exists :supersede
+ :element-type '(unsigned-byte 8))
+ (write-sequence buffer output-stream)))
;; check against the golden data
- (with-open-file (golden-input +golden-file-name+ :direction :input
- :element-type 'unsigned-byte)
+ (with-open-file (golden-input *golden-pathname*
+ :direction :input
+ :element-type '(unsigned-byte 8))
(qtest:assert-equal (file-length golden-input) size)
- (with-open-file (test-input +test-file-name+ :direction :input
- :element-type 'unsigned-byte)
+ (with-open-file (test-input *serial-pathname*
+ :direction :input
+ :element-type '(unsigned-byte 8))
(qtest:assert-equal (file-length test-input) size)
- (let ((golden-buffer (make-byte-vector size))
+ (let ((golden-buffer (make-byte-vector (file-length test-input)))
(test-buffer (make-byte-vector size)))
(read-sequence golden-buffer golden-input)
(read-sequence test-buffer test-input)
- (qtest:assert-true (equalp golden-buffer test-buffer))))))
+ (qtest:assert-true (equalp golden-buffer test-buffer))
+ (DESCRIBE P)
+ (DESCRIBE (DESERIALIZE-OBJECT (TYPE-OF P) TEST-BUFFER))
+ (DESCRIBE (DESERIALIZE-OBJECT (TYPE-OF P) GOLDEN-BUFFER))))))
;; clean up
- (delete-file +test-file-name+)))
+ (delete-file *serial-pathname*)))
(qtest:define-test test-pb-read ()
(let ((p (make-instance 'pbtest::Test1-Proto)))
- (with-open-file (golden-input +golden-file-name+ :direction :input
- :element-type 'unsigned-byte)
+ (with-open-file (golden-input *golden-pathname*
+ :direction :input
+ :element-type '(unsigned-byte 8))
(let* ((size (file-length golden-input))
(buffer (make-byte-vector size)))
(read-sequence buffer golden-input)
(qtest:assert-equal (proto:merge-from-array p buffer 0 size) size)))
- (flet ((test-repeated (value golden))
+ (flet ((test-repeated (value golden)
(let ((golden-size (length golden)))
(qtest:assert-equal (length value) golden-size)
(loop for v across value
(qtest:assert-equal v g))
((and (numberp v) (numberp g)) (qtest:assert-equal v g))
((and (arrayp v) (arrayp g)) (qtest:assert-true (equalp v g)))
- (t (assert (progn "type mismatch" nil)))))))
+ (t (assert (progn "type mismatch" nil))))))))
;; unrepeated things
- (qtest:assert-true (pbtest::has-o-a p))
+ (qtest:assert-true (proto:has-field p 'pbtest::o-a))
(qtest:assert-equal (pbtest::o-a p) 20)
- (qtest:assert-false (pbtest::has-o-b p))
+ (qtest:assert-false (proto:has-field p 'pbtest::o-b))
(qtest:assert-equal (pbtest::u-int32 p) 20)
(qtest:assert-equal (pbtest::u-int64 p) -20)
(qtest:assert-equal (pbtest::u-uint64 p) 12345678900)
(declare (type (simple-array (unsigned-byte 8)) buffer)
(type fixnum index))
;; Seven bits at a time, least significant bits first
- (loop with val fixnum = 0
- for places fixnum upfrom 0 by 7
- for byte fixnum = (prog1 (aref buffer index) (iincf index))
- do (setq val (ilogior val (iash (ildb (byte 7 0) byte) places)))
- until (i< byte 128)
- finally (progn
- (assert (< val #.(ash 1 32)) ()
- "The value ~D is longer than 32 bits" val)
- (return (values val index)))))
+ (let ((val 0))
+ (declare (type (unsigned-byte 32) val))
+ (loop for places fixnum upfrom 0 by 7
+ for byte fixnum = (prog1 (aref buffer index) (iincf index))
+ do (setq val (ilogior val (iash (ildb (byte 7 0) byte) places)))
+ until (i< byte 128)
+ finally (progn
+ (assert (< val #.(ash 1 32)) ()
+ "The value ~D is longer than 32 bits" val)
+ (return (values val index))))))
(defun decode-uint64 (buffer index)
"Decodes the next 64-bit varint integer in the buffer at the given index.
(declare (type (simple-array (unsigned-byte 8)) buffer)
(type fixnum index))
;; Seven bits at a time, least significant bits first
- (loop with val = 0
- for places fixnum upfrom 0 by 7
- for byte fixnum = (prog1 (aref buffer index) (iincf index))
- do (setq val (logior val (ash (ildb (byte 7 0) byte) places)))
- until (i< byte 128)
- finally (return (values val index))))
+ (let ((val 0))
+ (declare (type (unsigned-byte 64) val))
+ (loop for places fixnum upfrom 0 by 7
+ for byte fixnum = (prog1 (aref buffer index) (iincf index))
+ do (setq val (logior val (ash (ildb (byte 7 0) byte) places)))
+ until (i< byte 128)
+ finally (return (values val index)))))
(defun decode-int32 (buffer index)
"Decodes the next 32-bit varint integer in the buffer at the given index.
projects / cl-protobufs.git / commitdiff