Add some support for testing: 'protobufs-equal'

Passes 'precheckin'.

git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/quux/protobufs@543998 f8382938-511b-0410-9cdd-bb47b084005c

diff --git a/cl-protobufs.rst b/cl-protobufs.rst
index 685acce75d2198b9563583eccb53d25833402e3c..edf86ee25a9791866bf77e157f135050bc83c11c 100644 (file)
--- a/cl-protobufs.rst
+++ b/cl-protobufs.rst
@@ -490,7 +490,7 @@ the types of fields. The following type expressions are supported:
  - ``signed-byte`` and ``unsigned-byte``
  - ``single-float`` and ``double-float``
  - ``string``and ``character``
- - ``(simple-array (unsigned-byte 8))``
+ - ``proto:byte-vector`` (equivalent to ``(array (unsigned-byte 8))``)
  - ``boolean``
  - ``(member ...)``, where all the members are symbols or keywords or ``nil``
  - the name of a class that corresponds to another Protobufs message

diff --git a/proto-pkgdcl.lisp b/proto-pkgdcl.lisp
index 63a916048b43cee2f9546f147b36ebdc028b449e..ca4b244375d2b3cad3e77c83396998c795c2d82f 100644 (file)
--- a/proto-pkgdcl.lisp
+++ b/proto-pkgdcl.lisp
@@ -16,8 +16,9 @@
 (defpackage protobufs
   (:nicknames :proto)
 
-  ;; For repeated slots
+  ;; Some types useful for defining messages
   (:export
+   "BYTE-VECTOR"
    "LIST-OF")
 
   ;; ASDF module type
@@ -51,8 +52,9 @@
    "DEFINE-GROUP"
    "DEFINE-SERVICE"
 
-   ;; Upgradability testing
+   ;; Upgradability and equality testing
    "PROTOBUF-UPGRADABLE"
+   "PROTOBUFS-EQUAL"
 
    ;; CLOS to Protobufs transformer
    "WRITE-PROTOBUF-SCHEMA-FOR-CLASSES"

diff --git a/upgradable.lisp b/upgradable.lisp
index 7f8be81755537293435044c3020d58cadd706e32..3a2d6a12dd92b0363a8ec2a9a104aff698827f44 100644 (file)
--- a/upgradable.lisp
+++ b/upgradable.lisp
@@ -15,7 +15,7 @@
 
 (defgeneric protobuf-upgradable (old new &optional old-parent new-parent)
   (:documentation
-   "Returns true if and only if the old protobuf schema can be upgraded to
+   "Returns true if and only if the old Protobufs schema can be upgraded to
     the new schema.
     'old' is the old object (schema, enum, message, etc), 'new' is the new one.
     'old-parent' is the \"parent\" of 'old', 'new-parent' is the parent of 'new'.
@@ -179,3 +179,158 @@
    (upgrade-warn (string= (proto-output-name old) (proto-output-name new))
                  "Output type for ~A, ~A, is not upgradable to ~A"
                  (format nil  "~A.~A" (proto-name old-service) (proto-name old)))))
+
+\f
+;;; Are two protobufs equal?
+
+;; This is useful for testing purposes, but not much else
+(defgeneric protobufs-equal (proto1 proto2)
+  (:documentation
+   "Returns true if and only if the two Protobufs schemas are equal."))
+
+;; These methods are pretty similar to the 'protobuf-upgradable' methods above
+(defmethod protobufs-equal ((proto1 protobuf) (proto2 protobuf))
+  (and
+   (eql    (proto-class proto1) (proto-class proto2))
+   (equalp (proto-name proto1) (proto-name proto2))
+   (equalp (proto-syntax proto1) (proto-syntax proto2))
+   (equalp (proto-package proto1) (proto-package proto2))
+   (equalp (proto-lisp-package proto1) (proto-lisp-package proto2))
+   (equalp (proto-imports proto1) (proto-imports proto2))
+   (= (length (proto-options proto1)) (length (proto-options proto2)))
+   (loop for option1 in (proto-options proto1)
+         as option2 = (find (proto-name option1) (proto-options proto2)
+                            :key #'proto-name :test #'string=)
+         always (and option2 (protobufs-equal option1 option2)))
+   (= (length (proto-enums proto1)) (length (proto-enums proto2)))
+   (loop for enum1 in (proto-enums proto1)
+         as enum2 = (find (proto-name enum1) (proto-enums proto2)
+                          :key #'proto-name :test #'string=)
+         always (and enum2 (protobufs-equal enum1 enum2)))
+   (= (length (proto-messages proto1)) (length (proto-messages proto2)))
+   (loop for msg1 in (proto-messages proto1)
+         as msg2 = (find-if #'(lambda (msg2)
+                                (and (string= (proto-name msg1) (proto-name msg2))
+                                     (eql (proto-message-type msg1) (proto-message-type msg2))))
+                            (proto-messages proto2))
+         always (and msg2 (protobufs-equal msg1 msg2)))
+   (= (length (proto-services proto1)) (length (proto-services proto2)))
+   (loop for svc1 in (proto-services proto1)
+         as svc2 = (find (proto-name svc1) (proto-services proto2)
+                         :key #'proto-name :test #'string=)
+         always (and svc2 (protobufs-equal svc1 svc2)))))
+
+(defmethod protobufs-equal ((option1 protobuf-option) (option2 protobuf-option))
+  (and
+   (string= (proto-name option1) (proto-name option2))
+   (equalp  (proto-value option1) (proto-value option2))
+   (equalp  (proto-type option1) (proto-type option2))))
+
+(defmethod protobufs-equal ((enum1 protobuf-enum) (enum2 protobuf-enum))
+  (and
+   (eql    (proto-class enum1) (proto-class enum2))
+   (equalp (proto-name enum1) (proto-name enum2))
+   (equalp (proto-alias-for enum1) (proto-alias-for enum2))
+   (= (length (proto-options enum1)) (length (proto-options enum2)))
+   (loop for option1 in (proto-options enum1)
+         as option2 = (find (proto-name option1) (proto-options enum2)
+                            :key #'proto-name :test #'string=)
+         always (and option2 (protobufs-equal option1 option2)))
+   (= (length (proto-values enum1)) (length (proto-values enum2)))
+   (loop for val1 in (proto-values enum1)
+         as val2 = (find (proto-name val1) (proto-values enum2)
+                         :key #'proto-name :test #'string=)
+         always (and val2 (protobufs-equal val1 val2)))))
+
+(defmethod protobufs-equal ((value1 protobuf-enum-value) (value2 protobuf-enum-value))
+  (and 
+   (eql    (proto-class value1) (proto-class value2))
+   (equalp (proto-name value1) (proto-name value2))
+   (eql    (proto-index value1) (proto-index value2))
+   (equalp (proto-value value1) (proto-value value2))))
+
+(defmethod protobufs-equal ((message1 protobuf-message) (message2 protobuf-message))
+  (and
+   (eql    (proto-class message1) (proto-class message2))
+   (equalp (proto-name message1) (proto-name message2))
+   (equalp (proto-alias-for message1) (proto-alias-for message2))
+   (eql    (proto-message-type message1) (proto-message-type message2))
+   (= (length (proto-options message1)) (length (proto-options message2)))
+   (loop for option1 in (proto-options message1)
+         as option2 = (find (proto-name option1) (proto-options message2)
+                            :key #'proto-name :test #'string=)
+         always (and option2 (protobufs-equal option1 option2)))
+   (= (length (proto-enums message1)) (length (proto-enums message2)))
+   (loop for enum1 in (proto-enums message1)
+         as enum2 = (find (proto-name enum1) (proto-enums message2)
+                          :key #'proto-name :test #'string=)
+         always (and enum2 (protobufs-equal enum1 enum2)))
+   (= (length (proto-messages message1)) (length (proto-messages message2)))
+   (loop for msg1 in (proto-messages message1)
+         as msg2 = (find-if #'(lambda (msg2)
+                                (and (string= (proto-name msg1) (proto-name msg2))
+                                     (eql (proto-message-type msg1) (proto-message-type msg2))))
+                            (proto-messages message2))
+         always (and msg2 (protobufs-equal msg1 msg2)))
+   (= (length (proto-fields message1)) (length (proto-fields message2)))
+   (loop for fld1 in (proto-fields message1)
+         as fld2 = (find (proto-name fld1) (proto-fields message2)
+                         :key #'proto-name :test #'string=)
+         always (and fld2 (protobufs-equal fld1 fld2)))
+   (= (length (proto-extensions message1)) (length (proto-extensions message2)))
+   (loop for ext1 in (proto-extensions message1)
+         for ext2 in (proto-extensions message2)
+         always (protobufs-equal ext1 ext2))))
+
+(defmethod protobufs-equal ((field1 protobuf-field) (field2 protobuf-field))
+  (and
+   (eql    (proto-class field1) (proto-class field2))
+   (equalp (proto-name field1) (proto-name field2))
+   (equalp (proto-type field1) (proto-type field2))
+   (eql    (proto-required field1) (proto-required field2))
+   (eql    (proto-value field1) (proto-value field2))
+   (eql    (proto-index field1) (proto-index field2))
+   (eql    (proto-reader field1) (proto-reader field2))
+   (eql    (proto-writer field1) (proto-writer field2))
+   (equalp (proto-default field1) (proto-default field2))
+   (eql    (proto-packed field1) (proto-packed field2))
+   (eql    (proto-message-type field1) (proto-message-type field2))
+   (= (length (proto-options field1)) (length (proto-options field2)))
+   (loop for option1 in (proto-options field1)
+         as option2 = (find (proto-name option1) (proto-options field2)
+                            :key #'proto-name :test #'string=)
+         always (and option2 (protobufs-equal option1 option2)))))
+
+(defmethod protobufs-equal ((extension1 protobuf-extension) (extension2 protobuf-extension))
+  (and
+   (eql (proto-extension-from extension1) (proto-extension-from extension2))
+   (eql (proto-extension-to extension1) (proto-extension-to extension2))))
+
+(defmethod protobufs-equal ((service1 protobuf-service) (service2 protobuf-service))
+  (and
+   (eql    (proto-class service1) (proto-class service2))
+   (equalp (proto-name service1) (proto-name service2))
+   (= (length (proto-options service1)) (length (proto-options service2)))
+   (loop for option1 in (proto-options service1)
+         as option2 = (find (proto-name option1) (proto-options service2)
+                            :key #'proto-name :test #'string=)
+         always (and option2 (protobufs-equal option1 option2)))
+   (= (length (proto-methods service1)) (length (proto-methods service2)))
+   (loop for method1 in (proto-methods service1)
+         as method2 = (find (proto-name method1) (proto-methods service2)
+                            :key #'proto-name :test #'string=)
+         always (and method2 (protobufs-equal method1 method2)))))
+
+(defmethod protobufs-equal ((method1 protobuf-method) (method2 protobuf-method))
+  (and
+   (eql    (proto-class method1) (proto-class method2))
+   (equalp (proto-name method1) (proto-name method2))
+   (eql    (proto-input-type method1) (proto-input-type method2))
+   (eql    (proto-output-type method1) (proto-output-type method2))
+   (equalp (proto-input-name method1) (proto-input-name method2))
+   (equalp (proto-output-name method1) (proto-output-name method2))
+   (= (length (proto-options method1)) (length (proto-options method2)))
+   (loop for option1 in (proto-options method1)
+         as option2 = (find (proto-name option1) (proto-options method2)
+                            :key #'proto-name :test #'string=)
+         always (and option2 (protobufs-equal option1 option2)))))

diff --git a/utilities.lisp b/utilities.lisp
index 73fbbe073aea50537e85ec440ac0971989fee201..361d0d94dd89544e79b083924853b3b3567858e4 100644 (file)
--- a/utilities.lisp
+++ b/utilities.lisp
@@ -200,12 +200,18 @@
          (apply ,function ,(car args) more-args))
     form))
 
-;; A parameterized list types for repeated fields (not type-checked!)
+
+;; A parameterized list type for repeated fields
+;; The elements aren't type-checked
 (deftype list-of (type)
   (if (eq type 'null)
     'null
     'list))
 
+;; This corresponds to the :bytes Protobufs type
+(deftype byte-vector () '(array (unsigned-byte 8)))
+
+
 ;;; Code generation utilities
 
 (defvar *proto-name-separators* '(#\- #\_ #\/ #\space))