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 ;;; 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))))
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 (map () (curry #'do-field v msg indent)
65 (if suppress-line-breaks
67 (format stream "~&~VT}~%" indent)))))))
68 ((typep msg 'protobuf-enum)
70 (print-enum v msg field stream
71 (or suppress-line-breaks indent)))
72 (read-slot object slot reader)))))
74 (cond ((eq type :bool)
75 (let ((v (cond ((or (eq (proto-required field) :required)
77 (read-slot object slot reader))
78 ((slot-boundp object slot)
79 (read-slot object slot reader))
81 (unless (eq v :unbound)
82 (print-prim v type field stream
83 (or suppress-line-breaks indent)))))
85 (let ((v (read-slot object slot reader)))
87 (print-prim v type field stream
88 (or suppress-line-breaks indent)))))
89 ((typep (setq msg (and type (or (find-message trace type)
90 (find-enum trace type))))
92 (let ((v (if slot (read-slot object slot reader) object)))
94 (let ((indent (+ indent 2)))
95 (if suppress-line-breaks
96 (format stream "~A { " (proto-name field))
97 (format stream "~&~VT~A {~%" indent (proto-name field)))
98 (map () (curry #'do-field v msg indent)
100 (if suppress-line-breaks
102 (format stream "~&~VT}~%" indent))))))
103 ((typep msg 'protobuf-enum)
104 (let ((v (read-slot object slot reader)))
106 (print-enum v msg field stream
107 (or suppress-line-breaks indent))))))))))))
108 (declare (dynamic-extent #'do-field))
109 (if suppress-line-breaks
110 (format stream "~A { " (proto-name message))
111 (format stream "~&~A {~%" (proto-name message)))
112 (map () (curry #'do-field object message 0) (proto-fields message))
113 (if suppress-line-breaks
115 (format stream "~&}~%"))
118 (defun print-prim (val type field stream indent)
119 (when (or val (eq type :bool))
121 (format stream "~A: " (proto-name field))
122 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
124 ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
125 :fixed32 :sfixed32 :fixed64 :sfixed64)
126 (format stream "~D" val))
128 (format stream "\"~A\"" val))
130 (format stream "~S" val))
132 (format stream "~A" (if val "true" "false")))
134 (format stream "~D" val))
135 ;; A few of our homegrown types
137 (let ((val (if (keywordp val)
139 (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
140 (format stream "\"~A\"" val)))
141 ((:date :time :datetime :timestamp)
142 (format stream "~D" val)))
145 (format stream "~%"))))
147 (defun print-enum (val enum field stream indent)
150 (format stream "~A: " (proto-name field))
151 (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
152 (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
153 (and e (proto-name e)))))
154 (format stream "~A" name)
157 (format stream "~%")))))
160 ;;; Parse objects that were serialized using the text format
162 (defgeneric parse-text-format (type &key stream)
164 "Parses an object of type 'type' from the stream 'stream' using the textual format."))
166 (defmethod parse-text-format ((type symbol) &key (stream *standard-input*))
167 (let ((message (find-message-for-class type)))
169 "There is no Protobuf message having the type ~S" type)
170 (parse-text-format message :stream stream)))
172 (defmethod parse-text-format ((message protobuf-message) &key (stream *standard-input*))
173 (let ((name (parse-token stream)))
174 (assert (string= name (proto-name message)) ()
175 "The message is not of the expected type ~A" (proto-name message)))
176 (labels ((deserialize (type trace)
177 (let* ((message (find-message trace type))
179 (make-instance (or (proto-alias-for message) (proto-class message)))))
181 (expect-char stream #\{)
183 (skip-whitespace stream)
184 (when (eql (peek-char nil stream nil) #\})
186 (dolist (slot rslots)
187 (setf (slot-value object slot) (nreverse (slot-value object slot))))
188 (return-from deserialize object))
189 (let* ((name (parse-token stream))
190 (field (and name (find name (proto-fields message) :key #'proto-name :test #'string=)))
191 (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
192 (slot (and field (proto-value field)))
196 (cond ((and field (eq (proto-required field) :repeated))
197 (cond ((keywordp type)
198 (expect-char stream #\:)
199 (let ((val (case type
200 ((:float :double) (parse-float stream))
201 ((:string) (parse-string stream))
202 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
203 (otherwise (parse-signed-int stream)))))
205 (pushnew slot rslots)
206 (push val (slot-value object slot)))))
207 ((typep (setq msg (and type (or (find-message trace type)
208 (find-enum trace type))))
210 (when (eql (peek-char nil stream nil) #\:)
212 (let ((obj (deserialize type msg)))
214 (pushnew slot rslots)
215 (push obj (slot-value object slot)))))
216 ((typep msg 'protobuf-enum)
217 (expect-char stream #\:)
218 (let* ((name (parse-token stream))
219 (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
220 (val (and enum (proto-value enum))))
222 (pushnew slot rslots)
223 (push val (slot-value object slot)))))))
225 (cond ((keywordp type)
226 (expect-char stream #\:)
227 (let ((val (case type
228 ((:float :double) (parse-float stream))
229 ((:string) (parse-string stream))
230 ((:bool) (if (boolean-true-p (parse-token stream)) t nil))
231 (otherwise (parse-signed-int stream)))))
233 (setf (slot-value object slot) val))))
234 ((typep (setq msg (and type (or (find-message trace type)
235 (find-enum trace type))))
237 (when (eql (peek-char nil stream nil) #\:)
239 (let ((obj (deserialize type msg)))
241 (setf (slot-value object slot) obj))))
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 (setf (slot-value object slot) val))))))))))))
250 ;; Skip either a token or a balanced {}-pair
251 (ecase (peek-char nil stream nil)
254 (skip-whitespace stream)
255 (parse-token-or-string stream))
258 (loop for ch = (read-char stream)
259 do (cond ((eql ch #\")
260 (loop for ch0 = (read-char stream)
261 until (eql ch0 #\")))
266 until (i= depth 0)))))))
267 (declare (dynamic-extent #'deserialize #'skip-field))
268 (deserialize (proto-class message) message)))