(: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)
(: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)
(: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)
"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 ()
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 ()
(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)))
(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)))
+||#
+
\f
;;; Stubby examples
(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))
(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)))
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
(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)))
(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
(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") ()
'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)
'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)
(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))
(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)))))
'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)
(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)
(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)))
(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)
(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)
((: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)))))
((: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)
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)
projects / cl-protobufs.git / commitdiff