X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=text-format.lisp;h=3b4bb5c1332c6dc974298cb0f9f8202824b512cd;hb=b72957b729e4bf8561bfa2e2c2c81d02feb3cf1b;hp=edb9ad7e00e11cd40bb5a8bd915b71f542868452;hpb=b6317f29a2ab10103e1220a2e5c234efb61e4f7d;p=cl-protobufs.git diff --git a/text-format.lisp b/text-format.lisp index edb9ad7..3b4bb5c 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 ;;; ;;; ;;; @@ -16,7 +16,7 @@ (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) +(defgeneric print-text-format (object &optional type &key stream suppress-line-breaks print-name) (:documentation "Prints the object 'object' of type 'type' onto the stream 'stream' using the textual format. @@ -24,7 +24,7 @@ (defmethod print-text-format (object &optional type &key (stream *standard-output*) - (suppress-line-breaks *suppress-line-breaks*)) + (suppress-line-breaks *suppress-line-breaks*) (print-name t)) (let* ((type (or type (type-of object))) (message (find-message-for-class type))) (assert message () @@ -46,12 +46,12 @@ (when (or slot reader) (cond ((eq (proto-required field) :repeated) (cond ((keywordp type) - (map () #'(lambda (v) - (print-prim v type field stream - (or suppress-line-breaks indent))) - (read-slot object slot reader))) + (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-enum trace type) + (find-type-alias trace type)))) 'protobuf-message) (let ((values (if slot (read-slot object slot reader) (list object)))) (when values @@ -60,16 +60,24 @@ (if suppress-line-breaks (format stream "~A { " (proto-name field)) (format stream "~&~VT~A {~%" indent (proto-name field))) - (map () (curry #'do-field v msg indent) - (proto-fields msg)) + (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) - (map () #'(lambda (v) - (print-enum v msg field stream - (or suppress-line-breaks indent))) - (read-slot object slot reader))))) + (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 + (undefined-field-type "While printing ~S to text format," + object type field)))) (t (cond ((eq type :bool) (let ((v (cond ((or (eq (proto-required field) :required) @@ -83,11 +91,12 @@ (or suppress-line-breaks indent))))) ((keywordp type) (let ((v (read-slot object slot reader))) - (when v + (when (and v (not (equal v (proto-default field)))) (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-enum trace type) + (find-type-alias trace type)))) 'protobuf-message) (let ((v (if slot (read-slot object slot reader) object))) (when v @@ -95,21 +104,34 @@ (if suppress-line-breaks (format stream "~A { " (proto-name field)) (format stream "~&~VT~A {~%" indent (proto-name field))) - (map () (curry #'do-field v msg indent) - (proto-fields msg)) + (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 + (when (and v (not (eql v (proto-default field)))) (print-enum v msg field stream - (or suppress-line-breaks indent)))))))))))) + (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)))))) + (t + (undefined-field-type "While printing ~S to text format," + object type field))))))))) (declare (dynamic-extent #'do-field)) - (if suppress-line-breaks - (format stream "~A { " (proto-name message)) - (format stream "~&~A {~%" (proto-name message))) - (map () (curry #'do-field object message 0) (proto-fields message)) + (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 "~&}~%")) @@ -159,20 +181,23 @@ ;;; Parse objects that were serialized using the text format -(defgeneric parse-text-format (type &key stream) +(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*)) +(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-text-format message :stream stream :parse-name parse-name))) -(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))) +(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 @@ -205,7 +230,8 @@ (pushnew slot rslots) (push val (slot-value object slot))))) ((typep (setq msg (and type (or (find-message trace type) - (find-enum trace type)))) + (find-enum trace type) + (find-type-alias trace type)))) 'protobuf-message) (when (eql (peek-char nil stream nil) #\:) (read-char stream)) @@ -220,7 +246,22 @@ (val (and enum (proto-value enum)))) (when slot (pushnew slot rslots) - (push val (slot-value object slot))))))) + (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 + (undefined-field-type "While parsing ~S from text format," + message type field)))) (t (cond ((keywordp type) (expect-char stream #\:) @@ -232,7 +273,8 @@ (when slot (setf (slot-value object slot) val)))) ((typep (setq msg (and type (or (find-message trace type) - (find-enum trace type)))) + (find-enum trace type) + (find-type-alias trace type)))) 'protobuf-message) (when (eql (peek-char nil stream nil) #\:) (read-char stream)) @@ -245,24 +287,39 @@ (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)))))))))))) - (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))))))) - (declare (dynamic-extent #'deserialize #'skip-field)) + (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)))))) + (t + (undefined-field-type "While parsing ~S from text format," + message type field))))))))))) + (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))))))