From 67fc7299fb7bdabd6bf5edd3cabc9611467c14f0 Mon Sep 17 00:00:00 2001 From: Scott McKay Date: Fri, 25 May 2012 14:46:50 +0000 Subject: [PATCH] Fix a few more things discovered by the tests: - 'reinitialize-slot' didn't quite work. - Add a geodata example that uses vectors for repeated fields, which uncovered a bug in the optimized deserializers. - Importing the geodata CLOS classes revealed a bug in default handling when the default is provided only in 'defclass'. - Fix the knock-on bug in deserialization and the optimized (de)serialization caused the above. - Add tighter types in 'decode-uint32' and 'decode-uint64'. Passes 'precheckin'. Even with the new unit tests in place. git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/quux/protobufs@545865 f8382938-511b-0410-9cdd-bb47b084005c --- api.lisp | 14 +++-- asdf-support.lisp | 4 +- clos-transform.lisp | 16 ++--- define-proto.lisp | 2 +- examples.lisp | 60 ++++++++++++------ model-classes.lisp | 12 +++- printer.lisp | 17 ++++- serialize.lisp | 10 +-- tests/quick-tests.lisp | 139 +++++++++++++++++++++++------------------ wire-format.lisp | 32 +++++----- 10 files changed, 187 insertions(+), 119 deletions(-) diff --git a/api.lisp b/api.lisp index 4055e4c..9faffff 100644 --- a/api.lisp +++ b/api.lisp @@ -110,10 +110,10 @@ (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) @@ -129,9 +129,9 @@ (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))) ;;; A Python-like, Protobufs2-compatible API @@ -209,8 +209,10 @@ (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 diff --git a/asdf-support.lisp b/asdf-support.lisp index 095d583..c971468 100644 --- a/asdf-support.lisp +++ b/asdf-support.lisp @@ -43,7 +43,9 @@ (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) diff --git a/clos-transform.lisp b/clos-transform.lisp index c90793b..7c2b8f9 100644 --- a/clos-transform.lisp +++ b/clos-transform.lisp @@ -164,14 +164,14 @@ :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))))))) diff --git a/define-proto.lisp b/define-proto.lisp index 959cf8e..ffbba3f 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -471,7 +471,7 @@ `(: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) diff --git a/examples.lisp b/examples.lisp index 8cdcecf..d24306b 100644 --- a/examples.lisp +++ b/examples.lisp @@ -40,27 +40,35 @@ #|| ;; 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))) @@ -71,7 +79,12 @@ :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 @@ -83,8 +96,8 @@ 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)))) @@ -95,6 +108,15 @@ (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) ||# diff --git a/model-classes.lisp b/model-classes.lisp index 0efc1ea..aa10dd2 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -501,11 +501,19 @@ (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 diff --git a/printer.lisp b/printer.lisp index 0917015..7d2882f 100644 --- a/printer.lisp +++ b/printer.lisp @@ -233,7 +233,14 @@ (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) @@ -553,7 +560,13 @@ (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) diff --git a/serialize.lisp b/serialize.lisp index 30690ce..93db43f 100644 --- a/serialize.lisp +++ b/serialize.lisp @@ -273,7 +273,7 @@ (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) @@ -521,7 +521,7 @@ (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))) @@ -654,7 +654,7 @@ (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)))) @@ -758,7 +758,7 @@ 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 @@ -801,7 +801,7 @@ (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))) diff --git a/tests/quick-tests.lisp b/tests/quick-tests.lisp index 897e10f..bb84151 100644 --- a/tests/quick-tests.lisp +++ b/tests/quick-tests.lisp @@ -16,10 +16,10 @@ (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' @@ -41,11 +41,11 @@ (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")) @@ -54,7 +54,7 @@ ;; 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) @@ -67,102 +67,121 @@ (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 @@ -173,12 +192,12 @@ (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) diff --git a/wire-format.lisp b/wire-format.lisp index 195dac3..6d3bfc9 100644 --- a/wire-format.lisp +++ b/wire-format.lisp @@ -951,15 +951,16 @@ (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. @@ -969,12 +970,13 @@ (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. -- 2.45.2