api.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 ;;; Other API functions
  15
  16 (defgeneric object-initialized-p (object type)
  17   (:documentation
  18    "Returns true iff all of the fields of 'object' are initialized."))
  19
  20 (defmethod object-initialized-p (object (type symbol))
  21   (let ((message (find-message-for-class type)))
  22     (assert message ()
  23             "There is no Protobuf message having the type ~S" type)
  24     (object-initialized-p object message)))
  25
  26 (defmethod object-initialized-p (object (message protobuf-message))
  27   (macrolet ((read-slot (object slot reader)
  28                `(if ,reader
  29                   (funcall ,reader ,object)
  30                   (slot-value ,object ,slot))))
  31     (labels ((initialized-p (object trace field)
  32                (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  33                       (slot   (proto-value field))
  34                       (reader (proto-reader field))
  35                       msg)
  36                  (when slot
  37                    (cond ((eq (proto-required field) :repeated)
  38                           ;; We're claiming that empty repeated fields are initialized,
  39                           ;; which might not be correct
  40                           (cond ((keywordp type) t)
  41                                 ((typep (setq msg (and type (or (find-message trace type)
  42                                                                 (find-enum trace type))))
  43                                         'protobuf-message)
  44                                  (let ((values (read-slot object slot reader)))
  45                                    (dolist (value values t)
  46                                      (unless (every #'(lambda (field)
  47                                                         (initialized-p value msg field))
  48                                                     (proto-fields msg))
  49                                        (return-from object-initialized-p nil)))))
  50                                 ((typep msg 'protobuf-enum) t)))
  51                          (t
  52                           (cond ((keywordp type)
  53                                  (or (slot-initialized-p object message slot)
  54                                      (return-from object-initialized-p nil)))
  55                                 ((typep (setq msg (and type (or (find-message trace type)
  56                                                                 (find-enum trace type))))
  57                                         'protobuf-message)
  58                                  (unless (slot-initialized-p object message slot)
  59                                    (return-from object-initialized-p nil))
  60                                  (let ((value (read-slot object slot reader)))
  61                                    (unless (every #'(lambda (field)
  62                                                       (initialized-p value msg field))
  63                                                   (proto-fields msg))
  64                                      (return-from object-initialized-p nil))))
  65                                 ((typep msg 'protobuf-enum)
  66                                  (or (slot-initialized-p object message slot)
  67                                      (return-from object-initialized-p nil))))))))))
  68             (declare (dynamic-extent #'initialized-p))
  69             (every #'(lambda (field)
  70                        (initialized-p object message field))
  71                    (proto-fields message)))))
  72
  73
  74 (defgeneric slot-initialized-p (object type slot)
  75   (:documentation
  76    "Returns true iff the field 'slot' in 'object' is initialized."))
  77
  78 (defmethod slot-initialized-p (object (type symbol) slot)
  79   (let ((message (find-message-for-class type)))
  80     (assert message ()
  81             "There is no Protobuf message having the type ~S" type)
  82     (slot-initialized-p object message slot)))
  83
  84 (defmethod slot-initialized-p (object (message protobuf-message) slot)
  85   (macrolet ((read-slot (object slot reader)
  86                `(if ,reader
  87                   (funcall ,reader ,object)
  88                   (slot-value ,object ,slot))))
  89     (let ((field (find-field message slot)))
  90       (when field
  91         (let ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
  92               (slot   (proto-value field))
  93               (reader (proto-reader field)))
  94           (cond ((null slot) nil)
  95                 ((or (eq (proto-required field) :required)
  96                      (eq type :bool))
  97                  (slot-boundp object slot))
  98                 (t (not (null (read-slot object slot reader))))))))))
  99
 100
 101 (defgeneric reinitialize-object (object type)
 102   (:documentation
 103    "Reset all the fields of 'object' to their initial values."))
 104
 105 (defmethod reinitialize-object (object (type symbol))
 106   (let ((message (find-message-for-class type)))
 107     (assert message ()
 108             "There is no Protobuf message having the type ~S" type)
 109     (reinitialize-object object message)))
 110
 111 (defmethod reinitialize-object (object (message protobuf-message))
 112   (macrolet ((write-slot (object slot writer value)
 113                `(if ,writer
 114                   (funcall ,writer ,object ,value)
 115                   (setf (slot-value ,object ,slot) ,value))))
 116     (dolist (field (proto-fields message))
 117       (let* ((type    (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
 118              (default (protobuf-default-to-clos-init (proto-default field) type))
 119              (slot    (proto-value field))
 120              (writer  (proto-writer field)))
 121         (cond ((null slot))
 122               ((or (eq (proto-required field) :required)
 123                    (eq type :bool))
 124                (if (proto-default field)
 125                  (write-slot object slot writer default)
 126                  (slot-makunbound object slot)))
 127               (t
 128                (write-slot object slot writer default))))))
 129   object)
 130
 131 \f
 132 ;;; A Python-like, Protobufs2-compatible API
 133
 134 (defgeneric is-initialized (object)
 135   (:documentation
 136    "Returns true iff all of the fields of 'object' are initialized.")
 137   (:method ((object standard-object))
 138     (let* ((class   (type-of object))
 139            (message (find-message-for-class class)))
 140       (assert message ()
 141               "There is no Protobufs message for the class ~S" class)
 142       (object-initialized-p object message))))
 143
 144 (defgeneric has-field (object slot)
 145   (:documentation
 146    "Returns true iff the field 'slot' in 'object' is initialized.")
 147   (:method ((object standard-object) slot)
 148     (let* ((class   (type-of object))
 149            (message (find-message-for-class class)))
 150       (assert message ()
 151               "There is no Protobufs message for the class ~S" class)
 152       (slot-initialized-p object message slot))))
 153
 154 (defgeneric clear (object)
 155   (:documentation
 156    "Initialize all of the fields of 'object' to their default values.")
 157   (:method ((object standard-object))
 158     (let* ((class   (type-of object))
 159            (message (find-message-for-class class)))
 160       (assert message ()
 161               "There is no Protobufs message for the class ~S" class)
 162       (reinitialize-object object message))))
 163
 164 ;; This is simpler than 'object-size', but doesn't fully support aliasing
 165 (defgeneric octet-size (object)
 166   (:documentation
 167    "Returns the number of octets required to encode 'object' using the wire format.
 168     'object' is an object whose Lisp class corresponds to a Protobufs message.")
 169   (:method ((object standard-object))
 170     (let* ((class   (type-of object))
 171            (message (find-message-for-class class))
 172            (type    (and message (proto-class message))))
 173       (assert message ()
 174               "There is no Protobufs message for the class ~S" class)
 175       (let ((visited (make-hash-table)))
 176         (object-size object type visited)))))
 177
 178 ;; This is simpler than 'serialize-object', but doesn't fully support aliasing
 179 (defgeneric serialize (object &optional buffer start end)
 180   (:documentation
 181    "Serialize 'object' into 'buffer' using the wire format, starting at the index
 182    'start' and going no farther than 'end'. 'object' is an object whose Lisp class
 183    corresponds to a Protobufs message.")
 184   (:method ((object standard-object) &optional buffer (start 0) end)
 185     (declare (ignore end))
 186     (let* ((class   (type-of object))
 187            (message (find-message-for-class class))
 188            (type    (and message (proto-class message))))
 189       (assert message ()
 190               "There is no Protobufs message for the class ~S" class)
 191       (let* ((visited (make-hash-table))
 192              (size    (object-size object type visited))
 193              (start   (or start 0))
 194              (buffer  (or buffer (make-array size :element-type '(unsigned-byte 8)))))
 195         (assert (>= (length buffer) size) ()
 196                 "The buffer ~S is not large enough to hold ~S" buffer object)
 197         (serialize-object object type buffer start visited)
 198         buffer))))
 199
 200 (defgeneric merge-from-array (object buffer &optional start end)
 201   (:documentation
 202    "Deserialize the object encoded in 'buffer' and merge it into 'object'.
 203     Deserialization starts at the index 'start' and ends at 'end'.
 204     'object' must an object whose Lisp class corresponds to the message
 205     being deserialized.
 206     The return value is the updated object.")
 207   (:method ((object standard-object) buffer &optional (start 0) (end (length buffer)))
 208     (let* ((class   (type-of object))
 209            (message (find-message-for-class class))
 210            (type    (and message (proto-class message))))
 211       (assert message ()
 212               "There is no Protobufs message for the class ~S" class)
 213       (let* ((start  (or start 0))
 214              (end    (or end (length buffer))))
 215         (merge-from-message object (deserialize-object type buffer start end))))))
 216
 217 (defgeneric merge-from-message (object source)
 218   (:documentation
 219    "Merge the fields from the source object 'source' into 'object'.
 220     The two objects must be of the same type.
 221     Singular fields will be overwritten, with embedded messages being be merged.
 222     Repeated fields will be concatenated.
 223     The return value is the updated object 'object'.")
 224   (:method ((object standard-object) (source standard-object))
 225     (let* ((class   (type-of object))
 226            (message (find-message-for-class class))
 227            (type    (and message (proto-class message))))
 228       (assert message ()
 229               "There is no Protobufs message for the class ~S" class)
 230       (assert (eq class (type-of source)) ()
 231               "The objects ~S and ~S are of not of the same class" object source)
 232       ;;--- Do this
 233       type
 234       object)))