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 (class-of object))
  26                               &key (stream *standard-output*)
  27                                    (suppress-line-breaks *suppress-line-breaks*))
  28   (let ((message (find-message-for-class type)))
  29     (assert message ()
  30             "There is no Protobuf message having the type ~S" type)
  31     (macrolet ((read-slot (object slot reader)
  32                  ;; Don't do a boundp check, we assume the object is fully populated
  33                  ;; Unpopulated slots should be "nullable" and should contain nil
  34                  `(if ,reader
  35                     (funcall ,reader ,object)
  36                     (slot-value ,object ,slot))))
  37       (labels ((do-field (object trace indent field)
  38                  ;; We don't do cycle detection here
  39                  ;; If the client needs it, he can define his own 'print-text-format'
  40                  ;; method to clean things up first
  41                  (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  42                         (slot   (proto-value field))
  43                         (reader (proto-reader field))
  44                         msg)
  45                    (when (or slot reader)
  46                      (cond ((eq (proto-required field) :repeated)
  47                             (cond ((keywordp type)
  48                                    (map () #'(lambda (v)
  49                                                (print-prim v type field stream
  50                                                            (or suppress-line-breaks indent)))
  51                                            (read-slot object slot reader)))
  52                                   ((typep (setq msg (and type (or (find-message trace type)
  53                                                                   (find-enum trace type))))
  54                                           'protobuf-message)
  55                                    (let ((values (if slot (read-slot object slot reader) (list object))))
  56                                      (when values
  57                                        (let ((indent (+ indent 2)))
  58                                          (dolist (v values)
  59                                            (if suppress-line-breaks
  60                                              (format stream "~A: { " (proto-name field))
  61                                              (format stream "~&~VT~A: {~%" indent (proto-name field)))
  62                                            (map () (curry #'do-field v msg indent)
  63                                                    (proto-fields msg))
  64                                            (if suppress-line-breaks
  65                                              (format stream "} ")
  66                                              (format stream "~&~VT}~%" indent)))))))
  67                                   ((typep msg 'protobuf-enum)
  68                                    (map () #'(lambda (v)
  69                                                (print-enum v msg field stream
  70                                                            (or suppress-line-breaks indent)))
  71                                            (read-slot object slot reader)))))
  72                            (t
  73                             (cond ((keywordp type)
  74                                    (let ((v (read-slot object slot reader)))
  75                                      (when (or v (eq type :bool))
  76                                        (print-prim v type field stream
  77                                                    (or suppress-line-breaks indent)))))
  78                                   ((typep (setq msg (and type (or (find-message trace type)
  79                                                                   (find-enum trace type))))
  80                                           'protobuf-message)
  81                                    (let ((v (if slot (read-slot object slot reader) object)))
  82                                      (when v
  83                                        (let ((indent (+ indent 2)))
  84                                          (if suppress-line-breaks
  85                                              (format stream "~A: { " (proto-name field))
  86                                              (format stream "~&~VT~A: {~%" indent (proto-name field)))
  87                                          (map () (curry #'do-field v msg indent)
  88                                                  (proto-fields msg))
  89                                          (if suppress-line-breaks
  90                                              (format stream "} ")
  91                                              (format stream "~&~VT}~%" indent))))))
  92                                   ((typep msg 'protobuf-enum)
  93                                    (let ((v (read-slot object slot reader)))
  94                                      (when v
  95                                        (print-enum v msg field stream
  96                                                    (or suppress-line-breaks indent))))))))))))
  97         (declare (dynamic-extent #'do-field))
  98         (if suppress-line-breaks
  99           (format stream "~A { " (proto-name message))
 100           (format stream "~&~A {~%" (proto-name message)))
 101         (map () (curry #'do-field object message 0) (proto-fields message))
 102         (if suppress-line-breaks
 103           (format stream "}")
 104           (format stream "~&}~%"))
 105         nil))))
 106
 107 (defun print-prim (val type field stream indent)
 108   (when val
 109     (if (eq indent 't)
 110       (format stream "~A: " (proto-name field))
 111       (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
 112     (ecase type
 113       ((:int32 :uint32 :int64 :uint64 :sint32 :sint64
 114         :fixed32 :sfixed32 :fixed64 :sfixed64)
 115        (format stream "~D" val))
 116       ((:string)
 117        (format stream "\"~A\"" val))
 118       ((:bytes)
 119        (format stream "~S" val))
 120       ((:bool)
 121        (format stream "~A" (if val "true" "false")))
 122       ((:float :double)
 123        (format stream "~D" val))
 124       ;; A few of our homegrown types
 125       ((:symbol)
 126        (let ((val (if (keywordp val)
 127                     (string val)
 128                     (format nil "~A:~A" (package-name (symbol-package val)) (symbol-name val)))))
 129          (format stream "\"~A\"" val)))
 130       ((:date :time :datetime :timestamp)
 131        (format stream "~D" val)))
 132     (if (eq indent 't)
 133       (format stream " ")
 134       (format stream "~%"))))
 135
 136 (defun print-enum (val enum field stream indent)
 137   (when val
 138     (if (eq indent 't)
 139       (format stream "~A: " (proto-name field))
 140       (format stream "~&~VT~A: " (+ indent 2) (proto-name field)))
 141     (let ((name (let ((e (find val (proto-values enum) :key #'proto-value)))
 142                   (and e (proto-name e)))))
 143       (format stream "~A" name)
 144       (if (eq indent 't)
 145         (format stream " ")
 146         (format stream "~%")))))