X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=text-format.lisp;h=eacfb08afda5d6967c7634d8d28f8a18df96464d;hb=9a1d9899fc5cbe67c79b00d2fb8494a46e37fe53;hp=69a9e7f0140b293d5185ec7e0eeca0a2689d7ce1;hpb=d8cdb95b8278f427591536caf0c8a8730ee0ff5d;p=cl-protobufs.git diff --git a/text-format.lisp b/text-format.lisp index 69a9e7f..eacfb08 100644 --- a/text-format.lisp +++ b/text-format.lisp @@ -1,8 +1,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; -;;; Confidential and proprietary information of ITA Software, Inc. ;;; +;;; Free Software published under an MIT-like license. See LICENSE ;;; ;;; ;;; -;;; Copyright (c) 2012 ITA Software, Inc. All rights reserved. ;;; +;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;; ;;; ;;; ;;; Original author: Scott McKay ;;; ;;; ;;; @@ -13,99 +13,301 @@ ;;; Print objects using Protobufs text format -(defgeneric print-text-format (object protobuf &key stream) +(defvar *suppress-line-breaks* nil + "When true, don't generate line breaks in the text format") + +(defgeneric print-text-format (object &optional type &key stream suppress-line-breaks print-name) (:documentation - "Prints the object 'object' as a protobuf object defined in the schema 'protobuf' - onto the stream 'stream' using the textual format.")) + "Prints the object 'object' of type 'type' onto the stream 'stream' using the + textual format. + If 'suppress-line-breaks' is true, all the output is put on a single line.")) -(defmethod print-text-format ((object standard-object) protobuf &key (stream *standard-output*)) - (check-type protobuf (or protobuf protobuf-message)) - (let* ((class (class-of object)) - (message (find-message protobuf class))) +(defmethod print-text-format (object &optional type + &key (stream *standard-output*) + (suppress-line-breaks *suppress-line-breaks*) (print-name t)) + (let* ((type (or type (type-of object))) + (message (find-message-for-class type))) (assert message () - "There is no Protobuf message for the class ~S" class) - (labels ((safe-slot-value (object slot) - (if (slot-boundp object slot) - (slot-value object slot) - nil)) - (do-field (object trace indent field) - ;; We don't do cycle detection here - ;; If the client needs it, he can define his own 'print-text-format' - ;; method to clean things up first - (let* ((cl (if (eq (proto-class field) 'boolean) :bool (proto-class field))) - (msg (and cl (loop for p in trace - thereis (or (find-message p cl) - (find-enum p cl))))) - (slot (proto-value field))) - (cond ((eq (proto-required field) :repeated) - (cond ((and slot (keywordp cl)) - (map () #'(lambda (v) - (when (or (eq cl :bool) (not (null v))) - (print-prim v cl field stream indent))) - (safe-slot-value object slot))) - ((and slot (typep msg 'protobuf-enum)) - (map () #'(lambda (v) - (when (not (null v)) - (print-enum v msg field stream indent))) - (safe-slot-value object slot))) - ((typep msg 'protobuf-message) - (let ((values (if slot (safe-slot-value object slot) (list object)))) - (when values - (format stream "~&~VT~A:~%" (+ indent 2) (proto-name field)) - (let ((indent (+ indent 4))) - (dolist (v values) - (format stream "~&~VT~A {~%" indent (proto-name msg)) - (map () (curry #'do-field v (cons msg trace) indent) - (proto-fields msg)) - (format stream "~&~VT}~%" indent)))))))) - (t - (cond ((and slot (keywordp cl)) - (let ((v (safe-slot-value object slot))) - (when (or (eq cl :bool) (not (null v))) - (print-prim v cl field stream indent)))) - ((and slot (typep msg 'protobuf-enum)) - (let ((v (safe-slot-value object slot))) - (when (not (null v)) - (print-enum v msg field stream indent)))) - ((typep msg 'protobuf-message) - (let ((v (if slot (safe-slot-value object slot) object))) - (when v - (format stream "~&~VT~A:~%" (+ indent 2) (proto-name field)) - (let ((indent (+ indent 4))) - (format stream "~&~VT~A {~%" indent (proto-name msg)) - (map () (curry #'do-field v (cons msg trace) indent) - (proto-fields msg)) - (format stream "~&~VT}~%" indent))))))))))) - (declare (dynamic-extent #'safe-slot-value #'do-field)) - (format stream "~&~A {~%" (proto-name message)) - (map () (curry #'do-field object (list message protobuf) 0) (proto-fields message)) - (format stream "~&}~%") - nil))) + "There is no Protobuf message having the type ~S" type) + (macrolet ((read-slot (object slot reader) + ;; Don't do a boundp check, we assume the object is fully populated + ;; Unpopulated slots should be "nullable" and should contain nil + `(if ,reader + (funcall ,reader ,object) + (slot-value ,object ,slot)))) + (labels ((do-field (object trace indent field) + ;; We don't do cycle detection here + ;; If the client needs it, he can define his own 'print-text-format' + ;; method to clean things up first + (let* ((type (if (eq (proto-class field) 'boolean) :bool (proto-class field))) + (slot (proto-value field)) + (reader (proto-reader field)) + msg) + (when (or slot reader) + (cond ((eq (proto-required field) :repeated) + (cond ((keywordp type) + (doseq (v (read-slot object slot reader)) + (print-prim v type field stream + (or suppress-line-breaks indent)))) + ((typep (setq msg (and type (or (find-message trace type) + (find-enum trace type) + (find-type-alias trace type)))) + 'protobuf-message) + (let ((values (if slot (read-slot object slot reader) (list object)))) + (when values + (let ((indent (+ indent 2))) + (dolist (v values) + (if suppress-line-breaks + (format stream "~A { " (proto-name field)) + (format stream "~&~VT~A {~%" indent (proto-name field))) + (dolist (f (proto-fields msg)) + (do-field v msg indent f)) + (if suppress-line-breaks + (format stream "} ") + (format stream "~&~VT}~%" indent))))))) + ((typep msg 'protobuf-enum) + (doseq (v (read-slot object slot reader)) + (print-enum v msg field stream + (or suppress-line-breaks indent)))) + ((typep msg 'protobuf-type-alias) + (let ((type (proto-proto-type msg))) + (doseq (v (read-slot object slot reader)) + (let ((v (funcall (proto-serializer msg) v))) + (print-prim v type field stream + (or suppress-line-breaks indent)))))))) + (t + (cond ((eq type :bool) + (let ((v (cond ((or (eq (proto-required field) :required) + (null slot)) + (read-slot object slot reader)) + ((slot-boundp object slot) + (read-slot object slot reader)) + (t :unbound)))) + (unless (eq v :unbound) + (print-prim v type field stream + (or suppress-line-breaks indent))))) + ((keywordp type) + (let ((v (read-slot object slot reader))) + (when v + (print-prim v type field stream + (or suppress-line-breaks indent))))) + ((typep (setq msg (and type (or (find-message trace type) + (find-enum trace type) + (find-type-alias trace type)))) + 'protobuf-message) + (let ((v (if slot (read-slot object slot reader) object))) + (when v + (let ((indent (+ indent 2))) + (if suppress-line-breaks + (format stream "~A { " (proto-name field)) + (format stream "~&~VT~A {~%" indent (proto-name field))) + (dolist (f (proto-fields msg)) + (do-field v msg indent f)) + (if suppress-line-breaks + (format stream "} ") + (format stream "~&~VT}~%" indent)))))) + ((typep msg 'protobuf-enum) + (let ((v (read-slot object slot reader))) + (when v + (print-enum v msg field stream + (or suppress-line-breaks indent))))) + ((typep msg 'protobuf-type-alias) + (let ((v (read-slot object slot reader))) + (when v + (let ((v (funcall (proto-serializer msg) v)) + (type (proto-proto-type msg))) + (print-prim v type field stream + (or suppress-line-breaks indent))))))))))))) + (declare (dynamic-extent #'do-field)) + (if print-name + (if suppress-line-breaks + (format stream "~A { " (proto-name message)) + (format stream "~&~A {~%" (proto-name message))) + (format stream "{")) + (dolist (f (proto-fields message)) + (do-field object message 0 f)) + (if suppress-line-breaks + (format stream "}") + (format stream "~&}~%")) + nil)))) -(defun print-prim (val type field stream &optional (indent 0)) - (when val - (format stream "~&~VT~A: " (+ indent 2) (proto-name field)) +(defun print-prim (val type field stream indent) + (when (or val (eq type :bool)) + (if (eq indent 't) + (format stream "~A: " (proto-name field)) + (format stream "~&~VT~A: " (+ indent 2) (proto-name field))) (ecase type ((:int32 :uint32 :int64 :uint64 :sint32 :sint64 :fixed32 :sfixed32 :fixed64 :sfixed64) - (format stream "~D~%" val)) + (format stream "~D" val)) ((:string) - (format stream "\"~A\"~%" val)) + (format stream "\"~A\"" val)) ((:bytes) - (format stream "~S~%" val)) + (format stream "~S" val)) ((:bool) - (format stream "~A~%" (if (zerop val) "false" "true"))) + (format stream "~A" (if val "true" "false"))) ((:float :double) - (format stream "~D~%" val)) + (format stream "~D" val)) ;; A few of our homegrown types ((:symbol) - (format stream "~A~%" val)) + (let ((val (if (keywordp val) + (string val) + (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val))))) + (format stream "\"~A\"" val))) ((:date :time :datetime :timestamp) - (format stream "~D~%" val))))) + (format stream "~D" val))) + (if (eq indent 't) + (format stream " ") + (format stream "~%")))) -(defun print-enum (val enum field stream &optional (indent 0)) +(defun print-enum (val enum field stream indent) (when val - (format stream "~&~VT~A: " (+ indent 2) (proto-name field)) + (if (eq indent 't) + (format stream "~A: " (proto-name field)) + (format stream "~&~VT~A: " (+ indent 2) (proto-name field))) (let ((name (let ((e (find val (proto-values enum) :key #'proto-value))) (and e (proto-name e))))) - (format stream "~A~%" name)))) + (format stream "~A" name) + (if (eq indent 't) + (format stream " ") + (format stream "~%"))))) + + +;;; Parse objects that were serialized using the text format + +(defgeneric parse-text-format (type &key stream parse-name) + (:documentation + "Parses an object of type 'type' from the stream 'stream' using the textual format.")) + +(defmethod parse-text-format ((type symbol) + &key (stream *standard-input*) (parse-name t)) + (let ((message (find-message-for-class type))) + (assert message () + "There is no Protobuf message having the type ~S" type) + (parse-text-format message :stream stream :parse-name parse-name))) + +(defmethod parse-text-format ((message protobuf-message) + &key (stream *standard-input*) (parse-name t)) + (when parse-name + (let ((name (parse-token stream))) + (assert (string= name (proto-name message)) () + "The message is not of the expected type ~A" (proto-name message)))) + (labels ((deserialize (type trace) + (let* ((message (find-message trace type)) + (object (and message + (make-instance (or (proto-alias-for message) (proto-class message))))) + (rslots ())) + (expect-char stream #\{) + (loop + (skip-whitespace stream) + (when (eql (peek-char nil stream nil) #\}) + (read-char stream) + (dolist (slot rslots) + (setf (slot-value object slot) (nreverse (slot-value object slot)))) + (return-from deserialize object)) + (let* ((name (parse-token stream)) + (field (and name (find-field message name))) + (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field)))) + (slot (and field (proto-value field))) + msg) + (if (null field) + (skip-field stream) + (cond ((and field (eq (proto-required field) :repeated)) + (cond ((keywordp type) + (expect-char stream #\:) + (let ((val (case type + ((:float :double) (parse-float stream)) + ((:string) (parse-string stream)) + ((:bool) (if (boolean-true-p (parse-token stream)) t nil)) + (otherwise (parse-signed-int stream))))) + (when slot + (pushnew slot rslots) + (push val (slot-value object slot))))) + ((typep (setq msg (and type (or (find-message trace type) + (find-enum trace type) + (find-type-alias trace type)))) + 'protobuf-message) + (when (eql (peek-char nil stream nil) #\:) + (read-char stream)) + (let ((obj (deserialize type msg))) + (when slot + (pushnew slot rslots) + (push obj (slot-value object slot))))) + ((typep msg 'protobuf-enum) + (expect-char stream #\:) + (let* ((name (parse-token stream)) + (enum (find name (proto-values msg) :key #'proto-name :test #'string=)) + (val (and enum (proto-value enum)))) + (when slot + (pushnew slot rslots) + (push val (slot-value object slot))))) + ((typep msg 'protobuf-type-alias) + (let ((type (proto-proto-type msg))) + (expect-char stream #\:) + (let ((val (case type + ((:float :double) (parse-float stream)) + ((:string) (parse-string stream)) + ((:bool) (if (boolean-true-p (parse-token stream)) t nil)) + (otherwise (parse-signed-int stream))))) + (when slot + (pushnew slot rslots) + (push (funcall (proto-deserializer msg) val) + (slot-value object slot)))))))) + (t + (cond ((keywordp type) + (expect-char stream #\:) + (let ((val (case type + ((:float :double) (parse-float stream)) + ((:string) (parse-string stream)) + ((:bool) (if (boolean-true-p (parse-token stream)) t nil)) + (otherwise (parse-signed-int stream))))) + (when slot + (setf (slot-value object slot) val)))) + ((typep (setq msg (and type (or (find-message trace type) + (find-enum trace type) + (find-type-alias trace type)))) + 'protobuf-message) + (when (eql (peek-char nil stream nil) #\:) + (read-char stream)) + (let ((obj (deserialize type msg))) + (when slot + (setf (slot-value object slot) obj)))) + ((typep msg 'protobuf-enum) + (expect-char stream #\:) + (let* ((name (parse-token stream)) + (enum (find name (proto-values msg) :key #'proto-name :test #'string=)) + (val (and enum (proto-value enum)))) + (when slot + (setf (slot-value object slot) val)))) + ((typep msg 'protobuf-type-alias) + (let ((type (proto-proto-type msg))) + (expect-char stream #\:) + (let ((val (case type + ((:float :double) (parse-float stream)) + ((:string) (parse-string stream)) + ((:bool) (if (boolean-true-p (parse-token stream)) t nil)) + (otherwise (parse-signed-int stream))))) + (when slot + (setf (slot-value object slot) + (funcall (proto-deserializer msg) val))))))))))))))) + (declare (dynamic-extent #'deserialize)) + (deserialize (proto-class message) message))) + +(defun skip-field (stream) + "Skip either a token or a balanced {}-pair." + (ecase (peek-char nil stream nil) + ((#\:) + (read-char stream) + (skip-whitespace stream) + (parse-token-or-string stream)) + ((#\{) + (let ((depth 0)) + (loop for ch = (read-char stream) + do (cond ((eql ch #\") + (loop for ch0 = (read-char stream) + until (eql ch0 #\"))) + ((eql ch #\{) + (iincf depth)) + ((eql ch #\}) + (idecf depth))) + until (i= depth 0))))))