From: Scott McKay Date: Thu, 10 May 2012 21:14:58 +0000 (+0000) Subject: Fix some problems reported by Shaun Morris: X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=commitdiff_plain;h=dd5f03421989dc78753cf91904a023d7430f74d3;p=cl-protobufs.git Fix some problems reported by Shaun Morris: - Looks like Stubby will need 'merge-from-array', make room for that. - Text format deserializer didn't correctly parse negative integers. - Simply 'deserialize-object' a bit - Fix a bug in the 'deserialize-object' that caused it not to work correctly on extended fields. - Fix a sloppy bug in 'make-tag' that only showed up in SBCL. - Add a few more examples, soon to be part of a test suite. Passes 'precheckin'. Passes my by-hand tests. git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/quux/protobufs@543418 f8382938-511b-0410-9cdd-bb47b084005c --- diff --git a/api.lisp b/api.lisp index 006d5eb..95de254 100644 --- a/api.lisp +++ b/api.lisp @@ -135,7 +135,7 @@ (:documentation "Returns true iff all of the fields of 'object' are initialized.") (:method ((object standard-object)) - (let* ((class (class-of object)) + (let* ((class (type-of object)) (message (find-message-for-class class))) (assert message () "There is no Protobufs message for the class ~S" class) @@ -145,7 +145,7 @@ (:documentation "Returns true iff the field 'slot' in 'object' is initialized.") (:method ((object standard-object) slot) - (let* ((class (class-of object)) + (let* ((class (type-of object)) (message (find-message-for-class class))) (assert message () "There is no Protobufs message for the class ~S" class) @@ -155,7 +155,7 @@ (:documentation "Initialize all of the fields of 'object' to their default values.") (:method ((object standard-object)) - (let* ((class (class-of object)) + (let* ((class (type-of object)) (message (find-message-for-class class))) (assert message () "There is no Protobufs message for the class ~S" class) @@ -167,7 +167,7 @@ "Returns the number of octets required to encode 'object' using the wire format. 'object' is an object whose Lisp class corresponds to a Protobufs message.") (:method ((object standard-object)) - (let* ((class (class-of object)) + (let* ((class (type-of object)) (message (find-message-for-class class)) (type (and message (proto-class message)))) (assert message () @@ -183,7 +183,7 @@ corresponds to a Protobufs message.") (:method ((object standard-object) &optional buffer (start 0) end) (declare (ignore end)) - (let* ((class (class-of object)) + (let* ((class (type-of object)) (message (find-message-for-class class)) (type (and message (proto-class message)))) (assert message () @@ -197,32 +197,38 @@ (serialize-object object type buffer start visited) buffer)))) -;; This is simpler than 'deserialize-object', but doesn't fully support aliasing (defgeneric merge-from-array (object buffer &optional start end) (:documentation - "Deserialize the object encoded in 'buffer' into 'object', starting at the index - 'start' and ending at 'end'. 'object' is an object whose Lisp class corresponds - to a Protobufs message.") + "Deserialize the object encoded in 'buffer' and merge it into 'object'. + Deserialization starts at the index 'start' and ends at 'end'. + 'object' must an object whose Lisp class corresponds to the message + being deserialized. + The return value is the updated object.") (:method ((object standard-object) buffer &optional (start 0) (end (length buffer))) - (let* ((class (class-of object)) + (let* ((class (type-of object)) (message (find-message-for-class class)) (type (and message (proto-class message)))) (assert message () "There is no Protobufs message for the class ~S" class) (let* ((start (or start 0)) (end (or end (length buffer)))) - (deserialize-object type buffer start end))))) + (merge-from-message object (deserialize-object type buffer start end)))))) -(defgeneric merge-from-message (object source-object) +(defgeneric merge-from-message (object source) (:documentation - "") - (:method ((object standard-object) (source-object standard-object)) - (let* ((class (class-of object)) + "Merge the fields from the source object 'source' into 'object'. + The two objects must be of the same type. + Singular fields will be overwritten, with embedded messages being be merged. + Repeated fields will be concatenated. + The return value is the updated object 'object'.") + (:method ((object standard-object) (source standard-object)) + (let* ((class (type-of object)) (message (find-message-for-class class)) (type (and message (proto-class message)))) - (assert (eq class (class-of source-object)) () - "The objects ~S and ~S are of not of the same class" object source-object) (assert message () "There is no Protobufs message for the class ~S" class) + (assert (eq class (type-of source)) () + "The objects ~S and ~S are of not of the same class" object source) ;;--- Do this - type))) + type + object))) diff --git a/examples.lisp b/examples.lisp index 6b6be6a..98610a3 100644 --- a/examples.lisp +++ b/examples.lisp @@ -551,6 +551,35 @@ service ColorWheel { (proto:parse-text-format 'typed-list :stream s)))) ||# +#|| +(proto:define-proto integrity-test () + (proto:define-message inner () + (i :type (or null integer))) + (proto:define-message outer () + (inner :type (proto:list-of inner)) + (simple :type (or null inner)) + (i :type (or null integer)))) + +(defun integrity-test (message) + (let* ((type (type-of message)) + (buf (proto:serialize-object-to-stream message type :stream nil)) + (new (proto:deserialize-object type buf)) + (newbuf (proto:serialize-object-to-stream new type :stream nil))) + (assert (equalp (length buf) (length newbuf))) + (assert (equalp buf newbuf)) + (assert (string= (with-output-to-string (s) (proto:print-text-format message)) + (with-output-to-string (s) (proto:print-text-format new)))) + new)) + +(integrity-test (make-instance 'outer :i 4)) + +(integrity-test (make-instance 'outer + :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(1 2 3)))) + +(integrity-test (make-instance 'outer + :simple (make-instance 'inner :i 4))) +||# + ;;; Stubby examples diff --git a/parser.lisp b/parser.lisp index 1a08efb..1ff0911 100644 --- a/parser.lisp +++ b/parser.lisp @@ -150,7 +150,16 @@ (skip-whitespace stream) (return (coerce string 'string))))) -(defun parse-int (stream) +(defun parse-signed-int (stream) + "Parse the next token in the stream as an integer, then skip the following whitespace. + The returned value is the integer." + (let* ((sign (if (eql (peek-char nil stream nil) #\-) + (progn (read-char stream) -1) + 1)) + (int (parse-unsigned-int stream))) + (* int sign))) + +(defun parse-unsigned-int (stream) "Parse the next token in the stream as an integer, then skip the following whitespace. The returned value is the integer." (when (digit-char-p (peek-char nil stream nil)) @@ -163,7 +172,8 @@ (return (parse-integer (coerce token 'string))))))) (defun parse-float (stream) - "Parse the next token in the stream as a float, then skip the following whitespace. The returned value is the float." + "Parse the next token in the stream as a float, then skip the following whitespace. + The returned value is the float." (when (let ((ch (peek-char nil stream nil))) (or (digit-char-p ch) (eql ch #\-))) (let ((token (parse-token stream))) @@ -320,7 +330,7 @@ Updates the 'protobuf-enum' object to have the enum value." (check-type enum protobuf-enum) (expect-char stream #\= () "enum") - (let* ((idx (prog1 (parse-int stream) + (let* ((idx (prog1 (parse-signed-int stream) (expect-char stream #\; () "enum") (maybe-skip-comments stream))) (value (make-instance 'protobuf-enum-value @@ -422,7 +432,7 @@ (parse-proto-group stream message required extended-from) (let* ((name (prog1 (parse-token stream) (expect-char stream #\= () "message"))) - (idx (parse-int stream)) + (idx (parse-unsigned-int stream)) (opts (prog1 (parse-proto-field-options stream) (expect-char stream #\; () "message") (maybe-skip-comments stream))) @@ -462,7 +472,7 @@ (let* ((type (prog1 (parse-token stream) (expect-char stream #\= () "message"))) (name (slot-name->proto (proto->slot-name type))) - (idx (parse-int stream)) + (idx (parse-unsigned-int stream)) (msg (parse-proto-message stream message type)) (class (proto->class-name type *protobuf-package*)) (field (make-instance 'protobuf-field @@ -495,10 +505,10 @@ (defun parse-proto-extension (stream message) (check-type message protobuf-message) - (let* ((from (parse-int stream)) + (let* ((from (parse-unsigned-int stream)) (token (parse-token stream)) (to (if (digit-char-p (peek-char nil stream nil)) - (parse-int stream) + (parse-unsigned-int stream) (parse-token stream)))) (expect-char stream #\; () "message") (assert (string= token "to") () diff --git a/serialize.lisp b/serialize.lisp index 206db80..44fa3f2 100644 --- a/serialize.lisp +++ b/serialize.lisp @@ -55,7 +55,7 @@ 'visited' is a hash table used to cache object sizes. The return value is the buffer containing the serialized object.")) -(defmethod serialize-object (object (type symbol) buffer &optional start visited) +(defmethod serialize-object (object type buffer &optional start visited) (let ((message (find-message-for-class type))) (assert message () "There is no Protobuf message having the type ~S" type) @@ -198,7 +198,7 @@ 'end-tag' is used internally to handle the (deprecated) \"group\" feature. The return values are the object and the index at which deserialization stopped..")) -(defmethod deserialize-object ((type symbol) buffer &optional start end (end-tag 0)) +(defmethod deserialize-object (type buffer &optional start end (end-tag 0)) (let ((message (find-message-for-class type))) (assert message () "There is no Protobuf message having the type ~S" type) @@ -215,9 +215,11 @@ (funcall ,reader ,object) (slot-value ,object ,slot))) (write-slot (object slot writer value) - `(if ,writer - (funcall ,writer ,object ,value) - (setf (slot-value ,object ,slot) ,value)))) + (with-gensyms (vval) + `(let ((,vval ,value)) + (if ,writer + (funcall ,writer ,object ,vval) + (setf (slot-value ,object ,slot) ,vval)))))) (labels ((deserialize (type trace end end-tag) (declare (type fixnum end end-tag)) (let* ((message (find-message trace type)) @@ -266,73 +268,65 @@ (multiple-value-bind (values idx) (deserialize-packed type buffer index) (setq index idx) - (when slot - (write-slot object slot writer values)))) + (write-slot object slot writer values))) ((keywordp type) (multiple-value-bind (val idx) (deserialize-prim type buffer index) (setq index idx) - (when slot - (pushnew field rslots) - ;; This "push" will type-check the entire list for - ;; 'quux:list-of', so avoid using that type in classes - ;; in Protobufs if performance is an issue - ;; We'll reverse the slots at the last minute - (write-slot object slot writer - (cons val (read-slot object slot reader)))))) + (pushnew field rslots) + ;; This "push" will type-check the entire list for + ;; 'quux:list-of', so avoid using that type in classes + ;; in Protobufs if performance is an issue + ;; We'll reverse the slots at the last minute + (write-slot object slot writer + (cons val (read-slot object slot reader))))) ((typep (setq msg (and type (or (find-message trace type) (find-enum trace type)))) 'protobuf-message) (if (eq (proto-message-type msg) :group) (let* ((etag (make-tag $wire-type-end-group fidx)) - (obj (deserialize type msg length etag))) - (when slot - (pushnew field rslots) - (write-slot object slot writer - (cons obj (read-slot object slot reader))))) + (obj (deserialize type msg length etag))) + (pushnew field rslots) + (write-slot object slot writer + (cons obj (read-slot object slot reader)))) (multiple-value-bind (len idx) (decode-uint32 buffer index) (setq index idx) (let ((obj (deserialize type msg (+ index len) 0))) - (when slot - (pushnew field rslots) - (write-slot object slot writer - (cons obj (read-slot object slot reader)))))))) + (pushnew field rslots) + (write-slot object slot writer + (cons obj (read-slot object slot reader))))))) ((typep msg 'protobuf-enum) (multiple-value-bind (val idx) (deserialize-enum (proto-values msg) buffer index) (setq index idx) - (when slot - (pushnew field rslots) - (write-slot object slot writer - (cons val (read-slot object slot reader)))))))) + (pushnew field rslots) + (write-slot object slot writer + (cons val (read-slot object slot reader))))))) (t (cond ((keywordp type) (multiple-value-bind (val idx) (deserialize-prim type buffer index) (setq index idx) - (when slot - (write-slot object slot writer val)))) + (write-slot object slot writer val))) ((typep (setq msg (and type (or (find-message trace type) (find-enum trace type)))) 'protobuf-message) + ;;--- If there's already a value in the slot, merge messages (if (eq (proto-message-type msg) :group) (let* ((etag (make-tag $wire-type-end-group fidx)) - (obj (deserialize type msg length etag))) - (when slot - (write-slot object slot writer obj))) + (obj (deserialize type msg length etag))) + (write-slot object slot writer obj)) (multiple-value-bind (len idx) (decode-uint32 buffer index) (setq index idx) (let ((obj (deserialize type msg (+ index len) 0))) - (when slot - (write-slot object slot writer obj)))))) + (write-slot object slot writer obj))))) ((typep msg 'protobuf-enum) (multiple-value-bind (val idx) (deserialize-enum (proto-values msg) buffer index) (setq index idx) - (when slot - (write-slot object slot writer val)))))))))))))) + (write-slot object slot writer val))))))))))))) (declare (dynamic-extent #'deserialize)) (deserialize (proto-class message) message length end-tag))))) @@ -349,7 +343,7 @@ 'visited' is a hash table used to cache object sizes. The return value is the size of the object in bytes.")) -(defmethod object-size (object (type symbol) &optional visited) +(defmethod object-size (object type &optional visited) (let ((message (find-message-for-class type))) (assert message () "There is no Protobuf message having the type ~S" type) @@ -612,19 +606,16 @@ (if (eq (proto-message-type msg) :group) `((,(make-tag $wire-type-start-group index)) (multiple-value-bind (,vval idx) - (deserialize-object ',class ,vbuf ,vidx ,vlen + (deserialize-object ,msg ,vbuf ,vidx ,vlen ,(make-tag $wire-type-end-group index)) (setq ,vidx idx) (push ,vval ,temp))) `((,(make-tag $wire-type-string index)) - ;; Call 'deserialize-object' with the name of the message - ;; class so that we preferentially get any optimized version - ;; of the method (multiple-value-bind (len idx) (decode-uint32 ,vbuf ,vidx) (setq ,vidx idx) (multiple-value-bind (,vval idx) - (deserialize-object ',class ,vbuf ,vidx (i+ ,vidx len) 0) + (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0) (setq ,vidx idx) (push ,vval ,temp)))))))) ((typep msg 'protobuf-enum) @@ -649,7 +640,7 @@ (if (eq (proto-message-type msg) :group) `((,(make-tag $wire-type-start-group index)) (multiple-value-bind (,vval idx) - (deserialize-object ',class ,vbuf ,vidx ,vlen + (deserialize-object ,msg ,vbuf ,vidx ,vlen ,(make-tag $wire-type-end-group index)) (setq ,vidx idx) ,(write-slot vobj field vval))) @@ -658,7 +649,7 @@ (decode-uint32 ,vbuf ,vidx) (setq ,vidx idx) (multiple-value-bind (,vval idx) - (deserialize-object ',class ,vbuf ,vidx (i+ ,vidx len) 0) + (deserialize-object ,msg ,vbuf ,vidx (i+ ,vidx len) 0) (setq ,vidx idx) ,(write-slot vobj field vval))))))) ((typep msg 'protobuf-enum) diff --git a/text-format.lisp b/text-format.lisp index b04b08a..d2ec64b 100644 --- a/text-format.lisp +++ b/text-format.lisp @@ -25,7 +25,7 @@ (defmethod print-text-format (object &optional type &key (stream *standard-output*) (suppress-line-breaks *suppress-line-breaks*)) - (let* ((type (or type (class-of object))) + (let* ((type (or type (type-of object))) (message (find-message-for-class type))) (assert message () "There is no Protobuf message having the type ~S" type) @@ -200,7 +200,7 @@ ((:float :double) (parse-float stream)) ((:string) (parse-string stream)) ((:bool) (if (boolean-true-p (parse-token stream)) t nil)) - (otherwise (parse-int stream))))) + (otherwise (parse-signed-int stream))))) (when slot (pushnew slot rslots) (push val (slot-value object slot))))) @@ -228,7 +228,7 @@ ((:float :double) (parse-float stream)) ((:string) (parse-string stream)) ((:bool) (if (boolean-true-p (parse-token stream)) t nil)) - (otherwise (parse-int stream))))) + (otherwise (parse-signed-int stream))))) (when slot (setf (slot-value object slot) val)))) ((typep (setq msg (and type (or (find-message trace type) diff --git a/wire-format.lisp b/wire-format.lisp index 2b9ec90..e84dc4f 100644 --- a/wire-format.lisp +++ b/wire-format.lisp @@ -32,7 +32,7 @@ return the tag that encodes both of them." (locally (declare (optimize (speed 3) (safety 0) (debug 0))) (if (typep type 'fixnum) - type + (ilogior type (iash index 3)) (let ((type (ecase type ((:int32 :uint32) $wire-type-varint) ((:int64 :uint64) $wire-type-varint)