text-format.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
   6 ;;;                                                                  ;;;
   7 ;;; Original author: Scott McKay                                     ;;;
   8 ;;;                                                                  ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package "PROTO-IMPL")
  12
  13
  14 ;;; Print objects using Protobufs text format
  15
  16 (defvar *suppress-line-breaks* nil
  17   "When true, don't generate line breaks in the text format")
  18
  19 (defgeneric print-text-format (object &optional type &key stream suppress-line-breaks print-name)
  20   (:documentation
  21    "Prints the object 'object' of type 'type' onto the stream 'stream' using the
  22     textual format.
  23     If 'suppress-line-breaks' is true, all the output is put on a single line."))
  24
  25 (defmethod print-text-format (object &optional type
  26                               &key (stream *standard-output*)
  27                                    (suppress-line-breaks *suppress-line-breaks*) (print-name t))
  28   (let* ((type    (or type (type-of object)))
  29          (message (find-message-for-class type)))
  30     (unless message
  31       (serialization-error "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
  35                  `(if ,reader
  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))
  45                         msg)
  46                    (when (or slot reader)
  47                      (cond ((eq (proto-required field) :repeated)
  48                             (cond ((keywordp type)
  49                                    (doseq (v (read-slot object slot reader))
  50                                      (print-prim v type field stream
  51                                                  (or suppress-line-breaks indent))))
  52                                   ((typep (setq msg (and type (or (find-message trace type)
  53                                                                   (find-enum trace type)
  54                                                                   (find-type-alias trace type))))
  55                                           'protobuf-message)
  56                                    (let ((values (if slot (read-slot object slot reader) (list object))))
  57                                      (when values
  58                                        (let ((indent (+ indent 2)))
  59                                          (dolist (v values)
  60                                            (if suppress-line-breaks
  61                                              (format stream "~A { " (proto-name field))
  62                                              (format stream "~&~VT~A {~%" indent (proto-name field)))
  63                                            (dolist (f (proto-fields msg))
  64                                             (do-field v msg indent f))
  65                                            (if suppress-line-breaks
  66                                              (format stream "} ")
  67                                              (format stream "~&~VT}~%" indent)))))))
  68                                   ((typep msg 'protobuf-enum)
  69                                    (doseq (v (read-slot object slot reader))
  70                                      (print-enum v msg field stream
  71                                                  (or suppress-line-breaks indent))))
  72                                   ((typep msg 'protobuf-type-alias)
  73                                    (let ((type (proto-proto-type msg)))
  74                                      (doseq (v (read-slot object slot reader))
  75                                        (let ((v (funcall (proto-serializer msg) v)))
  76                                          (print-prim v type field stream
  77                                                      (or suppress-line-breaks indent))))))
  78                                   (t
  79                                    (undefined-field-type "While printing ~S to text format,"
  80                                                          object type field))))
  81                            (t
  82                             (cond ((eq type :bool)
  83                                    (let ((v (cond ((or (eq (proto-required field) :required)
  84                                                        (null slot))
  85                                                    (read-slot object slot reader))
  86                                                   ((slot-boundp object slot)
  87                                                    (read-slot object slot reader))
  88                                                   (t :unbound))))
  89                                      (unless (eq v :unbound)
  90                                        (print-prim v type field stream
  91                                                    (or suppress-line-breaks indent)))))
  92                                   ((keywordp type)
  93                                    (let ((v (read-slot object slot reader)))
  94                                      (when (and v (not (equal v (proto-default field))))
  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))))
 100                                           'protobuf-message)
 101                                    (let ((v (if slot (read-slot object slot reader) object)))
 102                                      (when v
 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                                          (dolist (f (proto-fields msg))
 108                                            (do-field v msg indent f))
 109                                          (if suppress-line-breaks
 110                                              (format stream "} ")
 111                                              (format stream "~&~VT}~%" indent))))))
 112                                   ((typep msg 'protobuf-enum)
 113                                    (let ((v (read-slot object slot reader)))
 114                                      (when (and v (not (eql v (proto-default field))))
 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)))
 119                                      (when v
 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                                   (t
 125                                    (undefined-field-type "While printing ~S to text format,"
 126                                                          object type field)))))))))
 127         (declare (dynamic-extent #'do-field))
 128         (if print-name
 129           (if suppress-line-breaks
 130             (format stream "~A { " (proto-name message))
 131             (format stream "~&~A {~%" (proto-name message)))
 132           (format stream "{"))
 133         (dolist (f (proto-fields message))
 134           (do-field object message 0 f))
 135         (if suppress-line-breaks
 136           (format stream "}")
 137           (format stream "~&}~%"))
 138         nil))))
 139
 140 (defun print-prim (val type field stream indent)
 141   (when (or val (eq type :bool))
 142     (if (eq indent 't)
 143       (format stream "~A: " (proto-name field))
 144       (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
 145     (ecase type
 146       ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 147         :fixed32 :sfixed32 :fixed64 :sfixed64)
 148        (format stream "~D" val))
 149       ((:string)
 150        (format stream "\"~A\"" val))
 151       ((:bytes)
 152        (format stream "~S" val))
 153       ((:bool)
 154        (format stream "~A" (if val "true" "false")))
 155       ((:float :double)
 156        (format stream "~D" val))
 157       ;; A few of our homegrown types
 158       ((:symbol)
 159        (let ((val (if (keywordp val)
 160                     (string val)
 161                     (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
 162          (format stream "\"~A\"" val)))
 163       ((:date :time :datetime :timestamp)
 164        (format stream "~D" val)))
 165     (if (eq indent 't)
 166       (format stream " ")
 167       (format stream "~%"))))
 168
 169 (defun print-enum (val enum field stream indent)
 170   (when val
 171     (if (eq indent 't)
 172       (format stream "~A: " (proto-name field))
 173       (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
 174     (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
 175                   (and e (proto-name e)))))
 176       (format stream "~A" name)
 177       (if (eq indent 't)
 178         (format stream " ")
 179         (format stream "~%")))))
 180
 181
 182 ;;; Parse objects that were serialized using the text format
 183
 184 (defgeneric parse-text-format (type &key stream parse-name)
 185   (:documentation
 186    "Parses an object of type 'type' from the stream 'stream' using the textual format."))
 187
 188 (defmethod parse-text-format ((type symbol)
 189                               &key (stream *standard-input*) (parse-name t))
 190   (let ((message (find-message-for-class type)))
 191     (unless message
 192       (serialization-error "There is no Protobuf message having the type ~S" type))
 193     (parse-text-format message :stream stream :parse-name parse-name)))
 194
 195 (defmethod parse-text-format ((message protobuf-message)
 196                               &key (stream *standard-input*) (parse-name t))
 197   (when parse-name
 198     (let ((name (parse-token stream)))
 199       (unless (string= name (proto-name message))
 200         (serialization-error "The message is not of the expected type ~A" (proto-name message)))))
 201   (labels ((deserialize (type trace)
 202              (let* ((message (find-message trace type))
 203                     (object  (and message
 204                                   (make-instance (or (proto-alias-for message) (proto-class message)))))
 205                     (rslots ()))
 206                (expect-char stream #\{)
 207                (loop
 208                  (skip-whitespace stream)
 209                  (when (eql (peek-char nil stream nil) #\})
 210                    (read-char stream)
 211                    (dolist (slot rslots)
 212                      (setf (slot-value object slot) (nreverse (slot-value object slot))))
 213                    (return-from deserialize object))
 214                  (let* ((name  (parse-token stream))
 215                         (field (and name (find-field message name)))
 216                         (type  (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
 217                         (slot  (and field (proto-value field)))
 218                         msg)
 219                    (if (null field)
 220                      (skip-field stream)
 221                      (cond ((and field (eq (proto-required field) :repeated))
 222                             (cond ((keywordp type)
 223                                    (expect-char stream #\:)
 224                                    (let ((val (case type
 225                                                 ((:float :double) (parse-float stream))
 226                                                 ((:string) (parse-string stream))
 227                                                 ((:bool)   (if (boolean-true-p (parse-token stream)) t nil))
 228                                                 (otherwise (parse-signed-int stream)))))
 229                                      (when slot
 230                                        (pushnew slot rslots)
 231                                        (push val (slot-value object slot)))))
 232                                   ((typep (setq msg (and type (or (find-message trace type)
 233                                                                   (find-enum trace type)
 234                                                                   (find-type-alias trace type))))
 235                                           'protobuf-message)
 236                                    (when (eql (peek-char nil stream nil) #\:)
 237                                      (read-char stream))
 238                                    (let ((obj (deserialize type msg)))
 239                                      (when slot
 240                                        (pushnew slot rslots)
 241                                        (push obj (slot-value object slot)))))
 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))))
 247                                      (when slot
 248                                        (pushnew slot rslots)
 249                                        (push val (slot-value object slot)))))
 250                                   ((typep msg 'protobuf-type-alias)
 251                                    (let ((type (proto-proto-type msg)))
 252                                      (expect-char stream #\:)
 253                                      (let ((val (case type
 254                                                   ((:float :double) (parse-float stream))
 255                                                   ((:string) (parse-string stream))
 256                                                   ((:bool)   (if (boolean-true-p (parse-token stream)) t nil))
 257                                                   (otherwise (parse-signed-int stream)))))
 258                                        (when slot
 259                                          (pushnew slot rslots)
 260                                          (push (funcall (proto-deserializer msg) val)
 261                                                (slot-value object slot))))))
 262                                   (t
 263                                    (undefined-field-type "While parsing ~S from text format,"
 264                                                          message type field))))
 265                            (t
 266                             (cond ((keywordp type)
 267                                    (expect-char stream #\:)
 268                                    (let ((val (case type
 269                                                 ((:float :double) (parse-float stream))
 270                                                 ((:string) (parse-string stream))
 271                                                 ((:bool)   (if (boolean-true-p (parse-token stream)) t nil))
 272                                                 (otherwise (parse-signed-int stream)))))
 273                                      (when slot
 274                                        (setf (slot-value object slot) val))))
 275                                   ((typep (setq msg (and type (or (find-message trace type)
 276                                                                   (find-enum trace type)
 277                                                                   (find-type-alias trace type))))
 278                                           'protobuf-message)
 279                                    (when (eql (peek-char nil stream nil) #\:)
 280                                      (read-char stream))
 281                                    (let ((obj (deserialize type msg)))
 282                                      (when slot
 283                                        (setf (slot-value object slot) obj))))
 284                                   ((typep msg 'protobuf-enum)
 285                                    (expect-char stream #\:)
 286                                    (let* ((name (parse-token stream))
 287                                           (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
 288                                           (val  (and enum (proto-value enum))))
 289                                      (when slot
 290                                        (setf (slot-value object slot) val))))
 291                                   ((typep msg 'protobuf-type-alias)
 292                                    (let ((type (proto-proto-type msg)))
 293                                      (expect-char stream #\:)
 294                                      (let ((val (case type
 295                                                   ((:float :double) (parse-float stream))
 296                                                   ((:string) (parse-string stream))
 297                                                   ((:bool)   (if (boolean-true-p (parse-token stream)) t nil))
 298                                                   (otherwise (parse-signed-int stream)))))
 299                                        (when slot
 300                                          (setf (slot-value object slot)
 301                                                (funcall (proto-deserializer msg) val))))))
 302                                   (t
 303                                    (undefined-field-type "While parsing ~S from text format,"
 304                                                          message type field)))))))))))
 305     (declare (dynamic-extent #'deserialize))
 306     (deserialize (proto-class message) message)))
 307
 308 (defun skip-field (stream)
 309   "Skip either a token or a balanced {}-pair."
 310   (ecase (peek-char nil stream nil)
 311     ((#\:)
 312      (read-char stream)
 313      (skip-whitespace stream)
 314      (parse-token-or-string stream))
 315     ((#\{)
 316      (let ((depth 0))
 317        (loop for ch = (read-char stream)
 318              do (cond ((eql ch #\")
 319                        (loop for ch0 = (read-char stream)
 320                              until (eql ch0 #\")))
 321                       ((eql ch #\{)
 322                        (iincf depth))
 323                       ((eql ch #\})
 324                        (idecf depth)))
 325              until (i= depth 0))))))