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)
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*))
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))
125 (if suppress-line-breaks
126 (format stream "~A { " (proto-name message))
127 (format stream "~&~A {~%" (proto-name message)))
128 (map () (curry #'do-field object message 0) (proto-fields message))
129 (if suppress-line-breaks
131 (format stream "~&}~%"))
134 (defun print-prim (val type field stream indent)
135 (when (or val (eq type :bool))
137 (format stream "~A: " (proto-name field))
138 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
140 ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
141 :fixed32 :sfixed32 :fixed64 :sfixed64)
142 (format stream "~D" val))
144 (format stream "\"~A\"" val))
146 (format stream "~S" val))
148 (format stream "~A" (if val "true" "false")))
150 (format stream "~D" val))
151 ;; A few of our homegrown types
153 (let ((val (if (keywordp val)
155 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
156 (format stream "\"~A\"" val)))
157 ((:date :time :datetime :timestamp)
158 (format stream "~D" val)))
161 (format stream "~%"))))
163 (defun print-enum (val enum field stream indent)
166 (format stream "~A: " (proto-name field))
167 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
168 (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
169 (and e (proto-name e)))))
170 (format stream "~A" name)
173 (format stream "~%")))))
176 ;;; Parse objects that were serialized using the text format
178 (defgeneric parse-text-format (type &key stream)
180 "Parses an object of type 'type' from the stream 'stream' using the textual format."))
182 (defmethod parse-text-format ((type symbol) &key (stream *standard-input*))
183 (let ((message (find-message-for-class type)))
185 "There is no Protobuf message having the type ~S" type)
186 (parse-text-format message :stream stream)))
188 (defmethod parse-text-format ((message protobuf-message) &key (stream *standard-input*))
189 (let ((name (parse-token stream)))
190 (assert (string= name (proto-name message)) ()
191 "The message is not of the expected type ~A" (proto-name message)))
192 (labels ((deserialize (type trace)
193 (let* ((message (find-message trace type))
195 (make-instance (or (proto-alias-for message) (proto-class message)))))
197 (expect-char stream #\{)
199 (skip-whitespace stream)
200 (when (eql (peek-char nil stream nil) #\})
202 (dolist (slot rslots)
203 (setf (slot-value object slot) (nreverse (slot-value object slot))))
204 (return-from deserialize object))
205 (let* ((name (parse-token stream))
206 (field (and name (find-field message name)))
207 (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
208 (slot (and field (proto-value field)))
212 (cond ((and field (eq (proto-required field) :repeated))
213 (cond ((keywordp type)
214 (expect-char stream #\:)
215 (let ((val (case type
216 ((:float :double) (parse-float stream))
217 ((:string) (parse-string stream))
218 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
219 (otherwise (parse-signed-int stream)))))
221 (pushnew slot rslots)
222 (push val (slot-value object slot)))))
223 ((typep (setq msg (and type (or (find-message trace type)
224 (find-enum trace type)
225 (find-type-alias trace type))))
227 (when (eql (peek-char nil stream nil) #\:)
229 (let ((obj (deserialize type msg)))
231 (pushnew slot rslots)
232 (push obj (slot-value object slot)))))
233 ((typep msg 'protobuf-enum)
234 (expect-char stream #\:)
235 (let* ((name (parse-token stream))
236 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
237 (val (and enum (proto-value enum))))
239 (pushnew slot rslots)
240 (push val (slot-value object slot)))))
241 ((typep msg 'protobuf-type-alias)
242 (let ((type (proto-proto-type msg)))
243 (expect-char stream #\:)
244 (let ((val (case type
245 ((:float :double) (parse-float stream))
246 ((:string) (parse-string stream))
247 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
248 (otherwise (parse-signed-int stream)))))
250 (pushnew slot rslots)
251 (push (funcall (proto-deserializer msg) val)
252 (slot-value object slot))))))))
254 (cond ((keywordp type)
255 (expect-char stream #\:)
256 (let ((val (case type
257 ((:float :double) (parse-float stream))
258 ((:string) (parse-string stream))
259 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
260 (otherwise (parse-signed-int stream)))))
262 (setf (slot-value object slot) val))))
263 ((typep (setq msg (and type (or (find-message trace type)
264 (find-enum trace type)
265 (find-type-alias trace type))))
267 (when (eql (peek-char nil stream nil) #\:)
269 (let ((obj (deserialize type msg)))
271 (setf (slot-value object slot) obj))))
272 ((typep msg 'protobuf-enum)
273 (expect-char stream #\:)
274 (let* ((name (parse-token stream))
275 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
276 (val (and enum (proto-value enum))))
278 (setf (slot-value object slot) val))))
279 ((typep msg 'protobuf-type-alias)
280 (let ((type (proto-proto-type msg)))
281 (expect-char stream #\:)
282 (let ((val (case type
283 ((:float :double) (parse-float stream))
284 ((:string) (parse-string stream))
285 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
286 (otherwise (parse-signed-int stream)))))
288 (setf (slot-value object slot)
289 (funcall (proto-deserializer msg) val))))))))))))))
291 ;; Skip either a token or a balanced {}-pair
292 (ecase (peek-char nil stream nil)
295 (skip-whitespace stream)
296 (parse-token-or-string stream))
299 (loop for ch = (read-char stream)
300 do (cond ((eql ch #\")
301 (loop for ch0 = (read-char stream)
302 until (eql ch0 #\")))
307 until (i= depth 0)))))))
308 (declare (dynamic-extent #'deserialize #'skip-field))
309 (deserialize (proto-class message) message)))