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)
50 (print-prim v type field stream
51 (or suppress-line-breaks indent)))
52 (read-slot object slot reader)))
53 ((typep (setq msg (and type (or (find-message trace type)
54 (find-enum trace type)
55 (find-type-alias trace type))))
57 (let ((values (if slot (read-slot object slot reader) (list object))))
59 (let ((indent (+ indent 2)))
61 (if suppress-line-breaks
62 (format stream "~A { " (proto-name field))
63 (format stream "~&~VT~A {~%" indent (proto-name field)))
64 (map () (curry #'do-field v msg indent)
66 (if suppress-line-breaks
68 (format stream "~&~VT}~%" indent)))))))
69 ((typep msg 'protobuf-enum)
71 (print-enum v msg field stream
72 (or suppress-line-breaks indent)))
73 (read-slot object slot reader)))
74 ((typep msg 'protobuf-type-alias)
75 (let ((type (proto-proto-type msg)))
77 (let ((v (funcall (proto-serializer msg) v)))
78 (print-prim v type field stream
79 (or suppress-line-breaks indent))))
80 (read-slot object slot reader))))))
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)))
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 (map () (curry #'do-field v msg indent)
109 (if suppress-line-breaks
111 (format stream "~&~VT}~%" indent))))))
112 ((typep msg 'protobuf-enum)
113 (let ((v (read-slot object slot reader)))
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)))))))))))))
124 (declare (dynamic-extent #'do-field))
126 (if suppress-line-breaks
127 (format stream "~A { " (proto-name message))
128 (format stream "~&~A {~%" (proto-name message)))
130 (map () (curry #'do-field object message 0) (proto-fields message))
131 (if suppress-line-breaks
133 (format stream "~&}~%"))
136 (defun print-prim (val type field stream indent)
137 (when (or val (eq type :bool))
139 (format stream "~A: " (proto-name field))
140 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
142 ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
143 :fixed32 :sfixed32 :fixed64 :sfixed64)
144 (format stream "~D" val))
146 (format stream "\"~A\"" val))
148 (format stream "~S" val))
150 (format stream "~A" (if val "true" "false")))
152 (format stream "~D" val))
153 ;; A few of our homegrown types
155 (let ((val (if (keywordp val)
157 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
158 (format stream "\"~A\"" val)))
159 ((:date :time :datetime :timestamp)
160 (format stream "~D" val)))
163 (format stream "~%"))))
165 (defun print-enum (val enum field stream indent)
168 (format stream "~A: " (proto-name field))
169 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
170 (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
171 (and e (proto-name e)))))
172 (format stream "~A" name)
175 (format stream "~%")))))
178 ;;; Parse objects that were serialized using the text format
180 (defgeneric parse-text-format (type &key stream parse-name)
182 "Parses an object of type 'type' from the stream 'stream' using the textual format."))
184 (defmethod parse-text-format ((type symbol)
185 &key (stream *standard-input*) (parse-name t))
186 (let ((message (find-message-for-class type)))
188 "There is no Protobuf message having the type ~S" type)
189 (parse-text-format message :stream stream :parse-name parse-name)))
191 (defmethod parse-text-format ((message protobuf-message)
192 &key (stream *standard-input*) (parse-name t))
194 (let ((name (parse-token stream)))
195 (assert (string= name (proto-name message)) ()
196 "The message is not of the expected type ~A" (proto-name message))))
197 (labels ((deserialize (type trace)
198 (let* ((message (find-message trace type))
200 (make-instance (or (proto-alias-for message) (proto-class message)))))
202 (expect-char stream #\{)
204 (skip-whitespace stream)
205 (when (eql (peek-char nil stream nil) #\})
207 (dolist (slot rslots)
208 (setf (slot-value object slot) (nreverse (slot-value object slot))))
209 (return-from deserialize object))
210 (let* ((name (parse-token stream))
211 (field (and name (find-field message name)))
212 (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
213 (slot (and field (proto-value field)))
217 (cond ((and field (eq (proto-required field) :repeated))
218 (cond ((keywordp type)
219 (expect-char stream #\:)
220 (let ((val (case type
221 ((:float :double) (parse-float stream))
222 ((:string) (parse-string stream))
223 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
224 (otherwise (parse-signed-int stream)))))
226 (pushnew slot rslots)
227 (push val (slot-value object slot)))))
228 ((typep (setq msg (and type (or (find-message trace type)
229 (find-enum trace type)
230 (find-type-alias trace type))))
232 (when (eql (peek-char nil stream nil) #\:)
234 (let ((obj (deserialize type msg)))
236 (pushnew slot rslots)
237 (push obj (slot-value object slot)))))
238 ((typep msg 'protobuf-enum)
239 (expect-char stream #\:)
240 (let* ((name (parse-token stream))
241 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
242 (val (and enum (proto-value enum))))
244 (pushnew slot rslots)
245 (push val (slot-value object slot)))))
246 ((typep msg 'protobuf-type-alias)
247 (let ((type (proto-proto-type msg)))
248 (expect-char stream #\:)
249 (let ((val (case type
250 ((:float :double) (parse-float stream))
251 ((:string) (parse-string stream))
252 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
253 (otherwise (parse-signed-int stream)))))
255 (pushnew slot rslots)
256 (push (funcall (proto-deserializer msg) val)
257 (slot-value object slot))))))))
259 (cond ((keywordp type)
260 (expect-char stream #\:)
261 (let ((val (case type
262 ((:float :double) (parse-float stream))
263 ((:string) (parse-string stream))
264 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
265 (otherwise (parse-signed-int stream)))))
267 (setf (slot-value object slot) val))))
268 ((typep (setq msg (and type (or (find-message trace type)
269 (find-enum trace type)
270 (find-type-alias trace type))))
272 (when (eql (peek-char nil stream nil) #\:)
274 (let ((obj (deserialize type msg)))
276 (setf (slot-value object slot) obj))))
277 ((typep msg 'protobuf-enum)
278 (expect-char stream #\:)
279 (let* ((name (parse-token stream))
280 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
281 (val (and enum (proto-value enum))))
283 (setf (slot-value object slot) val))))
284 ((typep msg 'protobuf-type-alias)
285 (let ((type (proto-proto-type msg)))
286 (expect-char stream #\:)
287 (let ((val (case type
288 ((:float :double) (parse-float stream))
289 ((:string) (parse-string stream))
290 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
291 (otherwise (parse-signed-int stream)))))
293 (setf (slot-value object slot)
294 (funcall (proto-deserializer msg) val)))))))))))))))
295 (declare (dynamic-extent #'deserialize))
296 (deserialize (proto-class message) message)))
298 (defun skip-field (stream)
299 "Skip either a token or a balanced {}-pair."
300 (ecase (peek-char nil stream nil)
303 (skip-whitespace stream)
304 (parse-token-or-string stream))
307 (loop for ch = (read-char stream)
308 do (cond ((eql ch #\")
309 (loop for ch0 = (read-char stream)
310 until (eql ch0 #\")))
315 until (i= depth 0))))))