text-format.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012 ITA Software, 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)
  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*))
  28   (let* ((type    (or type (class-of object)))
  29          (message (find-message-for-class type)))
  30     (assert message ()
  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
  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                                    (map () #'(lambda (v)
  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))))
  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                                            (map () (curry #'do-field v msg indent)
  64                                                    (proto-fields msg))
  65                                            (if suppress-line-breaks
  66                                              (format stream "} ")
  67                                              (format stream "~&~VT}~%" indent)))))))
  68                                   ((typep msg 'protobuf-enum)
  69                                    (map () #'(lambda (v)
  70                                                (print-enum v msg field stream
  71                                                            (or suppress-line-breaks indent)))
  72                                            (read-slot object slot reader)))))
  73                            (t
  74                             (cond ((keywordp type)
  75                                    (let ((v (read-slot object slot reader)))
  76                                      (when (or v (eq type :bool))
  77                                        (print-prim v type field stream
  78                                                    (or suppress-line-breaks indent)))))
  79                                   ((typep (setq msg (and type (or (find-message trace type)
  80                                                                   (find-enum trace type))))
  81                                           'protobuf-message)
  82                                    (let ((v (if slot (read-slot object slot reader) object)))
  83                                      (when v
  84                                        (let ((indent (+ indent 2)))
  85                                          (if suppress-line-breaks
  86                                              (format stream "~A: { " (proto-name field))
  87                                              (format stream "~&~VT~A: {~%" indent (proto-name field)))
  88                                          (map () (curry #'do-field v msg indent)
  89                                                  (proto-fields msg))
  90                                          (if suppress-line-breaks
  91                                              (format stream "} ")
  92                                              (format stream "~&~VT}~%" indent))))))
  93                                   ((typep msg 'protobuf-enum)
  94                                    (let ((v (read-slot object slot reader)))
  95                                      (when v
  96                                        (print-enum v msg field stream
  97                                                    (or suppress-line-breaks indent))))))))))))
  98         (declare (dynamic-extent #'do-field))
  99         (if suppress-line-breaks
 100           (format stream "~A { " (proto-name message))
 101           (format stream "~&~A {~%" (proto-name message)))
 102         (map () (curry #'do-field object message 0) (proto-fields message))
 103         (if suppress-line-breaks
 104           (format stream "}")
 105           (format stream "~&}~%"))
 106         nil))))
 107
 108 (defun print-prim (val type field stream indent)
 109   (when val
 110     (if (eq indent 't)
 111       (format stream "~A: " (proto-name field))
 112       (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
 113     (ecase type
 114       ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 115         :fixed32 :sfixed32 :fixed64 :sfixed64)
 116        (format stream "~D" val))
 117       ((:string)
 118        (format stream "\"~A\"" val))
 119       ((:bytes)
 120        (format stream "~S" val))
 121       ((:bool)
 122        (format stream "~A" (if val "true" "false")))
 123       ((:float :double)
 124        (format stream "~D" val))
 125       ;; A few of our homegrown types
 126       ((:symbol)
 127        (let ((val (if (keywordp val)
 128                     (string val)
 129                     (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
 130          (format stream "\"~A\"" val)))
 131       ((:date :time :datetime :timestamp)
 132        (format stream "~D" val)))
 133     (if (eq indent 't)
 134       (format stream " ")
 135       (format stream "~%"))))
 136
 137 (defun print-enum (val enum field stream indent)
 138   (when val
 139     (if (eq indent 't)
 140       (format stream "~A: " (proto-name field))
 141       (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
 142     (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
 143                   (and e (proto-name e)))))
 144       (format stream "~A" name)
 145       (if (eq indent 't)
 146         (format stream " ")
 147         (format stream "~%")))))
 148
 149
 150 ;;; Parse objects that were serialized using the text format
 151
 152 (defgeneric parse-text-format (type &key stream)
 153   (:documentation
 154    "Parses an object of type 'type' from the stream 'stream' using the textual format."))
 155
 156 (defmethod parse-text-format ((type symbol) &key (stream *standard-input*))
 157   (let ((message (find-message-for-class type)))
 158     (assert message ()
 159             "There is no Protobuf message having the type ~S" type)
 160     (parse-text-format message :stream stream)))
 161
 162 (defmethod parse-text-format ((message protobuf-message) &key (stream *standard-input*))
 163   (let ((name (parse-token stream)))
 164     (assert (string= name (proto-name message)) ()
 165             "The message is not of the expected type ~A" (proto-name message)))
 166   (labels ((deserialize (type trace)
 167              (let* ((message (find-message trace type))
 168                     (object  (and message
 169                                   (make-instance (or (proto-alias-for message) (proto-class message)))))
 170                     (rslots ()))
 171                (expect-char stream #\{)
 172                (loop
 173                  (skip-whitespace stream)
 174                  (when (eql (peek-char nil stream nil) #\})
 175                    (read-char stream)
 176                    (dolist (slot rslots)
 177                      (setf (slot-value object slot) (nreverse (slot-value object slot))))
 178                    (return-from deserialize object))
 179                  (let* ((name  (prog1 (parse-token stream)
 180                                  (expect-char stream #\:)))
 181                         (field (and name (find name (proto-fields message) :key #'proto-name :test #'string=)))
 182                         (type  (and field (if (eq (proto-class field) 'boolean) :bool (proto-class field))))
 183                         (slot  (and field (proto-value field)))
 184                         msg)
 185                    (if (null field)
 186                      ;;---*** This needs to skip a token or a balanced {}-pair
 187                      (parse-token stream)
 188                      (cond ((and field (eq (proto-required field) :repeated))
 189                             (cond ((keywordp type)
 190                                    (let ((val (case type
 191                                                 ((:float :double) (parse-float stream))
 192                                                 ((:string) (parse-string stream))
 193                                                 ((:bool)   (parse-token stream))
 194                                                 (otherwise (parse-int stream)))))
 195                                      (when slot
 196                                        (pushnew slot rslots)
 197                                        (push val (slot-value object slot)))))
 198                                   ((typep (setq msg (and type (or (find-message trace type)
 199                                                                   (find-enum trace type))))
 200                                           'protobuf-message)
 201                                      (let ((obj (deserialize type msg)))
 202                                        (when slot
 203                                          (pushnew slot rslots)
 204                                          (push obj (slot-value object slot)))))
 205                                   ((typep msg 'protobuf-enum)
 206                                    (let* ((name (parse-token stream))
 207                                           (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
 208                                           (val  (and enum (proto-value enum))))
 209                                      (when slot
 210                                        (pushnew slot rslots)
 211                                        (push val (slot-value object slot)))))))
 212                            (t
 213                             (cond ((keywordp type)
 214                                    (let ((val (case type
 215                                                 ((:float :double) (parse-float stream))
 216                                                 ((:string) (parse-string stream))
 217                                                 ((:bool)   (parse-token stream))
 218                                                 (otherwise (parse-int stream)))))
 219                                      (when slot
 220                                        (setf (slot-value object slot) val))))
 221                                   ((typep (setq msg (and type (or (find-message trace type)
 222                                                                   (find-enum trace type))))
 223                                           'protobuf-message)
 224                                    (let ((obj (deserialize type msg)))
 225                                      (when slot
 226                                        (setf (slot-value object slot) obj))))
 227                                   ((typep msg 'protobuf-enum)
 228                                    (let* ((name (parse-token stream))
 229                                           (enum (find name (proto-values msg) :key #'proto-name :test #'string=))
 230                                           (val  (and enum (proto-value enum))))
 231                                      (when slot
 232                                        (setf (slot-value object slot) val)))))))))))))
 233     (declare (dynamic-extent #'deserialize))
 234     (deserialize (proto-class message) message)))