From b57da00813d6f4c039d13f87cf4b3fb182f1f3dd Mon Sep 17 00:00:00 2001 From: Scott McKay Date: Wed, 11 Apr 2012 15:10:26 +0000 Subject: [PATCH] It's gonna be a heck of a lot easier debugging CL-Stubby if we can parse the text format of Protobufs messages git-svn-id: http://svn.internal.itasoftware.com/svn/ita/branches/qres/swm/borgify-1/qres/lisp/quux/protobufs@538712 f8382938-511b-0410-9cdd-bb47b084005c --- api.lisp | 34 ++++++++++-------- examples.lisp | 24 +++++++++++++ parser.lisp | 11 +++++- proto-pkgdcl.lisp | 11 +++--- text-format.lisp | 89 +++++++++++++++++++++++++++++++++++++++++++++-- 5 files changed, 146 insertions(+), 23 deletions(-) diff --git a/api.lisp b/api.lisp index 1f53242..f1acc04 100644 --- a/api.lisp +++ b/api.lisp @@ -17,9 +17,10 @@ (:documentation "Initialize all of the fields of 'object' to their default values.") (:method ((object standard-object)) - (let ((message (find-message-for-class (class-of object)))) + (let* ((class (class-of object)) + (message (find-message-for-class class))) (assert message () - "There is no Protobufs message for the class ~S" (class-of object)) + "There is no Protobufs message for the class ~S" class) ;;--- Do this message))) @@ -27,9 +28,10 @@ (:documentation "Returns true iff all of the fields of 'object' are initialized.") (:method ((object standard-object)) - (let ((message (find-message-for-class (class-of object)))) + (let* ((class (class-of object)) + (message (find-message-for-class class))) (assert message () - "There is no Protobufs message for the class ~S" (class-of object)) + "There is no Protobufs message for the class ~S" class) ;;--- Do this message))) @@ -39,10 +41,11 @@ "Returns the number of octets required to encode 'object' using the wire format. 'object' is an object whose Lisp class corresponds to a Protobufs message.") (:method ((object standard-object)) - (let* ((message (find-message-for-class (class-of object))) + (let* ((class (class-of object)) + (message (find-message-for-class class)) (type (and message (proto-class message)))) (assert message () - "There is no Protobufs message for the class ~S" (class-of object)) + "There is no Protobufs message for the class ~S" class) (let ((visited (make-hash-table))) (object-size object type visited))))) @@ -54,10 +57,11 @@ corresponds to a Protobufs message.") (:method ((object standard-object) &optional buffer (start 0) end) (declare (ignore end)) - (let* ((message (find-message-for-class (class-of object))) + (let* ((class (class-of object)) + (message (find-message-for-class class)) (type (and message (proto-class message)))) (assert message () - "There is no Protobufs message for the class ~S" (class-of object)) + "There is no Protobufs message for the class ~S" class) (let* ((visited (make-hash-table)) (size (object-size object type visited)) (start (or start 0)) @@ -74,10 +78,11 @@ 'start' and ending at 'end'. 'object' is an object whose Lisp class corresponds to a Protobufs message.") (:method ((object standard-object) buffer &optional (start 0) (end (length buffer))) - (let* ((message (find-message-for-class (class-of object))) + (let* ((class (class-of object)) + (message (find-message-for-class class)) (type (and message (proto-class message)))) (assert message () - "There is no Protobufs message for the class ~S" (class-of object)) + "There is no Protobufs message for the class ~S" class) (let* ((start (or start 0)) (end (or end (length buffer)))) (deserialize-object type buffer start end))))) @@ -86,11 +91,12 @@ (:documentation "") (:method ((object standard-object) (source-object standard-object)) - (assert (eq (class-of object) (class-of source-object)) () - "The objects ~S and ~S are of not of the same class" object source-object) - (let* ((message (find-message-for-class (class-of object))) + (let* ((class (class-of object)) + (message (find-message-for-class class)) (type (and message (proto-class message)))) + (assert (eq class (class-of source-object)) () + "The objects ~S and ~S are of not of the same class" object source-object) (assert message () - "There is no Protobufs message for the class ~S" (class-of object)) + "There is no Protobufs message for the class ~S" class) ;;--- Do this type))) diff --git a/examples.lisp b/examples.lisp index 85f1e2e..d27b887 100644 --- a/examples.lisp +++ b/examples.lisp @@ -237,21 +237,45 @@ (proto:print-text-format test1) (proto:print-text-format (proto:deserialize-object 'proto-test1 tser1)) +(let ((text (with-output-to-string (s) + (proto:print-text-format test1 'proto-test1 :stream s)))) + (with-input-from-string (s text) + (proto:parse-text-format 'proto-test1 :stream s))) (proto:print-text-format test2) (proto:print-text-format (proto:deserialize-object 'proto-test2 tser2)) +(let ((text (with-output-to-string (s) + (proto:print-text-format test2 'proto-test2 :stream s)))) + (with-input-from-string (s text) + (proto:parse-text-format 'proto-test2 :stream s))) (proto:print-text-format test3) (proto:print-text-format (proto:deserialize-object 'proto-test3 tser3)) +(let ((text (with-output-to-string (s) + (proto:print-text-format test3 'proto-test3 :stream s)))) + (with-input-from-string (s text) + (proto:parse-text-format 'proto-test3 :stream s))) (proto:print-text-format test4) (proto:print-text-format (proto:deserialize-object 'proto-test4 tser4)) +(let ((text (with-output-to-string (s) + (proto:print-text-format test4 'proto-test4 :stream s)))) + (with-input-from-string (s text) + (proto:parse-text-format 'proto-test4 :stream s))) (proto:print-text-format test5) (proto:print-text-format (proto:deserialize-object 'proto-test5 tser5)) +(let ((text (with-output-to-string (s) + (proto:print-text-format test5 'proto-test5 :stream s)))) + (with-input-from-string (s text) + (proto:parse-text-format 'proto-test5 :stream s))) (proto:print-text-format test6) (proto:print-text-format (proto:deserialize-object 'proto-test6 tser6)) +(let ((text (with-output-to-string (s) + (proto:print-text-format test6 'proto-test6 :stream s)))) + (with-input-from-string (s text) + (proto:parse-text-format 'proto-test6 :stream s))) ||# #|| diff --git a/parser.lisp b/parser.lisp index 87d2450..a518a44 100644 --- a/parser.lisp +++ b/parser.lisp @@ -124,6 +124,15 @@ (skip-whitespace stream) (return (parse-integer (coerce token 'string))))))) +(defun parse-float (stream) + "Parse the next token in the stream as a float, then skip the following whitespace. The returned value is the float." + (when (let ((ch (peek-char nil stream nil))) + (or (digit-char-p ch) (eql ch #\-))) + (let ((token (parse-token stream))) + (when token + (skip-whitespace stream) + (coerce (read-from-string token) 'float))))) + ;;; The parser itself @@ -390,7 +399,7 @@ :class (proto->class-name name *protobuf-package*) :name name :input-type (proto->class-name in *protobuf-package*) - :input-name in + :input-name in :output-type (proto->class-name out *protobuf-package*) :output-name out :options opts))) diff --git a/proto-pkgdcl.lisp b/proto-pkgdcl.lisp index 8d0fbe4..3eaf55d 100644 --- a/proto-pkgdcl.lisp +++ b/proto-pkgdcl.lisp @@ -28,12 +28,10 @@ "PROTOBUF-SERVICE" "PROTOBUF-RPC" - ;; Printing - "WRITE-PROTOBUF" - - ;; Parsing + ;; .proto parsing and printing "PARSE-PROTOBUF-FROM-FILE" "PARSE-PROTOBUF-FROM-STREAM" + "WRITE-PROTOBUF" ;; Protobuf defining macros "DEFINE-PROTO" @@ -49,14 +47,15 @@ "WRITE-PROTOBUF-SCHEMA-FOR-CLASSES" "GENERATE-PROTOBUF-SCHEMA-FOR-CLASSES" - ;; Serialization + ;; Serialization and deserialization (wire format) "SERIALIZE-OBJECT-TO-STREAM" "SERIALIZE-OBJECT" "DESERIALIZE-OBJECT-FROM-STREAM" "DESERIALIZE-OBJECT" "OBJECT-SIZE" - ;; Text printing + ;; Serialization and deserialization (text format) + "PARSE-TEXT-FORMAT" "PRINT-TEXT-FORMAT") ;; The "compatibility" API, whose names are taken from the Python API diff --git a/text-format.lisp b/text-format.lisp index defd486..adbb2b6 100644 --- a/text-format.lisp +++ b/text-format.lisp @@ -22,10 +22,11 @@ textual format. If 'suppress-line-breaks' is true, all the output is put on a single line.")) -(defmethod print-text-format (object &optional (type (class-of object)) +(defmethod print-text-format (object &optional type &key (stream *standard-output*) (suppress-line-breaks *suppress-line-breaks*)) - (let ((message (find-message-for-class type))) + (let* ((type (or type (class-of object))) + (message (find-message-for-class type))) (assert message () "There is no Protobuf message having the type ~S" type) (macrolet ((read-slot (object slot reader) @@ -144,3 +145,87 @@ (if (eq indent 't) (format stream " ") (format stream "~%"))))) + + +;;; Parse objects that were serialized using the text format + +(defgeneric parse-text-format (type &key stream) + (: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*)) + (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))) + +(defmethod parse-text-format ((message protobuf-message) &key (stream *standard-input*)) + (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) + (when rslots + (map:map #'(lambda (s v) (setf (slot-value object s) (nreverse v))) rslots)) + (return-from deserialize object)) + (let* ((name (prog1 (parse-token stream) + (expect-char stream #\:))) + (field (and name (find name (proto-fields message) :key #'proto-name :test #'string=))) + (type (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field)))) + (slot (and field (proto-value field))) + msg) + (if (null field) + ;;---*** This needs to skip a token or a balanced {}-pair + (parse-token stream) + (cond ((and field (eq (proto-required field) :repeated)) + (cond ((keywordp type) + (let ((val (case type + ((:float :double) (parse-float stream)) + ((:string) (parse-string stream)) + ((:bool) (parse-token stream)) + (otherwise (parse-int stream))))) + (when slot + (push val (map:get slot (or rslots (setq rslots (map:make-map)))))))) + ((typep (setq msg (and type (or (find-message trace type) + (find-enum trace type)))) + 'protobuf-message) + (let ((obj (deserialize type msg))) + (when slot + (push obj (map:get slot (or rslots (setq rslots (map:make-map)))))))) + ((typep msg 'protobuf-enum) + (let* ((name (parse-token stream)) + (enum (find name (proto-values msg) :key #'proto-name :test #'string=)) + (val (and enum (proto-value enum)))) + (when slot + (push val (map:get slot (or rslots (setq rslots (map:make-map)))))))))) + (t + (cond ((keywordp type) + (let ((val (case type + ((:float :double) (parse-float stream)) + ((:string) (parse-string stream)) + ((:bool) (parse-token stream)) + (otherwise (parse-int stream))))) + (when slot + (setf (slot-value object slot) val)))) + ((typep (setq msg (and type (or (find-message trace type) + (find-enum trace type)))) + 'protobuf-message) + (let ((obj (deserialize type msg))) + (when slot + (setf (slot-value object slot) obj)))) + ((typep msg 'protobuf-enum) + (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))))))))))))) + (declare (dynamic-extent #'deserialize)) + (deserialize (proto-class message) message))) -- 2.45.2