X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=blobdiff_plain;f=api.lisp;h=de7fd2707ea5d1c0025974c8803a7ee610f38211;hb=53404bf93a572d058012667df1c83159d0a9fed5;hp=f5c3aef1ccdc42c01342c1d6bf43835e31686ba8;hpb=30e3ea6c2d87f50a541ba14a9f1a4d0db1545bdc;p=cl-protobufs.git

diff --git a/api.lisp b/api.lisp
index f5c3aef..de7fd27 100644
--- a/api.lisp
+++ b/api.lisp
@@ -1,8 +1,8 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;                                                                  ;;;
-;;; Confidential and proprietary information of ITA Software, Inc.   ;;;
+;;; Free Software published under an MIT-like license. See LICENSE   ;;;
 ;;;                                                                  ;;;
-;;; Copyright (c) 2012 ITA Software, Inc.  All rights reserved.      ;;;
+;;; Copyright (c) 2012 Google, Inc.  All rights reserved.            ;;;
 ;;;                                                                  ;;;
 ;;; Original author: Scott McKay                                     ;;;
 ;;;                                                                  ;;;
@@ -11,27 +11,172 @@
 (in-package "PROTO-IMPL")
 
 
-;;; A Protobufs2-compatible API, whose names are taken from the Python API
+;;; Other API functions
+
+(defgeneric object-initialized-p (object type)
+  (:documentation
+   "Returns true iff all of the fields of 'object' are initialized."))  
+
+(defmethod object-initialized-p (object (type symbol))
+  (let ((message (find-message-for-class type)))
+    (assert message ()
+            "There is no Protobuf message having the type ~S" type)
+    (object-initialized-p object message)))
+
+(defmethod object-initialized-p (object (message protobuf-message))
+  (macrolet ((read-slot (object slot reader)
+               `(if ,reader
+                  (funcall ,reader ,object)
+                  (slot-value ,object ,slot))))
+    (labels ((initialized-p (object trace field)
+               (let* ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
+                      (slot   (proto-value field))
+                      (reader (proto-reader field))
+                      msg)
+                 (when slot
+                   (cond ((eq (proto-required field) :repeated)
+                          ;; We're claiming that empty repeated fields are initialized,
+                          ;; which might not be correct
+                          (cond ((keywordp type) t)
+                                ((typep (setq msg (and type (or (find-message trace type)
+                                                                (find-enum trace type))))
+                                        'protobuf-message)
+                                 (let ((values (read-slot object slot reader)))
+                                   (dolist (value values t)
+                                     (unless (every #'(lambda (field)
+                                                        (initialized-p value msg field))
+                                                    (proto-fields msg))
+                                       (return-from object-initialized-p nil)))))
+                                ((typep msg 'protobuf-enum) t)))
+                         (t
+                          (cond ((keywordp type)
+                                 (or (slot-initialized-p object message slot)
+                                     (return-from object-initialized-p nil)))
+                                ((typep (setq msg (and type (or (find-message trace type)
+                                                                (find-enum trace type))))
+                                        'protobuf-message)
+                                 (unless (slot-initialized-p object message slot)
+                                   (return-from object-initialized-p nil))
+                                 (let ((value (read-slot object slot reader)))
+                                   (unless (every #'(lambda (field)
+                                                      (initialized-p value msg field))
+                                                  (proto-fields msg))
+                                     (return-from object-initialized-p nil))))
+                                ((typep msg 'protobuf-enum)
+                                 (or (slot-initialized-p object message slot)
+                                     (return-from object-initialized-p nil))))))))))
+            (declare (dynamic-extent #'initialized-p))
+            (every #'(lambda (field)
+                       (initialized-p object message field))
+                   (proto-fields message)))))
+
+
+(defgeneric slot-initialized-p (object type slot)
+  (:documentation
+   "Returns true iff the field 'slot' in 'object' is initialized."))
+
+(defmethod slot-initialized-p (object (type symbol) slot)
+  (let ((message (find-message-for-class type)))
+    (assert message ()
+            "There is no Protobuf message having the type ~S" type)
+    (slot-initialized-p object message slot)))
+
+(defmethod slot-initialized-p (object (message protobuf-message) slot)
+  (macrolet ((read-slot (object slot reader)
+               `(if ,reader
+                  (funcall ,reader ,object)
+                  (slot-value ,object ,slot))))
+    (let ((field (find-field message slot)))
+      (when field
+        (let ((type   (if (eq (proto-class field) 'boolean) :bool (proto-class field)))
+              (slot   (proto-value field))
+              (reader (proto-reader field)))
+          (cond ((null slot) nil)
+                ((or (eq (proto-required field) :required)
+                     (eq type :bool))
+                 (slot-boundp object slot))
+                (t (not (null (read-slot object slot reader))))))))))
+
+
+(defgeneric reinitialize-object (object type)
+  (:documentation
+   "Reset all the fields of 'object' to their initial values."))
+
+(defmethod reinitialize-object (object (type symbol))
+  (let ((message (find-message-for-class type)))
+    (assert message ()
+            "There is no Protobuf message having the type ~S" type)
+    (reinitialize-object object message)))
+
+(defmethod reinitialize-object (object (message protobuf-message))
+  (dolist (field (proto-fields message))
+    (reinitialize-field object message field))
+  object)
+
+(defgeneric reinitialize-field (object message field)
+  (:method (object (message protobuf-message) field)
+    (macrolet ((write-slot (object slot writer value)
+                 `(if ,writer
+                    (funcall ,writer ,object ,value)
+                    (setf (slot-value ,object ,slot) ,value))))
+      (let ((default (proto-default field))
+            (slot    (proto-value field))
+            (writer  (proto-writer field)))
+        (cond ((null slot)
+               (unless (empty-default-p field)
+                 (write-slot object slot writer default)))
+              (t
+               (if (empty-default-p field)
+                 (slot-makunbound object slot)
+                 (write-slot object slot writer default))))))))
+
+(defgeneric reinitialize-slot (object message slot)
+  (:method (object (message protobuf-message) slot)
+    (let ((field (find slot (proto-fields message) :key #'proto-value)))
+      (reinitialize-field object message field))))
+
+
+;;; A Python-like, Protobufs2-compatible API
+
+(defgeneric is-initialized (object)
+  (:documentation
+   "Returns true iff all of the fields of 'object' are initialized.")
+  (:method ((object standard-object))
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class)))
+      (assert message ()
+              "There is no Protobufs message for the class ~S" class)
+      (object-initialized-p object message))))
 
 (defgeneric clear (object)
   (:documentation
    "Initialize all of the fields of 'object' to their default values.")
   (:method ((object standard-object))
-    (let* ((message (find-message-for-class (class-of object)))
-           (proto   '---need-to-have-messages-store-the-parent---))
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class)))
       (assert message ()
-              "There is no Protobufs message for the class ~S" (class-of object))
-      message proto)))
+              "There is no Protobufs message for the class ~S" class)
+      (reinitialize-object object message))))
 
-(defgeneric is-initialized (object)
+(defgeneric has-field (object slot)
   (:documentation
-   "Returns true iff all of the fields of 'object' are initialized.")
-  (:method ((object standard-object))
-    (let* ((message (find-message-for-class (class-of object)))
-           (proto   '---need-to-have-messages-store-the-parent---))
+   "Returns true iff the field 'slot' in 'object' is initialized.")
+  (:method ((object standard-object) slot)
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class)))
+      (assert message ()
+              "There is no Protobufs message for the class ~S" class)
+      (slot-initialized-p object message slot))))
+
+(defgeneric clear-field (object slot)
+  (:documentation
+   "Initialize the field 'slot' of 'object' to its default value.")
+  (:method ((object standard-object) slot)
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class)))
       (assert message ()
-              "There is no Protobufs message for the class ~S" (class-of object))
-      message proto)))
+              "There is no Protobufs message for the class ~S" class)
+      (reinitialize-slot object message slot))))
 
 ;; This is simpler than 'object-size', but doesn't fully support aliasing
 (defgeneric octet-size (object)
@@ -39,59 +184,71 @@
    "Returns the number of octets required to encode 'object' using the wire format.
     'object' is an object whose Lisp class corresponds to a Protobufs message.")
   (:method ((object standard-object))
-    (let* ((message (find-message-for-class (class-of object)))
-           (type    (and message (proto-class message)))
-           (proto   '---need-to-have-messages-store-the-parent---))
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class))
+           (type    (and message (proto-class message))))
       (assert message ()
-              "There is no Protobufs message for the class ~S" (class-of object))
+              "There is no Protobufs message for the class ~S" class)
       (let ((visited (make-hash-table)))
-        (object-size object type proto :visited visited)))))
+        (object-size object type visited)))))
 
 ;; This is simpler than 'serialize-object', but doesn't fully support aliasing
-(defgeneric serialize (object buffer &optional start end)
+(defgeneric serialize (object &optional buffer start end)
   (:documentation
    "Serialize 'object' into 'buffer' using the wire format, starting at the index
    'start' and going no farther than 'end'. 'object' is an object whose Lisp class
-   corresponds to a Protobufs message.")
-  (:method ((object standard-object) buffer &optional start end)
+   corresponds to a Protobufs message.
+   Returns two values, the final index and the buffer.")
+  (:method ((object standard-object) &optional buffer (start 0) end)
     (declare (ignore end))
-    (let* ((message (find-message-for-class (class-of object)))
-           (type    (and message (proto-class message)))
-           (proto   '---need-to-have-messages-store-the-parent---))
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class))
+           (type    (and message (proto-class message))))
       (assert message ()
-              "There is no Protobufs message for the class ~S" (class-of object))
+              "There is no Protobufs message for the class ~S" class)
       (let* ((visited (make-hash-table))
-	     (size    (object-size object type proto :visited visited))
+             (size    (object-size object type visited))
              (start   (or start 0))
-             (buffer  (make-array size :element-type '(unsigned-byte 8))))
-        (serialize-object object type proto buffer start :visited visited)
-        buffer))))
+             (buffer  (or buffer (make-byte-vector size))))
+        (assert (>= (length buffer) size) ()
+                "The buffer ~S is not large enough to hold ~S" buffer object)
+        (multiple-value-bind (nbuf nend)
+            (serialize-object object type buffer start visited)
+        (declare (ignore nbuf))
+        (values nend buffer))))))
 
-;; This is simpler than 'deserialize-object', but doesn't fully support aliasing
 (defgeneric merge-from-array (object buffer &optional start end)
   (:documentation
-   "Deserialize the object encoded in 'buffer' into 'object', starting at the index
-    'start' and ending at 'end'. 'object' is an object whose Lisp class corresponds
-    to a Protobufs message.")
-  (:method ((object standard-object) buffer &optional start end)
-    (let* ((message (find-message-for-class (class-of object)))
-           (type    (and message (proto-class message)))
-           (proto   '---need-to-have-messages-store-the-parent---))
+   "Deserialize the object encoded in 'buffer' and merge it into 'object'.
+    Deserialization starts at the index 'start' and ends at 'end'.
+    'object' must an object whose Lisp class corresponds to the message
+    being deserialized.
+    The return value is the updated object.")
+  (:method ((object standard-object) buffer &optional (start 0) (end (length buffer)))
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class))
+           (type    (and message (proto-class message))))
       (assert message ()
-              "There is no Protobufs message for the class ~S" (class-of object))
+              "There is no Protobufs message for the class ~S" class)
       (let* ((start  (or start 0))
              (end    (or end (length buffer))))
-        (deserialize-object type proto buffer start end)))))
+        (merge-from-message object (deserialize-object type buffer start end))))))
 
-(defgeneric merge-from-message (object source-object)
+(defgeneric merge-from-message (object source)
   (:documentation
-   "")
-  (:method ((object standard-object) (source-object standard-object))
-    (assert (eq (class-of object) (class-of source-object)) ()
-            "The objects ~S and ~S are of not of the same class" object source-object)
-    (let* ((message (find-message-for-class (class-of object)))
-           (type    (and message (proto-class message)))
-           (proto   '---need-to-have-messages-store-the-parent---))
+   "Merge the fields from the source object 'source' into 'object'.
+    The two objects must be of the same type.
+    Singular fields will be overwritten, with embedded messages being be merged.
+    Repeated fields will be concatenated.
+    The return value is the updated object 'object'.")
+  (:method ((object standard-object) (source standard-object))
+    (let* ((class   (type-of object))
+           (message (find-message-for-class class))
+           (type    (and message (proto-class message))))
       (assert message ()
-              "There is no Protobufs message for the class ~S" (class-of object))
-      message type proto)))
+              "There is no Protobufs message for the class ~S" class)
+      (assert (eq class (type-of source)) ()
+              "The objects ~S and ~S are of not of the same class" object source)
+      ;;--- Do this (should return side-effected 'object', not 'source')
+      type
+      source)))