1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;; Free Software published under an MIT-like license. See LICENSE ;;;
5 ;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
7 ;;; Original author: Scott McKay ;;;
9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 (in-package "PROTO-IMPL")
14 ;;; Print objects using Protobufs text format
16 (defvar *suppress-line-breaks* nil
17 "When true, don't generate line breaks in the text format")
19 (defgeneric print-text-format (object &optional type &key stream suppress-line-breaks print-name)
21 "Prints the object 'object' of type 'type' onto the stream 'stream' using the
23 If 'suppress-line-breaks' is true, all the output is put on a single line."))
25 (defmethod print-text-format (object &optional type
26 &key (stream *standard-output*)
27 (suppress-line-breaks *suppress-line-breaks*) (print-name t))
28 (let* ((type (or type (type-of object)))
29 (message (find-message-for-class type)))
31 "There is no Protobuf message having the type ~S" type)
32 (macrolet ((read-slot (object slot reader)
33 ;; Don't do a boundp check, we assume the object is fully populated
34 ;; Unpopulated slots should be "nullable" and should contain nil
36 (funcall ,reader ,object)
37 (slot-value ,object ,slot))))
38 (labels ((do-field (object trace indent field)
39 ;; We don't do cycle detection here
40 ;; If the client needs it, he can define his own 'print-text-format'
41 ;; method to clean things up first
42 (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
43 (slot (proto-value field))
44 (reader (proto-reader field))
46 (when (or slot reader)
47 (cond ((eq (proto-required field) :repeated)
48 (cond ((keywordp type)
49 (doseq (v (read-slot object slot reader))
50 (print-prim v type field stream
51 (or suppress-line-breaks indent))))
52 ((typep (setq msg (and type (or (find-message trace type)
53 (find-enum trace type)
54 (find-type-alias trace type))))
56 (let ((values (if slot (read-slot object slot reader) (list object))))
58 (let ((indent (+ indent 2)))
60 (if suppress-line-breaks
61 (format stream "~A { " (proto-name field))
62 (format stream "~&~VT~A {~%" indent (proto-name field)))
63 (dolist (f (proto-fields msg))
64 (do-field v msg indent f))
65 (if suppress-line-breaks
67 (format stream "~&~VT}~%" indent)))))))
68 ((typep msg 'protobuf-enum)
69 (doseq (v (read-slot object slot reader))
70 (print-enum v msg field stream
71 (or suppress-line-breaks indent))))
72 ((typep msg 'protobuf-type-alias)
73 (let ((type (proto-proto-type msg)))
74 (doseq (v (read-slot object slot reader))
75 (let ((v (funcall (proto-serializer msg) v)))
76 (print-prim v type field stream
77 (or suppress-line-breaks indent))))))
79 (undefined-field-type "While printing ~S to text format,"
82 (cond ((eq type :bool)
83 (let ((v (cond ((or (eq (proto-required field) :required)
85 (read-slot object slot reader))
86 ((slot-boundp object slot)
87 (read-slot object slot reader))
89 (unless (eq v :unbound)
90 (print-prim v type field stream
91 (or suppress-line-breaks indent)))))
93 (let ((v (read-slot object slot reader)))
94 (when (and v (not (equal v (proto-default field))))
95 (print-prim v type field stream
96 (or suppress-line-breaks indent)))))
97 ((typep (setq msg (and type (or (find-message trace type)
98 (find-enum trace type)
99 (find-type-alias trace type))))
101 (let ((v (if slot (read-slot object slot reader) object)))
103 (let ((indent (+ indent 2)))
104 (if suppress-line-breaks
105 (format stream "~A { " (proto-name field))
106 (format stream "~&~VT~A {~%" indent (proto-name field)))
107 (dolist (f (proto-fields msg))
108 (do-field v msg indent f))
109 (if suppress-line-breaks
111 (format stream "~&~VT}~%" indent))))))
112 ((typep msg 'protobuf-enum)
113 (let ((v (read-slot object slot reader)))
114 (when (and v (not (eql v (proto-default field))))
115 (print-enum v msg field stream
116 (or suppress-line-breaks indent)))))
117 ((typep msg 'protobuf-type-alias)
118 (let ((v (read-slot object slot reader)))
120 (let ((v (funcall (proto-serializer msg) v))
121 (type (proto-proto-type msg)))
122 (print-prim v type field stream
123 (or suppress-line-breaks indent))))))
125 (undefined-field-type "While printing ~S to text format,"
126 object type field)))))))))
127 (declare (dynamic-extent #'do-field))
129 (if suppress-line-breaks
130 (format stream "~A { " (proto-name message))
131 (format stream "~&~A {~%" (proto-name message)))
133 (dolist (f (proto-fields message))
134 (do-field object message 0 f))
135 (if suppress-line-breaks
137 (format stream "~&}~%"))
140 (defun print-prim (val type field stream indent)
141 (when (or val (eq type :bool))
143 (format stream "~A: " (proto-name field))
144 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
146 ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
147 :fixed32 :sfixed32 :fixed64 :sfixed64)
148 (format stream "~D" val))
150 (format stream "\"~A\"" val))
152 (format stream "~S" val))
154 (format stream "~A" (if val "true" "false")))
156 (format stream "~D" val))
157 ;; A few of our homegrown types
159 (let ((val (if (keywordp val)
161 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
162 (format stream "\"~A\"" val)))
163 ((:date :time :datetime :timestamp)
164 (format stream "~D" val)))
167 (format stream "~%"))))
169 (defun print-enum (val enum field stream indent)
172 (format stream "~A: " (proto-name field))
173 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
174 (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
175 (and e (proto-name e)))))
176 (format stream "~A" name)
179 (format stream "~%")))))
182 ;;; Parse objects that were serialized using the text format
184 (defgeneric parse-text-format (type &key stream parse-name)
186 "Parses an object of type 'type' from the stream 'stream' using the textual format."))
188 (defmethod parse-text-format ((type symbol)
189 &key (stream *standard-input*) (parse-name t))
190 (let ((message (find-message-for-class type)))
192 "There is no Protobuf message having the type ~S" type)
193 (parse-text-format message :stream stream :parse-name parse-name)))
195 (defmethod parse-text-format ((message protobuf-message)
196 &key (stream *standard-input*) (parse-name t))
198 (let ((name (parse-token stream)))
199 (assert (string= name (proto-name message)) ()
200 "The message is not of the expected type ~A" (proto-name message))))
201 (labels ((deserialize (type trace)
202 (let* ((message (find-message trace type))
204 (make-instance (or (proto-alias-for message) (proto-class message)))))
206 (expect-char stream #\{)
208 (skip-whitespace stream)
209 (when (eql (peek-char nil stream nil) #\})
211 (dolist (slot rslots)
212 (setf (slot-value object slot) (nreverse (slot-value object slot))))
213 (return-from deserialize object))
214 (let* ((name (parse-token stream))
215 (field (and name (find-field message name)))
216 (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
217 (slot (and field (proto-value field)))
221 (cond ((and field (eq (proto-required field) :repeated))
222 (cond ((keywordp type)
223 (expect-char stream #\:)
224 (let ((val (case type
225 ((:float :double) (parse-float stream))
226 ((:string) (parse-string stream))
227 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
228 (otherwise (parse-signed-int stream)))))
230 (pushnew slot rslots)
231 (push val (slot-value object slot)))))
232 ((typep (setq msg (and type (or (find-message trace type)
233 (find-enum trace type)
234 (find-type-alias trace type))))
236 (when (eql (peek-char nil stream nil) #\:)
238 (let ((obj (deserialize type msg)))
240 (pushnew slot rslots)
241 (push obj (slot-value object slot)))))
242 ((typep msg 'protobuf-enum)
243 (expect-char stream #\:)
244 (let* ((name (parse-token stream))
245 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
246 (val (and enum (proto-value enum))))
248 (pushnew slot rslots)
249 (push val (slot-value object slot)))))
250 ((typep msg 'protobuf-type-alias)
251 (let ((type (proto-proto-type msg)))
252 (expect-char stream #\:)
253 (let ((val (case type
254 ((:float :double) (parse-float stream))
255 ((:string) (parse-string stream))
256 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
257 (otherwise (parse-signed-int stream)))))
259 (pushnew slot rslots)
260 (push (funcall (proto-deserializer msg) val)
261 (slot-value object slot))))))
263 (undefined-field-type "While parsing ~S from text format,"
264 message type field))))
266 (cond ((keywordp type)
267 (expect-char stream #\:)
268 (let ((val (case type
269 ((:float :double) (parse-float stream))
270 ((:string) (parse-string stream))
271 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
272 (otherwise (parse-signed-int stream)))))
274 (setf (slot-value object slot) val))))
275 ((typep (setq msg (and type (or (find-message trace type)
276 (find-enum trace type)
277 (find-type-alias trace type))))
279 (when (eql (peek-char nil stream nil) #\:)
281 (let ((obj (deserialize type msg)))
283 (setf (slot-value object slot) obj))))
284 ((typep msg 'protobuf-enum)
285 (expect-char stream #\:)
286 (let* ((name (parse-token stream))
287 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
288 (val (and enum (proto-value enum))))
290 (setf (slot-value object slot) val))))
291 ((typep msg 'protobuf-type-alias)
292 (let ((type (proto-proto-type msg)))
293 (expect-char stream #\:)
294 (let ((val (case type
295 ((:float :double) (parse-float stream))
296 ((:string) (parse-string stream))
297 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
298 (otherwise (parse-signed-int stream)))))
300 (setf (slot-value object slot)
301 (funcall (proto-deserializer msg) val))))))
303 (undefined-field-type "While parsing ~S from text format,"
304 message type field)))))))))))
305 (declare (dynamic-extent #'deserialize))
306 (deserialize (proto-class message) message)))
308 (defun skip-field (stream)
309 "Skip either a token or a balanced {}-pair."
310 (ecase (peek-char nil stream nil)
313 (skip-whitespace stream)
314 (parse-token-or-string stream))
317 (loop for ch = (read-char stream)
318 do (cond ((eql ch #\")
319 (loop for ch0 = (read-char stream)
320 until (eql ch0 #\")))
325 until (i= depth 0))))))