api.lisp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;                                                                  ;;;
   3 ;;; Free Software published under an MIT-like license. See LICENSE   ;;;
   4 ;;;                                                                  ;;;
   5 ;;; Copyright (c) 2012-2013 Google, 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     (unless message
  23       (serialization-error "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     (unless message
  81       (serialization-error "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     (unless message
 108       (serialization-error "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   (dolist (field (proto-fields message))
 113     (reinitialize-field object message field))
 114   object)
 115
 116 (defgeneric reinitialize-field (object message field)
 117   (:method (object (message protobuf-message) field)
 118     (macrolet ((write-slot (object slot writer value)
 119                  `(if ,writer
 120                     (funcall ,writer ,object ,value)
 121                     (setf (slot-value ,object ,slot) ,value))))
 122       (let ((default (proto-default field))
 123             (slot    (proto-value field))
 124             (writer  (proto-writer field)))
 125         (cond ((null slot)
 126                (unless (empty-default-p field)
 127                  (write-slot object slot writer default)))
 128               (t
 129                (if (empty-default-p field)
 130                  (slot-makunbound object slot)
 131                  (write-slot object slot writer default))))))))
 132
 133 (defgeneric reinitialize-slot (object message slot)
 134   (:method (object (message protobuf-message) slot)
 135     (let ((field (find slot (proto-fields message) :key #'proto-value)))
 136       (reinitialize-field object message field))))
 137
 138 \f
 139 ;;; A Python-like, Protobufs2-compatible API
 140
 141 (defgeneric is-initialized (object)
 142   (:documentation
 143    "Returns true iff all of the fields of 'object' are initialized.")
 144   (:method ((object standard-object))
 145     (let* ((class   (type-of object))
 146            (message (find-message-for-class class)))
 147       (unless message
 148         (serialization-error "There is no Protobufs message for the class ~S" class))
 149       (object-initialized-p object message))))
 150
 151 (defgeneric clear (object)
 152   (:documentation
 153    "Initialize all of the fields of 'object' to their default values.")
 154   (:method ((object standard-object))
 155     (let* ((class   (type-of object))
 156            (message (find-message-for-class class)))
 157       (unless message
 158         (serialization-error "There is no Protobufs message for the class ~S" class))
 159       (reinitialize-object object message))))
 160
 161 (defgeneric has-field (object slot)
 162   (:documentation
 163    "Returns true iff the field 'slot' in 'object' is initialized.")
 164   (:method ((object standard-object) slot)
 165     (let* ((class   (type-of object))
 166            (message (find-message-for-class class)))
 167       (unless message
 168         (serialization-error "There is no Protobufs message for the class ~S" class))
 169       (slot-initialized-p object message slot))))
 170
 171 (defgeneric clear-field (object slot)
 172   (:documentation
 173    "Initialize the field 'slot' of 'object' to its default value.")
 174   (:method ((object standard-object) slot)
 175     (let* ((class   (type-of object))
 176            (message (find-message-for-class class)))
 177       (unless message
 178         (serialization-error "There is no Protobufs message for the class ~S" class))
 179       (reinitialize-slot object message slot))))
 180
 181 ;; This is simpler than 'object-size', but doesn't fully support aliasing
 182 (defgeneric octet-size (object)
 183   (:documentation
 184    "Returns the number of octets required to encode 'object' using the wire format.
 185     'object' is an object whose Lisp class corresponds to a Protobufs message.")
 186   (:method ((object standard-object))
 187     (let* ((class   (type-of object))
 188            (message (find-message-for-class class))
 189            (type    (and message (proto-class message))))
 190       (unless message
 191         (serialization-error "There is no Protobufs message for the class ~S" class))
 192       (let ((visited (make-size-cache object type)))
 193         (object-size object type visited)))))
 194
 195 ;; This is simpler than 'serialize-object', but doesn't fully support aliasing
 196 (defgeneric serialize (object &optional buffer start end)
 197   (:documentation
 198    "Serialize 'object' into 'buffer' using the wire format, starting at the index
 199    'start' and going no farther than 'end'. 'object' is an object whose Lisp class
 200    corresponds to a Protobufs message.
 201    Returns two values, the final index and the buffer.")
 202   (:method ((object standard-object) &optional buffer (start 0) end)
 203     (declare (ignore end))
 204     (let* ((class   (type-of object))
 205            (message (find-message-for-class class))
 206            (type    (and message (proto-class message))))
 207       (unless message
 208         (serialization-error "There is no Protobufs message for the class ~S" class))
 209       (let* ((visited (make-size-cache object type))
 210              (size    (object-size object type visited))
 211              (start   (or start 0))
 212              (buffer  (or buffer (make-byte-vector size))))
 213         (unless (>= (length buffer) size)
 214           (serialization-error "The buffer ~S is not large enough to hold ~S" buffer))
 215         (multiple-value-bind (nbuf nend)
 216             (serialize-object object type buffer start visited)
 217           (declare (ignore nbuf))
 218           (values nend buffer))))))
 219
 220 (defgeneric merge-from-array (object buffer &optional start end)
 221   (:documentation
 222    "Deserialize the object encoded in 'buffer' and merge it into 'object'.
 223     Deserialization starts at the index 'start' and ends at 'end'.
 224     'object' must an object whose Lisp class corresponds to the message
 225     being deserialized.
 226     The return value is the updated object.")
 227   (:method ((object standard-object) buffer &optional (start 0) (end (length buffer)))
 228     (let* ((class   (type-of object))
 229            (message (find-message-for-class class))
 230            (type    (and message (proto-class message))))
 231       (unless message
 232         (serialization-error "There is no Protobufs message for the class ~S" class))
 233       (let* ((start  (or start 0))
 234              (end    (or end (length buffer))))
 235         (merge-from-message object (deserialize-object type buffer start end))))))
 236
 237 (defgeneric merge-from-message (object source)
 238   (:documentation
 239    "Merge the fields from the source object 'source' into 'object'.
 240     The two objects must be of the same type.
 241     Singular fields will be overwritten, with embedded messages being be merged.
 242     Repeated fields will be concatenated.
 243     The return value is the updated object 'object'.")
 244   (:method ((object standard-object) (source standard-object))
 245     (let* ((class   (type-of object))
 246            (message (find-message-for-class class))
 247            (type    (and message (proto-class message))))
 248       (unless message
 249         (serialization-error "There is no Protobufs message for the class ~S" class))
 250       (unless (eq class (type-of source))
 251         (serialization-error "The objects ~S and ~S are of not of the same class" object source))
 252       ;;--- Do this (should return side-effected 'object', not 'source')
 253       type
 254       source)))