1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Confidential and proprietary information of ITA Software, Inc. ;;;
5 ;;; Copyright (c) 2012 ITA Software, 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 (macrolet ((write-slot (object slot writer value)
114 (funcall ,writer ,object ,value)
115 (setf (slot-value ,object ,slot) ,value))))
116 (dolist (field (proto-fields message))
117 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
118 (default (protobuf-default-to-clos-init (proto-default field) type))
119 (slot (proto-value field))
120 (writer (proto-writer field)))
122 ((or (eq (proto-required field) :required)
124 (if (proto-default field)
125 (write-slot object slot writer default)
126 (slot-makunbound object slot)))
128 (write-slot object slot writer default))))))
132 ;;; A Python-like, Protobufs2-compatible API
134 (defgeneric is-initialized (object)
136 "Returns true iff all of the fields of 'object' are initialized.")
137 (:method ((object standard-object))
138 (let* ((class (class-of object))
139 (message (find-message-for-class class)))
141 "There is no Protobufs message for the class ~S" class)
142 (object-initialized-p object message))))
144 (defgeneric has-field (object slot)
146 "Returns true iff the field 'slot' in 'object' is initialized.")
147 (:method ((object standard-object) slot)
148 (let* ((class (class-of object))
149 (message (find-message-for-class class)))
151 "There is no Protobufs message for the class ~S" class)
152 (slot-initialized-p object message slot))))
154 (defgeneric clear (object)
156 "Initialize all of the fields of 'object' to their default values.")
157 (:method ((object standard-object))
158 (let* ((class (class-of object))
159 (message (find-message-for-class class)))
161 "There is no Protobufs message for the class ~S" class)
162 (reinitialize-object object message))))
164 ;; This is simpler than 'object-size', but doesn't fully support aliasing
165 (defgeneric octet-size (object)
167 "Returns the number of octets required to encode 'object' using the wire format.
168 'object' is an object whose Lisp class corresponds to a Protobufs message.")
169 (:method ((object standard-object))
170 (let* ((class (class-of object))
171 (message (find-message-for-class class))
172 (type (and message (proto-class message))))
174 "There is no Protobufs message for the class ~S" class)
175 (let ((visited (make-hash-table)))
176 (object-size object type visited)))))
178 ;; This is simpler than 'serialize-object', but doesn't fully support aliasing
179 (defgeneric serialize (object &optional buffer start end)
181 "Serialize 'object' into 'buffer' using the wire format, starting at the index
182 'start' and going no farther than 'end'. 'object' is an object whose Lisp class
183 corresponds to a Protobufs message.")
184 (:method ((object standard-object) &optional buffer (start 0) end)
185 (declare (ignore end))
186 (let* ((class (class-of object))
187 (message (find-message-for-class class))
188 (type (and message (proto-class message))))
190 "There is no Protobufs message for the class ~S" class)
191 (let* ((visited (make-hash-table))
192 (size (object-size object type visited))
194 (buffer (or buffer (make-array size :element-type '(unsigned-byte 8)))))
195 (assert (>= (length buffer) size) ()
196 "The buffer ~S is not large enough to hold ~S" buffer object)
197 (serialize-object object type buffer start visited)
200 ;; This is simpler than 'deserialize-object', but doesn't fully support aliasing
201 (defgeneric merge-from-array (object buffer &optional start end)
203 "Deserialize the object encoded in 'buffer' into 'object', starting at the index
204 'start' and ending at 'end'. 'object' is an object whose Lisp class corresponds
205 to a Protobufs message.")
206 (:method ((object standard-object) buffer &optional (start 0) (end (length buffer)))
207 (let* ((class (class-of object))
208 (message (find-message-for-class class))
209 (type (and message (proto-class message))))
211 "There is no Protobufs message for the class ~S" class)
212 (let* ((start (or start 0))
213 (end (or end (length buffer))))
214 (deserialize-object type buffer start end)))))
216 (defgeneric merge-from-message (object source-object)
219 (:method ((object standard-object) (source-object standard-object))
220 (let* ((class (class-of object))
221 (message (find-message-for-class class))
222 (type (and message (proto-class message))))
223 (assert (eq class (class-of source-object)) ()
224 "The objects ~S and ~S are of not of the same class" object source-object)
226 "There is no Protobufs message for the class ~S" class)