;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
-;;; Confidential and proprietary information of ITA Software, Inc. ;;;
+;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
(reinitialize-object object message)))
(defmethod reinitialize-object (object (message protobuf-message))
- (macrolet ((write-slot (object slot writer value)
- `(if ,writer
- (funcall ,writer ,object ,value)
- (setf (slot-value ,object ,slot) ,value))))
- (dolist (field (proto-fields message))
- (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
- (default (protobuf-default-to-clos-init (proto-default field) type))
- (slot (proto-value field))
- (writer (proto-writer field)))
- (cond ((null slot))
- ((or (eq (proto-required field) :required)
- (eq type :bool))
- (if (proto-default field)
- (write-slot object slot writer default)
- (slot-makunbound object slot)))
- (t
- (write-slot object slot writer default))))))
+ (dolist (field (proto-fields message))
+ (reinitialize-field object message field))
object)
+(defgeneric reinitialize-field (object message field)
+ (:method (object (message protobuf-message) field)
+ (macrolet ((write-slot (object slot writer value)
+ `(if ,writer
+ (funcall ,writer ,object ,value)
+ (setf (slot-value ,object ,slot) ,value))))
+ (let ((default (proto-default field))
+ (slot (proto-value field))
+ (writer (proto-writer field)))
+ (cond ((null slot)
+ (unless (empty-default-p field)
+ (write-slot object slot writer default)))
+ (t
+ (if (empty-default-p field)
+ (slot-makunbound object slot)
+ (write-slot object slot writer default))))))))
+
+(defgeneric reinitialize-slot (object message slot)
+ (:method (object (message protobuf-message) slot)
+ (let ((field (find slot (proto-fields message) :key #'proto-value)))
+ (reinitialize-field object message field))))
+
\f
;;; A Python-like, Protobufs2-compatible API
(: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)
(object-initialized-p object message))))
+(defgeneric clear (object)
+ (:documentation
+ "Initialize all of the fields of 'object' to their default values.")
+ (:method ((object standard-object))
+ (let* ((class (type-of object))
+ (message (find-message-for-class class)))
+ (assert message ()
+ "There is no Protobufs message for the class ~S" class)
+ (reinitialize-object object message))))
+
(defgeneric has-field (object slot)
(: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)
(slot-initialized-p object message slot))))
-(defgeneric clear (object)
+(defgeneric clear-field (object slot)
(:documentation
- "Initialize all of the fields of 'object' to their default values.")
- (:method ((object standard-object))
- (let* ((class (class-of object))
+ "Initialize the field 'slot' of 'object' to its default value.")
+ (:method ((object standard-object) slot)
+ (let* ((class (type-of object))
(message (find-message-for-class class)))
(assert message ()
"There is no Protobufs message for the class ~S" class)
- (reinitialize-object object message))))
+ (reinitialize-slot object message slot))))
;; This is simpler than 'object-size', but doesn't fully support aliasing
(defgeneric octet-size (object)
"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 ()
"There is no Protobufs message for the class ~S" class)
- (let ((visited (make-hash-table)))
+ (let ((visited (make-size-cache object type)))
(object-size object type visited)))))
;; This is simpler than 'serialize-object', but doesn't fully support aliasing
(:documentation
"Serialize 'object' into 'buffer' using the wire format, starting at the index
'start' and going no farther than 'end'. 'object' is an object whose Lisp class
- corresponds to a Protobufs message.")
+ corresponds to a Protobufs message.
+ Returns two values, the final index and the buffer.")
(: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 ()
"There is no Protobufs message for the class ~S" class)
- (let* ((visited (make-hash-table))
+ (let* ((visited (make-size-cache object type))
(size (object-size object type visited))
(start (or start 0))
- (buffer (or buffer (make-array size :element-type '(unsigned-byte 8)))))
+ (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))
+ (values nend 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)
- ;;--- Do this
- type)))
+ (assert (eq class (type-of source)) ()
+ "The objects ~S and ~S are of not of the same class" object source)
+ ;;--- Do this (should return side-effected 'object', not 'source')
+ type
+ source)))
projects / cl-protobufs.git / blobdiff