;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
-;;; 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 (proto-default field))
- (slot (proto-value field))
- (writer (proto-writer field)))
- (cond ((null slot))
- ((or (eq (proto-required field) :required)
- (eq type :bool))
- (if default
- (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
"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.")
"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))
+ "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)
(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 (type-of object))
(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))))))
(defgeneric merge-from-array (object buffer &optional start end)
(:documentation
"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
+ ;;--- Do this (should return side-effected 'object', not 'source')
type
- object)))
+ source)))