From: Scott McKay Date: Wed, 20 Jun 2012 17:39:41 +0000 (+0000) Subject: Random things discovered while working on Stubby support... X-Git-Url: https://asedeno.scripts.mit.edu/gitweb/?a=commitdiff_plain;h=5ae2da974f384ab7fa4dc23b566a0e02c8e676fb;p=cl-protobufs.git Random things discovered while working on Stubby support... - Make the 'find-xxx' support searching "relative to" another namespace. - There was a bug in the non-optimized deserializer when deserializing a repeated slot into a vector; create a stretchy vector on demand if it's needed. - 'define-extends' should wrap 'eval-when' around the generated 'defsetf' forms so that they are visible at compile time. - Fix a formatting bug in the export list in the Lisp printer. - Straighten of the ASDF declaration for the tests. - Add the Protobufs test suite to QRes, to keep things honest. Passes 'precheckin' with the new Protobufs unit tests in place. git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/libs/cl-protobufs@550053 f8382938-511b-0410-9cdd-bb47b084005c --- diff --git a/define-proto.lisp b/define-proto.lisp index 79918e0..00219e6 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -198,6 +198,7 @@ :options (remove-options options "default" "packed") :documentation documentation)) (index 0) + ;; Only now can we bind *protobuf* to the new message (*protobuf* message)) (with-collectors ((slots collect-slot) (forms collect-form)) @@ -309,6 +310,7 @@ :extensions (copy-list (proto-extensions message)) :message-type :extends ;this message is an extension :documentation documentation))) + ;; Only now can we bind *protobuf* to the new extended message (*protobuf* extends) (index 0)) (assert message () @@ -353,7 +355,6 @@ ,@(and writer `((defmethod ,writer ((object ,type) value) (declare (type ,stype value)) (setf (gethash object ,stable) value)))) - ,@(and writer `((defsetf ,reader ,writer))) ;; For Python compatibility (defmethod get-extension ((object ,type) (slot (eql ',sname))) (values (gethash object ,stable ,default))) @@ -365,7 +366,11 @@ (declare (ignore value)) foundp)) (defmethod clear-extension ((object ,type) (slot (eql ',sname))) - (remhash object ,stable))))))) + (remhash object ,stable))) + ,@(and writer + ;; 'defsetf' needs to be visible at compile time + `((eval-when (:compile-toplevel :load-toplevel :execute) + (defsetf ,reader ,writer)))))))) (setf (proto-message-type extra-field) :extends) ;this field is an extension (setf (proto-fields extends) (nconc (proto-fields extends) (list extra-field))) (setf (proto-extended-fields extends) (nconc (proto-extended-fields extends) (list extra-field))))))) @@ -405,8 +410,6 @@ ,@(and writer `((defmethod ,writer ((object ,type) value) (declare (type ,stype value)) (setf (gethash object ,stable) value)))) - ,@(and writer `((defsetf ,reader ,writer))) - ;; For Python compatibility (defmethod get-extension ((object ,type) (slot (eql ',sname))) (values (gethash object ,stable ,default))) (defmethod set-extension ((object ,type) (slot (eql ',sname)) value) @@ -417,7 +420,10 @@ (declare (ignore value)) foundp)) (defmethod clear-extension ((object ,type) (slot (eql ',sname))) - (remhash object ,stable))))) + (remhash object ,stable))) + ,@(and writer + `((eval-when (:compile-toplevel :load-toplevel :execute) + (defsetf ,reader ,writer)))))) ;; This so that (de)serialization works (setf (proto-reader field) reader (proto-writer field) writer))) @@ -500,12 +506,14 @@ :class type :name name :qualified-name (make-qualified-name *protobuf* name) + :parent *protobuf* :alias-for alias-for :conc-name conc-name :options (remove-options options "default" "packed") :message-type :group ;this message is a group :documentation documentation)) (index 0) + ;; Only now can we bind *protobuf* to the (group) message (*protobuf* message)) (with-collectors ((slots collect-slot) (forms collect-form)) diff --git a/examples.lisp b/examples.lisp index f4809bd..2b7c933 100644 --- a/examples.lisp +++ b/examples.lisp @@ -41,17 +41,33 @@ ;; A pretty useful subset of geographic business data (defclass geodata () ;; This one stores the data in lists - ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries) - (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions) - (cities :type (proto:list-of qres-core::city) :initform () :initarg :cities) - (airports :type (proto:list-of qres-core::airport) :initform () :initarg :airports))) + ((countries :type (proto:list-of qres-core::country) + :initform () + :initarg :countries) + (regions :type (proto:list-of qres-core::region) + :initform () + :initarg :regions) + (cities :type (proto:list-of qres-core::city) + :initform () + :initarg :cities) + (airports :type (proto:list-of qres-core::airport) + :initform () + :initarg :airports))) (defclass geodata-v () ;; This one stores the data in vectors - ((countries :type (proto:vector-of qres-core::country) :initform #() :initarg :countries) - (regions :type (proto:vector-of qres-core::region) :initform #() :initarg :regions) - (cities :type (proto:vector-of qres-core::city) :initform #() :initarg :cities) - (airports :type (proto:vector-of qres-core::airport) :initform #() :initarg :airports))) + ((countries :type (proto:vector-of qres-core::country) + :initform #() + :initarg :countries) + (regions :type (proto:vector-of qres-core::region) + :initform #() + :initarg :regions) + (cities :type (proto:vector-of qres-core::city) + :initform #() + :initarg :cities) + (airports :type (proto:vector-of qres-core::airport) + :initform #() + :initarg :airports))) (setq *geodata* (proto:generate-schema-for-classes '(qres-core::country diff --git a/model-classes.lisp b/model-classes.lisp index be000e3..af97784 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -99,14 +99,15 @@ (defun find-qualified-name (name protos &key (proto-key #'proto-name) (full-key #'proto-qualified-name) - (lisp-key #'proto-class)) - "Find something by its string name. - First do a simple name match. - Failing that, exhaustively search qualified names." + (lisp-key #'proto-class) + relative-to) + "Find something by its string name, first doing a simple name match, + and, if that fails, exhaustively searching qualified names." + (declare (ignore relative-to)) (or (find name protos :key proto-key :test #'string=) + ;;--- This needs more sophisticated search, e.g., relative to current namespace (find name protos :key full-key :test #'string=) - ;; Get desperate in the face of incomplete namespace support - ;;--- This needs to be more sophisticated than just using Lisp packages + ;; Maybe we can find the symbol in Lisp land? (multiple-value-bind (name package path other) (proto->class-name name) (declare (ignore path)) @@ -199,12 +200,13 @@ ;; packaged "dot" the name (strcat (proto-package schema) "." name)) -(defgeneric find-enum (protobuf type) +(defgeneric find-enum (protobuf type &optional relative-to) (:documentation "Given a Protobufs schema or message and the name of an enum type, returns the Protobufs enum corresponding to the type.")) -(defmethod find-enum ((schema protobuf-schema) (type symbol)) +(defmethod find-enum ((schema protobuf-schema) (type symbol) &optional relative-to) + (declare (ignore relative-to)) (labels ((find-it (schema) (let ((enum (find type (proto-enums schema) :key #'proto-class))) (when enum @@ -212,20 +214,23 @@ (map () #'find-it (proto-imported-schemas schema))))) (find-it schema))) -(defmethod find-enum ((schema protobuf-schema) (name string)) - (labels ((find-it (schema) - (let ((enum (find-qualified-name name (proto-enums schema)))) - (when enum - (return-from find-enum enum)) - (map () #'find-it (proto-imported-schemas schema))))) - (find-it schema))) - -(defgeneric find-message (protobuf type) +(defmethod find-enum ((schema protobuf-schema) (name string) &optional relative-to) + (let ((relative-to (or relative-to schema))) + (labels ((find-it (schema) + (let ((enum (find-qualified-name name (proto-enums schema) + :relative-to relative-to))) + (when enum + (return-from find-enum enum)) + (map () #'find-it (proto-imported-schemas schema))))) + (find-it schema)))) + +(defgeneric find-message (protobuf type &optional relative-to) (:documentation "Given a Protobufs schema or message and a type name or class name, returns the Protobufs message corresponding to the type.")) -(defmethod find-message ((schema protobuf-schema) (type symbol)) +(defmethod find-message ((schema protobuf-schema) (type symbol) &optional relative-to) + (declare (ignore relative-to)) ;; Extended messages "shadow" non-extended ones (labels ((find-it (schema) (let ((message (or (find type (proto-extenders schema) :key #'proto-class) @@ -235,17 +240,20 @@ (map () #'find-it (proto-imported-schemas schema))))) (find-it schema))) -(defmethod find-message ((schema protobuf-schema) (type class)) - (find-message schema (class-name type))) - -(defmethod find-message ((schema protobuf-schema) (name string)) - (labels ((find-it (schema) - (let ((message (or (find-qualified-name name (proto-extenders schema)) - (find-qualified-name name (proto-messages schema))))) - (when message - (return-from find-message message)) - (map () #'find-it (proto-imported-schemas schema))))) - (find-it schema))) +(defmethod find-message ((schema protobuf-schema) (type class) &optional relative-to) + (find-message schema (class-name type) (or relative-to schema))) + +(defmethod find-message ((schema protobuf-schema) (name string) &optional relative-to) + (let ((relative-to (or relative-to schema))) + (labels ((find-it (schema) + (let ((message (or (find-qualified-name name (proto-extenders schema) + :relative-to relative-to) + (find-qualified-name name (proto-messages schema) + :relative-to relative-to)))) + (when message + (return-from find-message message)) + (map () #'find-it (proto-imported-schemas schema))))) + (find-it schema)))) (defgeneric find-service (protobuf name) (:documentation @@ -469,40 +477,48 @@ (make-qualified-name (proto-parent message) (strcat (proto-name message) "." name)) (strcat (proto-name message) "." name))) -(defmethod find-message ((message protobuf-message) (type symbol)) +(defmethod find-message ((message protobuf-message) (type symbol) &optional relative-to) ;; Extended messages "shadow" non-extended ones (or (find type (proto-extenders message) :key #'proto-class) (find type (proto-messages message) :key #'proto-class) - (find-message (proto-parent message) type))) + (find-message (proto-parent message) type (or relative-to message)))) -(defmethod find-message ((message protobuf-message) (type class)) - (find-message message (class-name type))) +(defmethod find-message ((message protobuf-message) (type class) &optional relative-to) + (find-message message (class-name type) (or relative-to message))) -(defmethod find-message ((message protobuf-message) (name string)) - (or (find-qualified-name name (proto-extenders message)) - (find-qualified-name name (proto-messages message)) - (find-message (proto-parent message) name))) +(defmethod find-message ((message protobuf-message) (name string) &optional relative-to) + (let ((relative-to (or relative-to message))) + (or (find-qualified-name name (proto-extenders message) + :relative-to relative-to) + (find-qualified-name name (proto-messages message) + :relative-to relative-to) + (find-message (proto-parent message) name relative-to)))) -(defmethod find-enum ((message protobuf-message) type) +(defmethod find-enum ((message protobuf-message) type &optional relative-to) (or (find type (proto-enums message) :key #'proto-class) - (find-enum (proto-parent message) type))) + (find-enum (proto-parent message) type (or relative-to message)))) -(defmethod find-enum ((message protobuf-message) (name string)) - (or (find-qualified-name name (proto-enums message)) - (find-enum (proto-parent message) name))) +(defmethod find-enum ((message protobuf-message) (name string) &optional relative-to) + (let ((relative-to (or relative-to message))) + (or (find-qualified-name name (proto-enums message) + :relative-to relative-to) + (find-enum (proto-parent message) name relative-to)))) -(defgeneric find-field (message name) +(defgeneric find-field (message name &optional relative-to) (:documentation "Given a Protobufs message and a slot name, field name or index, returns the Protobufs field having that name.")) -(defmethod find-field ((message protobuf-message) (name symbol)) +(defmethod find-field ((message protobuf-message) (name symbol) &optional relative-to) + (declare (ignore relative-to)) (find name (proto-fields message) :key #'proto-value)) -(defmethod find-field ((message protobuf-message) (name string)) - (find-qualified-name name (proto-fields message) :lisp-key #'proto-value)) +(defmethod find-field ((message protobuf-message) (name string) &optional relative-to) + (find-qualified-name name (proto-fields message) :lisp-key #'proto-value + :relative-to (or relative-to message))) -(defmethod find-field ((message protobuf-message) (index integer)) +(defmethod find-field ((message protobuf-message) (index integer) &optional relative-to) + (declare (ignore relative-to)) (find index (proto-fields message) :key #'proto-index)) @@ -608,7 +624,7 @@ (eq default $empty-vector) ;; Special handling for imported CLOS classes (and (not (eq (proto-required field) :optional)) - (or (null default) (equal default #()))))))) + (or (null default) (equalp default #()))))))) (defgeneric vector-field-p (field) (:documentation diff --git a/printer.lisp b/printer.lisp index 00ea7d7..1e7af7f 100644 --- a/printer.lisp +++ b/printer.lisp @@ -363,7 +363,7 @@ ~% (unless (cl:find-package \"~A\") ~ ~% (cl:defpackage ~A (:use :COMMON-LISP)))) ~ ~%(cl:in-package \"~A\") ~ - ~%(cl:export '(~{~A~^ ~%~}))~%~%" + ~%(cl:export '(~{~A~^~% ~}))~%~%" pkg pkg pkg (collect-exports schema)))) (when documentation (write-schema-documentation type documentation stream :indentation indentation)) @@ -570,7 +570,7 @@ (cond ((eq required :optional) `(or null ,cl)) ((eq required :repeated) - (if (eq (proto-default field) $empty-vector) + (if (vector-field-p field) `(vector-of ,cl) `(list-of ,cl))) (t cl))))) diff --git a/serialize.lisp b/serialize.lisp index bb36ad5..b7bea40 100644 --- a/serialize.lisp +++ b/serialize.lisp @@ -247,7 +247,18 @@ `(let ((,vval ,value)) (if ,writer (funcall ,writer ,object ,vval) - (setf (slot-value ,object ,slot) ,vval)))))) + (setf (slot-value ,object ,slot) ,vval))))) + (push-slot (object slot reader writer value) + (with-gensyms (vvals) + `(let ((,vvals (read-slot ,object ,slot ,reader))) + (if (i= (length ,vvals) 0) + ;; We need the initial value to be a stretchy vector, + ;; so scribble over it just to make sure + (let ((,vvals (make-array 1 + :fill-pointer t :adjustable t + :initial-contents (list ,value)))) + (write-slot ,object ,slot ,writer ,vvals)) + (vector-push-extend ,value ,vvals)))))) (labels ((deserialize (type trace end end-tag) (declare (type fixnum end end-tag)) (let* ((message (find-message trace type)) @@ -308,7 +319,7 @@ (deserialize-prim type buffer index) (setq index idx) (cond (vectorp - (vector-push-extend val (read-slot object slot reader))) + (push-slot object slot reader writer val)) (t (pushnew field rslots) ;; This "push" could type-check the entire list if @@ -324,7 +335,7 @@ (let* ((etag (make-tag $wire-type-end-group fidx)) (obj (deserialize type msg length etag))) (cond (vectorp - (vector-push-extend obj (read-slot object slot reader))) + (push-slot object slot reader writer obj)) (t (pushnew field rslots) (write-slot object slot writer @@ -334,7 +345,7 @@ (setq index idx) (let ((obj (deserialize type msg (+ index len) 0))) (cond (vectorp - (vector-push-extend obj (read-slot object slot reader))) + (push-slot object slot reader writer obj)) (t (pushnew field rslots) (write-slot object slot writer @@ -354,7 +365,7 @@ (deserialize-enum (proto-values msg) buffer index) (setq index idx) (cond (vectorp - (vector-push-extend val (read-slot object slot reader))) + (push-slot object slot reader writer val)) (t (pushnew field rslots) (write-slot object slot writer diff --git a/tests/cl-protobufs-tests.asd b/tests/cl-protobufs-tests.asd index be4394b..69ea81d 100644 --- a/tests/cl-protobufs-tests.asd +++ b/tests/cl-protobufs-tests.asd @@ -19,64 +19,68 @@ :maintainer '("Scott McKay") :description "Test code for Protobufs for Common Lisp" :long-description "Test code for Protobufs for Common Lisp" - :depends-on (:cl-protobufs :quux :test-tools - ;; Some of these tests use QRes business data - #+qres :qres-core) + :defsystem-depends-on (:cl-protobufs) + :depends-on (:cl-protobufs + ;; Right now, this uses the QRes test framework + ;; Sorry about that + #+qres :quux + #+qres :test-tools + #+qres :qres-core) :serial t :components ((:module "packages" - :serial t - :pathname #p"" - :components - ((:file "pkgdcl"))) + :serial t + :pathname #p"" + :components + ((:file "pkgdcl"))) ;; Wire format tests (:module "wire-level-tests" - :serial t - :pathname #p"" - :depends-on ("packages") - :components - ((:file "varint-tests") - (:file "wire-tests"))) + :serial t + :pathname #p"" + :depends-on ("packages") + :components + ((:file "varint-tests") + (:file "wire-tests"))) ;; Simple tests (:module "object-level-tests" - :serial t - :pathname #p"" - :depends-on ("wire-level-tests") - :components - ((:file "serialization-tests") - (:file "stability-tests"))) + :serial t + :pathname #p"" + :depends-on ("wire-level-tests") + :components + ((:file "serialization-tests") + (:file "stability-tests"))) ;; Bob Brown's protocol buffers tests (:module "brown-tests-proto" - :serial t - :pathname #p"" - :components - ((:protobuf-file "testproto1") - (:protobuf-file "testproto2"))) + :serial t + :pathname #p"" + :components + ((:protobuf-file "testproto1") + (:protobuf-file "testproto2"))) (:module "brown-tests" - :serial t - :pathname #p"" - :depends-on ("object-level-tests" "brown-tests-proto") - :components - ((:file "quick-tests") - (:static-file "golden.data"))) + :serial t + :pathname #p"" + :depends-on ("object-level-tests" "brown-tests-proto") + :components + ((:file "quick-tests") + (:static-file "golden.data"))) ;; Google's own protocol buffers and protobuf definitions tests #+++notyet (:module "google-tests-proto" - :serial t - :pathname #p"" - :components - ((:protobuf-file "descriptor") - (:protobuf-file "unittest_import") - (:protobuf-file "unittest" :depends-on ("unittest_import")))) + :serial t + :pathname #p"" + :components + ((:protobuf-file "descriptor") + (:protobuf-file "unittest_import") + (:protobuf-file "unittest" :depends-on ("unittest_import")))) #+++notyet (:module "google-tests" - :serial t - :pathname #p"" - :depends-on ("object-level-tests" "google-tests-proto") - :components - ((:file "full-tests") - (:static-file "golden_message.data") - (:static-file "golden_packed_message.data"))))) + :serial t + :pathname #p"" + :depends-on ("object-level-tests" "google-tests-proto") + :components + ((:file "full-tests") + (:static-file "golden_message.data") + (:static-file "golden_packed_message.data")))))