1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Other API functions
16 (defgeneric object-initialized-p (object type)
18 "Returns true iff all of the fields of 'object' are initialized."))
20 (defmethod object-initialized-p (object (type symbol))
21 (let ((message (find-message-for-class type)))
23 "There is no Protobuf message having the type ~S" type)
24 (object-initialized-p object message)))
26 (defmethod object-initialized-p (object (message protobuf-message))
27 (macrolet ((read-slot (object slot reader)
29 (funcall ,reader ,object)
30 (slot-value ,object ,slot))))
31 (labels ((initialized-p (object trace field)
32 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
33 (slot (proto-value field))
34 (reader (proto-reader field))
37 (cond ((eq (proto-required field) :repeated)
38 ;; We're claiming that empty repeated fields are initialized,
39 ;; which might not be correct
40 (cond ((keywordp type) t)
41 ((typep (setq msg (and type (or (find-message trace type)
42 (find-enum trace type))))
44 (let ((values (read-slot object slot reader)))
45 (dolist (value values t)
46 (unless (every #'(lambda (field)
47 (initialized-p value msg field))
49 (return-from object-initialized-p nil)))))
50 ((typep msg 'protobuf-enum) t)))
52 (cond ((keywordp type)
53 (or (slot-initialized-p object message slot)
54 (return-from object-initialized-p nil)))
55 ((typep (setq msg (and type (or (find-message trace type)
56 (find-enum trace type))))
58 (unless (slot-initialized-p object message slot)
59 (return-from object-initialized-p nil))
60 (let ((value (read-slot object slot reader)))
61 (unless (every #'(lambda (field)
62 (initialized-p value msg field))
64 (return-from object-initialized-p nil))))
65 ((typep msg 'protobuf-enum)
66 (or (slot-initialized-p object message slot)
67 (return-from object-initialized-p nil))))))))))
68 (declare (dynamic-extent #'initialized-p))
69 (every #'(lambda (field)
70 (initialized-p object message field))
71 (proto-fields message)))))
74 (defgeneric slot-initialized-p (object type slot)
76 "Returns true iff the field 'slot' in 'object' is initialized."))
78 (defmethod slot-initialized-p (object (type symbol) slot)
79 (let ((message (find-message-for-class type)))
81 "There is no Protobuf message having the type ~S" type)
82 (slot-initialized-p object message slot)))
84 (defmethod slot-initialized-p (object (message protobuf-message) slot)
85 (macrolet ((read-slot (object slot reader)
87 (funcall ,reader ,object)
88 (slot-value ,object ,slot))))
89 (let ((field (find-field message slot)))
91 (let ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
92 (slot (proto-value field))
93 (reader (proto-reader field)))
94 (cond ((null slot) nil)
95 ((or (eq (proto-required field) :required)
97 (slot-boundp object slot))
98 (t (not (null (read-slot object slot reader))))))))))
101 (defgeneric reinitialize-object (object type)
103 "Reset all the fields of 'object' to their initial values."))
105 (defmethod reinitialize-object (object (type symbol))
106 (let ((message (find-message-for-class type)))
108 "There is no Protobuf message having the type ~S" type)
109 (reinitialize-object object message)))
111 (defmethod reinitialize-object (object (message protobuf-message))
112 (dolist (field (proto-fields message))
113 (reinitialize-field object message field))
116 (defgeneric reinitialize-field (object message field)
117 (:method (object (message protobuf-message) field)
118 (macrolet ((write-slot (object slot writer value)
120 (funcall ,writer ,object ,value)
121 (setf (slot-value ,object ,slot) ,value))))
122 (let ((default (proto-default field))
123 (slot (proto-value field))
124 (writer (proto-writer field)))
126 (unless (empty-default-p field)
127 (write-slot object slot writer default)))
129 (if (empty-default-p field)
130 (slot-makunbound object slot)
131 (write-slot object slot writer default))))))))
133 (defgeneric reinitialize-slot (object message slot)
134 (:method (object (message protobuf-message) slot)
135 (let ((field (find slot (proto-fields message) :key #'proto-value)))
136 (reinitialize-field object message field))))
139 ;;; A Python-like, Protobufs2-compatible API
141 (defgeneric is-initialized (object)
143 "Returns true iff all of the fields of 'object' are initialized.")
144 (:method ((object standard-object))
145 (let* ((class (type-of object))
146 (message (find-message-for-class class)))
148 "There is no Protobufs message for the class ~S" class)
149 (object-initialized-p object message))))
151 (defgeneric clear (object)
153 "Initialize all of the fields of 'object' to their default values.")
154 (:method ((object standard-object))
155 (let* ((class (type-of object))
156 (message (find-message-for-class class)))
158 "There is no Protobufs message for the class ~S" class)
159 (reinitialize-object object message))))
161 (defgeneric has-field (object slot)
163 "Returns true iff the field 'slot' in 'object' is initialized.")
164 (:method ((object standard-object) slot)
165 (let* ((class (type-of object))
166 (message (find-message-for-class class)))
168 "There is no Protobufs message for the class ~S" class)
169 (slot-initialized-p object message slot))))
171 (defgeneric clear-field (object slot)
173 "Initialize the field 'slot' of 'object' to its default value.")
174 (:method ((object standard-object) slot)
175 (let* ((class (type-of object))
176 (message (find-message-for-class class)))
178 "There is no Protobufs message for the class ~S" class)
179 (reinitialize-slot object message slot))))
181 ;; This is simpler than 'object-size', but doesn't fully support aliasing
182 (defgeneric octet-size (object)
184 "Returns the number of octets required to encode 'object' using the wire format.
185 'object' is an object whose Lisp class corresponds to a Protobufs message.")
186 (:method ((object standard-object))
187 (let* ((class (type-of object))
188 (message (find-message-for-class class))
189 (type (and message (proto-class message))))
191 "There is no Protobufs message for the class ~S" class)
192 (let ((visited (make-size-cache object type)))
193 (object-size object type visited)))))
195 ;; This is simpler than 'serialize-object', but doesn't fully support aliasing
196 (defgeneric serialize (object &optional buffer start end)
198 "Serialize 'object' into 'buffer' using the wire format, starting at the index
199 'start' and going no farther than 'end'. 'object' is an object whose Lisp class
200 corresponds to a Protobufs message.
201 Returns two values, the final index and the buffer.")
202 (:method ((object standard-object) &optional buffer (start 0) end)
203 (declare (ignore end))
204 (let* ((class (type-of object))
205 (message (find-message-for-class class))
206 (type (and message (proto-class message))))
208 "There is no Protobufs message for the class ~S" class)
209 (let* ((visited (make-size-cache object type))
210 (size (object-size object type visited))
212 (buffer (or buffer (make-byte-vector size))))
213 (assert (>= (length buffer) size) ()
214 "The buffer ~S is not large enough to hold ~S" buffer object)
215 (multiple-value-bind (nbuf nend)
216 (serialize-object object type buffer start visited)
217 (declare (ignore nbuf))
218 (values nend buffer))))))
220 (defgeneric merge-from-array (object buffer &optional start end)
222 "Deserialize the object encoded in 'buffer' and merge it into 'object'.
223 Deserialization starts at the index 'start' and ends at 'end'.
224 'object' must an object whose Lisp class corresponds to the message
226 The return value is the updated object.")
227 (:method ((object standard-object) buffer &optional (start 0) (end (length buffer)))
228 (let* ((class (type-of object))
229 (message (find-message-for-class class))
230 (type (and message (proto-class message))))
232 "There is no Protobufs message for the class ~S" class)
233 (let* ((start (or start 0))
234 (end (or end (length buffer))))
235 (merge-from-message object (deserialize-object type buffer start end))))))
237 (defgeneric merge-from-message (object source)
239 "Merge the fields from the source object 'source' into 'object'.
240 The two objects must be of the same type.
241 Singular fields will be overwritten, with embedded messages being be merged.
242 Repeated fields will be concatenated.
243 The return value is the updated object 'object'.")
244 (:method ((object standard-object) (source standard-object))
245 (let* ((class (type-of object))
246 (message (find-message-for-class class))
247 (type (and message (proto-class message))))
249 "There is no Protobufs message for the class ~S" class)
250 (assert (eq class (type-of source)) ()
251 "The objects ~S and ~S are of not of the same class" object source)
252 ;;--- Do this (should return side-effected 'object', not 'source')