: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))
: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 ()
,@(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)))
(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)))))))
,@(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)
(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)))
: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))
;; 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
(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))
;; 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
(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)
(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
(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))
(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
~% (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))
(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)))))
`(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))
(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
(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
(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
(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
: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")))))
projects / cl-protobufs.git / commitdiff