(let ((*compile-file-pathname* nil)
(*load-pathname* fasl-file))
(load fasl-file)))))
- (let* ((imported (find-schema base-path)))
+ (let* ((imported (find-schema (class-name->proto import-name))))
(when imported
(setf (proto-imported-schemas schema)
(nconc (proto-imported-schemas schema) (list imported))))
:depends-on ("packages")
:components
((:file "utilities")
- (:file "model-classes")))
+ (:file "model-classes")
+ (:file "conditions")))
(:module "parsing"
:serial t
:pathname #p""
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; Free Software published under an MIT-like license. See LICENSE ;;;
+;;; ;;;
+;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; ;;;
+;;; Original author: Ben Wagner ;;;
+;;; ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package "PROTO-IMPL")
+
+;;; Protocol buffers conditions
+
+(define-condition undefined-type (simple-error)
+ ((type-name :type string
+ :reader error-type-name
+ :initarg :type-name
+ :documentation "The name of the type which can not be found."))
+ (:documentation "Indicates that a schema references a type which has not been defined.")
+ (:default-initargs :format-control "Undefined type:")
+ (:report (lambda (condition stream)
+ (format stream "~? ~s"
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
+ (error-type-name condition)))))
+
+(define-condition undefined-field-type (undefined-type)
+ ((field :type protobuf-field
+ :reader error-field
+ :initarg :field
+ :documentation "The field whose type is TYPE-NAME."))
+ (:documentation "Indicates that a schema contains a message with a field whose type is not a
+ primitive type and is not a known message (or extend) or enum.")
+ (:report (lambda (condition stream)
+ (format stream "~? Field ~s in message ~s has unknown type ~s."
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
+ (error-field condition)
+ (proto-parent (error-field condition))
+ (error-type-name condition)))))
+
+(define-condition undefined-method-type (undefined-type)
+ ((method :type protobuf-method
+ :reader error-method
+ :initarg :method
+ :documentation "The method that references TYPE-NAME.")
+ (where :type string
+ :reader error-where
+ :initarg :where
+ :documentation "Description of which type referenced by the method is undefined."))
+ (:documentation "Superclass for `undefined-type' errors related to a `protobuf-method'. Indicates
+ that a schema contains a service with a method whose input, output, or stream
+ type is not a known message (or extend).")
+ (:report (lambda (condition stream)
+ (format stream "~? ~a type for rpc ~s in service ~s has unknown type ~s."
+ (simple-condition-format-control condition)
+ (simple-condition-format-arguments condition)
+ (error-where condition)
+ (error-method condition)
+ (proto-parent (error-method condition))
+ (error-type-name condition)))))
+
+(define-condition undefined-input-type (undefined-method-type)
+ ()
+ (:default-initargs :where "Input"))
+
+(define-condition undefined-output-type (undefined-method-type)
+ ()
+ (:default-initargs :where "Output"))
+
+(define-condition undefined-stream-type (undefined-method-type)
+ ()
+ (:default-initargs :where "Stream"))
(defun find-qualified-name (name protos
&key (proto-key #'proto-name) (full-key #'proto-qualified-name)
- (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=)
- ;; Maybe we can find the symbol in Lisp land?
- (multiple-value-bind (name package path other)
- (proto->class-name name)
- (declare (ignore path))
- (let* ((name (string name))
- (symbol (or (and package (find-symbol name package))
- (and other
- (find-proto-package other)
- (find-symbol name (find-proto-package other))))))
- (when symbol
- (find symbol protos :key lisp-key))))))
+ (find name protos :key full-key :test #'string=)))
;; A Protobufs schema, corresponds to one .proto file
(defmethod print-object ((s protobuf-schema) stream)
(print-unreadable-object (s stream :type t :identity t)
(format stream "~@[~S~]~@[ (package ~A)~]"
- (proto-class s) (proto-package s))))
+ (when (slot-boundp s 'class) (proto-class s)) (proto-package s))))
(defgeneric make-qualified-name (proto name)
(:documentation
(defmethod print-object ((e protobuf-enum) stream)
(print-unreadable-object (e stream :type t :identity t)
(format stream "~S~@[ (alias for ~S)~]"
- (proto-class e) (proto-alias-for e))))
+ (when (slot-boundp e 'class) (proto-class e)) (proto-alias-for e))))
(defmethod make-qualified-name ((enum protobuf-enum) name)
;; The qualified name is the enum name "dot" the name
(defmethod print-object ((m protobuf-message) stream)
(print-unreadable-object (m stream :type t :identity t)
(format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
- (proto-class m) (proto-alias-for m)
+ (when (slot-boundp m 'class) (proto-class m))
+ (proto-alias-for m)
(eq (proto-message-type m) :group)
(eq (proto-message-type m) :extends))))
(find name (proto-fields message) :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
+ (find-qualified-name name (proto-fields message)
:relative-to (or relative-to message)))
(defmethod find-field ((message protobuf-message) (index integer) &optional relative-to)
(defmethod print-object ((f protobuf-field) stream)
(print-unreadable-object (f stream :type t :identity t)
(format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
- (proto-value f) (proto-class f) (proto-index f)
+ (proto-value f)
+ (when (slot-boundp f 'class) (proto-class f))
+ (proto-index f)
(eq (proto-message-type f) :group)
(eq (proto-message-type f) :extends))))
(defmethod print-object ((m protobuf-method) stream)
(print-unreadable-object (m stream :type t :identity t)
(format stream "~S (~S) => (~S)"
- (proto-class m) (proto-input-type m) (proto-output-type m))))
+ (proto-class m)
+ (when (slot-boundp m 'itype) (proto-input-type m))
+ (when (slot-boundp m 'otype) (proto-output-type m)))))
;;; Lisp-only extensions
(%make-source-location :pathname *protobuf-pathname*
:start-pos start :end-pos end)))
+(defgeneric resolve-lisp-names (protobuf)
+ (:documentation "Second pass of schema parsing which recursively resolves protobuf type names to
+ lisp type names in all messages and services contained within 'protobuf'. No
+ return value."))
+
;; The syntax for Protocol Buffers is so simple that it doesn't seem worth
;; writing a sophisticated parser
;; Note that we don't put the result into *all-schemas*; that's done in 'define-schema'
(let ((char (peek-char nil stream nil)))
(cond ((null char)
(remove-options schema "lisp_package")
+ (resolve-lisp-names schema)
(return-from parse-schema-from-stream schema))
((proto-token-char-p char)
(let ((token (parse-token stream)))
(name (and option (proto-name option)))
(value (and option (proto-value option))))
(when (and option (option-name= name "lisp_package"))
- (let ((package (or (find-proto-package value)
- ;; Try to put symbols into the right package
- (make-package (string-upcase value) :use ())
- *protobuf-package*)))
- (setf (proto-lisp-package schema) value)
- (setq *protobuf-package* package)))))
+ (set-lisp-package schema value))))
((string= token "enum")
(parse-proto-enum stream schema))
((string= token "extend")
(t
(error "Syntax error at position ~D" (file-position stream))))))))
+(defun set-lisp-package (schema lisp-package-name)
+ "Set the package for generated lisp names of 'schema'."
+ (check-type schema protobuf-schema)
+ (check-type lisp-package-name string)
+ (let ((package (or (find-proto-package lisp-package-name)
+ ;; Try to put symbols into the right package
+ (make-package (string-upcase lisp-package-name) :use ())
+ *protobuf-package*)))
+ (setf (proto-lisp-package schema) lisp-package-name)
+ (setq *protobuf-package* package)))
+
+(defmethod resolve-lisp-names ((schema protobuf-schema))
+ "Recursively resolves protobuf type names to lisp type names in the messages and services in
+ 'schema'."
+ (map () #'resolve-lisp-names (proto-messages schema))
+ (map () #'resolve-lisp-names (proto-services schema)))
+
(defun parse-proto-syntax (stream schema &optional (terminator #\;))
"Parse a Protobufs syntax line from 'stream'.
Updates the 'protobuf-schema' object to use the syntax."
(substitute #\- #\_ package))))
(setf (proto-package schema) package)
(unless (proto-lisp-package schema)
- (setf (proto-lisp-package schema) lisp-pkg))
- (let ((package (or (find-proto-package lisp-pkg) *protobuf-package*)))
- (setq *protobuf-package* package))))
+ (set-lisp-package schema lisp-pkg))))
(defun parse-proto-import (stream schema &optional (terminator #\;))
"Parse a Protobufs import line from 'stream'.
((or (digit-char-p ch) (member ch '(#\- #\+ #\.)))
(parse-number stream))
((eql ch #\{)
+ ;;---bwagner: this is incorrect -- we need to find the field name in
+ ;; the locally-extended version of
+ ;; google.protobuf.[File,Message,Field,Enum,EnumValue,Service,Method]Options
+ ;; and get its type
(let ((message (find-message (or protobuf *protobuf*) key)))
(if message
;; We've got a complex message as a value to an option
- ;; This only shows up in custom optionss
+ ;; This only shows up in custom options
(parse-text-format message :stream stream :parse-name nil)
;; Who knows what to do? Skip the value
(skip-field stream))))
(error "Unrecognized token ~A at position ~D"
token (file-position stream))))))))
+(defmethod resolve-lisp-names ((message protobuf-message))
+ "Recursively resolves protobuf type names to lisp type names in nested messages and fields of
+ 'message'."
+ (map () #'resolve-lisp-names (proto-messages message))
+ (map () #'resolve-lisp-names (proto-fields message)))
+
(defun parse-proto-extend (stream protobuf)
"Parse a Protobufs 'extend' from 'stream'.
Updates the 'protobuf-schema' or 'protobuf-message' object to have the message."
(name (prog1 (parse-token stream)
(expect-char stream #\{ () "extend")
(maybe-skip-comments stream)))
+ ;;---bwagner: is 'extend' allowed to use a forward reference to a message?
(message (find-message protobuf name))
(extends (and message
(make-instance 'protobuf-message
(expect-char stream #\; () "message")
(maybe-skip-comments stream)))
(packed (find-option opts "packed"))
- (ptype (if (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
- "fixed32" "fixed64" "sfixed32" "sfixed64"
- "string" "bytes" "bool" "float" "double") :test #'string=)
- (kintern type)
- type))
- (class (if (keywordp ptype) ptype (proto->class-name type *protobuf-package*)))
(slot (proto->slot-name name *protobuf-package*))
(reqd (kintern required))
(field (make-instance 'protobuf-field
:name name
:type type
- :class class
:qualified-name (make-qualified-name message name)
:parent message
;; One of :required, :optional or :repeated
(setf (proto-fields message) (nconc (proto-fields message) (list field)))
field))))
+(defmethod resolve-lisp-names ((field protobuf-field))
+ "Resolves the field's protobuf type to a lisp type and sets `proto-class' for 'field'."
+ (let* ((type (proto-type field))
+ (ptype (when (member type '("int32" "int64" "uint32" "uint64" "sint32" "sint64"
+ "fixed32" "fixed64" "sfixed32" "sfixed64"
+ "string" "bytes" "bool" "float" "double") :test #'string=)
+ (kintern type)))
+ (message (unless ptype
+ (or (find-message (proto-parent field) type)
+ (find-enum (proto-parent field) type)))))
+ (unless (or ptype message)
+ (error 'undefined-field-type
+ :type-name type
+ :field field))
+ (setf (proto-class field) (or ptype (proto-class message))))
+ nil)
+
(defun parse-proto-group (stream message required &optional extended-from)
"Parse a (deprecated) Protobufs group from 'stream'.
Updates the 'protobuf-message' object to have the group type and field."
(name (slot-name->proto (proto->slot-name type)))
(idx (parse-unsigned-int stream))
(msg (parse-proto-message stream message type))
- (class (proto->class-name type *protobuf-package*))
(slot (proto->slot-name name *protobuf-package*))
(field (make-instance 'protobuf-field
:name name
:type type
- :class class
:qualified-name (make-qualified-name message name)
:parent message
:required (kintern required)
(error "Unrecognized token ~A at position ~D"
token (file-position stream))))))))
+(defmethod resolve-lisp-names ((service protobuf-service))
+ "Recursively resolves protobuf type names to lisp type names for all methods of 'service'."
+ (map () #'resolve-lisp-names (proto-methods service)))
+
(defun parse-proto-method (stream service index)
"Parse a Protobufs method from 'stream'.
Updates the 'protobuf-service' object to have the method."
(out (prog2 (expect-char stream #\( () "service")
(parse-token stream)
(expect-char stream #\) () "service")))
- (strm (parse-token stream)) ;might be "streams"
- (strm (and strm (string= strm "streams")
- (prog2 (expect-char stream #\( () "service")
- (parse-token stream)
- (expect-char stream #\) () "service"))))
(opts (let ((opts (parse-proto-method-options stream)))
(when (or (null opts) (eql (peek-char nil stream nil) #\;))
(expect-char stream #\; () "service"))
:name name
:qualified-name (make-qualified-name *protobuf* name)
:parent service
- :input-type (proto->class-name in *protobuf-package*)
:input-name in
- :output-type (proto->class-name out *protobuf-package*)
:output-name out
- :streams-type (and strm (proto->class-name strm *protobuf-package*))
- :streams-name strm
:index index
:options opts
:source-location (make-source-location stream loc (i+ loc (length name))))))
(setf (proto-class method) stub
(proto-client-stub method) stub
(proto-server-stub method) (intern (format nil "~A-~A" 'do stub) *protobuf-package*)))
+ (let ((strm (find-option method "stream_type")))
+ (when strm
+ (setf (proto-streams-name method) strm)))
(setf (proto-methods service) (nconc (proto-methods service) (list method)))
method))
+(defmethod resolve-lisp-names ((method protobuf-method))
+ "Resolves input, output, and streams protobuf type names to lisp type names and sets
+ `proto-input-type', `proto-output-type', and, if `proto-streams-name' is set,
+ `proto-streams-type' on 'method'."
+ (let* ((input-name (proto-input-name method))
+ (output-name (proto-output-name method))
+ (streams-name (proto-streams-name method))
+ (service (proto-parent method))
+ (schema (proto-parent service))
+ (input-message (find-message schema input-name))
+ (output-message (find-message schema output-name))
+ (streams-message (and streams-name
+ ;; this is supposed to be the fully-qualified name, but we don't
+ ;; require that
+ (find-message schema streams-name))))
+ (unless input-message
+ (error 'undefined-input-type
+ :type-name input-name
+ :method method))
+ (unless output-message
+ (error 'undefined-output-type
+ :type-name output-name
+ :method method))
+ (setf (proto-input-type method) (proto-class input-message))
+ (setf (proto-output-type method) (proto-class output-message))
+ (when streams-name
+ (unless streams-message
+ (error 'undefined-stream-type
+ :type-name streams-name
+ :method method))
+ (setf (proto-streams-type method) (proto-class streams-message))))
+ nil)
+
(defun parse-proto-method-options (stream)
"Parse any options in a Protobufs method from 'stream'.
Returns a list of 'protobuf-option' objects."
"PROTOBUF-METHOD"
"PROTOBUF-TYPE-ALIAS" ;Lisp-only extension
+ ;; Conditions
+ "UNDEFINED-FIELD-TYPE"
+ "UNDEFINED-INPUT-TYPE"
+ "UNDEFINED-OUTPUT-TYPE"
+ "UNDEFINED-STREAM-TYPE"
+ "ERROR-TYPE-NAME"
+ "ERROR-FIELD"
+ "ERROR-METHOD"
+
;; Object lookup
"FIND-MESSAGE"
"FIND-MESSAGE-FOR-CLASS"
(*show-lisp-enum-indexes* show-enum-indexes)
(*show-lisp-field-indexes* show-field-indexes)
(*use-common-lisp-package* use-common-lisp)
- (*protobuf-package* (or (find-proto-package lisp-pkg) *package*))
- (*package* *protobuf-package*))
+ (*protobuf-package* (find-proto-package lisp-pkg))
+ ;; If *protobuf-package* has not been defined, print symbols
+ ;; from :common-lisp if *use-common-lisp-package* is true; or
+ ;; :keyword otherwise. This ensures that all symbols will be
+ ;; read back correctly.
+ ;; (The :keyword package does not use any other packages, so
+ ;; all symbols will be printed with package prefixes.
+ ;; Keywords are always printed as :keyword.)
+ (*package* (or *protobuf-package*
+ (when *use-common-lisp-package* (find-package :common-lisp))
+ (find-package :keyword))))
(when (or lisp-pkg pkg)
(let ((pkg (string-upcase (or lisp-pkg pkg))))
(format stream "~&(cl:eval-when (:execute :compile-toplevel :load-toplevel) ~
(tag (make-tag type (proto-index field))))
(doseq (v (read-slot object slot reader))
(let ((v (funcall (proto-serializer msg) v)))
- (setq index (serialize-prim v type tag buffer index))))))))
+ (setq index (serialize-prim v type tag buffer index))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While serializing ~s to protobuf,"
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field))))
(t
(cond ((eq type :bool)
;; We have to handle optional boolean fields specially
(let* ((v (funcall (proto-serializer msg) v))
(type (proto-proto-type msg))
(tag (make-tag type (proto-index field))))
- (setq index (serialize-prim v type tag buffer index)))))))))))))
+ (setq index (serialize-prim v type tag buffer index))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While serializing ~s to protobuf,"
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field)))))))))
(declare (dynamic-extent #'do-field))
(dolist (field (proto-fields message))
(do-field object message field))))
(tag (make-tag type (proto-index field))))
(doseq (v (read-slot object slot reader))
(let ((v (funcall (proto-serializer msg) v)))
- (iincf size (prim-size v type tag))))))))
+ (iincf size (prim-size v type tag))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While computing the size of ~s in bytes,"
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(let* ((v (funcall (proto-serializer msg) v))
(type (proto-proto-type msg))
(tag (make-tag type (proto-index field))))
- (iincf size (prim-size v type tag)))))))))))))
+ (iincf size (prim-size v type tag))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While computing the size of ~s in bytes,"
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field)))))))))
(declare (dynamic-extent #'do-field))
(dolist (field (proto-fields message))
(do-field object message field))
(tag (make-tag class (proto-index field))))
`(,iterator (,vval ,reader)
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
- (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))))
+ (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While generating the serialize-object method ~
+ for ~s,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string class)
+ :field field)))))
(t
(cond ((keywordp class)
(collect-serializer
`(let ((,vval ,reader))
(when ,vval
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
- (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))))))))
+ (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While generating the serialize-object method ~
+ for ~s,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string class)
+ :field field))))))))
`(defmethod serialize-object
(,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
(declare #.$optimize-serialization)
(multiple-value-bind (,vval idx)
(deserialize-prim ,class ,vbuf ,vidx)
(setq ,vidx idx)
- (push (funcall #',(proto-deserializer msg) ,vval) ,temp))))))))
+ (push (funcall #',(proto-deserializer msg) ,vval) ,temp))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While generating the deserialize-object method ~
+ for ~s,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string class)
+ :field field))))
(t
(cond ((keywordp class)
(collect-deserializer
(deserialize-prim ,class ,vbuf ,vidx)
(let ((,vval (funcall #',(proto-deserializer msg) ,vval)))
(setq ,vidx idx)
- ,(write-slot vobj field vval)))))))))))))
+ ,(write-slot vobj field vval)))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While generating the deserialize-object method ~
+ for ~s,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string class)
+ :field field))))))))
(let* ((rslots (delete-duplicates rslots :key #'first))
(rfields (mapcar #'first rslots))
(rtemps (mapcar #'second rslots)))
(tag (make-tag class index)))
`(,iterator (,vval ,reader)
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
- (iincf ,vsize (prim-size ,vval ,class ,tag))))))))))
+ (iincf ,vsize (prim-size ,vval ,class ,tag)))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While generating the object-size method for ~s,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string class)
+ :field field)))))
(t
(cond ((keywordp class)
(let ((tag (make-tag class index)))
(when ,vval
(iincf ,vsize (prim-size
(funcall #',(proto-serializer msg) ,vval)
- ,class ,tag)))))))))))))
+ ,class ,tag)))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While generating the object-size method for ~s,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string class)
+ :field field))))))))
`(defmethod object-size
(,vobj (,vclass (eql ,message)) &optional visited)
(declare #.$optimize-serialization)
((:file "quick-tests")
(:static-file "golden.data")))
+ (:module "lisp-reference-tests"
+ :serial t
+ :pathname #p""
+ :components
+ ((:protobuf-file "package_test1") ; automatically includes package_test2
+ (:protobuf-file "forward_reference")
+ (:file "lisp-reference-tests")))
+
;; Google's own protocol buffers and protobuf definitions tests
#+++notyet
(:module "google-tests-proto"
--- /dev/null
+// Free Software published under an MIT-like license. See LICENSE
+//
+// Copyright (c) 2012 Google, Inc. All rights reserved.
+//
+// Original author: Ben Wagner
+
+syntax = "proto2";
+
+package protobuf_forward_reference_unittest;
+
+message MessageWithForwardReference {
+ required MessageWithOverriddenLispClass foo = 1;
+ required EnumWithOverriddenLispClass bar = 2;
+}
+
+service ServiceWithForwardReference {
+ rpc Bloop(MessageWithOverriddenLispClass) returns (MessageWithForwardReference);
+ rpc Beep(MessageWithForwardReference) returns (MessageWithOverriddenLispClass);
+}
+
+message MessageWithOverriddenLispClass {
+ option (lisp_name) = "PROTOBUF-FORWARD-REFERENCE-UNITTEST:MSG-W-OVERRIDDEN-LISP-CLASS";
+ required int32 baz = 1;
+}
+
+enum EnumWithOverriddenLispClass {
+ option (lisp_name) = "PROTOBUF-FORWARD-REFERENCE-UNITTEST:ENUM-W-OVERRIDDEN-LISP-CLASS";
+ BAA = 1;
+}
--- /dev/null
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; ;;;
+;;; Free Software published under an MIT-like license. See LICENSE ;;;
+;;; ;;;
+;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; ;;;
+;;; Original author: Ben Wagner ;;;
+;;; ;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(in-package "PROTO-TEST")
+
+(define-test cross-package-reference-test ()
+ (flet ((find-by-name (name proto-objects)
+ (find name proto-objects :key #'proto-name :test #'string=)))
+ (let* ((schema (find-schema :package_test1))
+ (message-with-cross-package-reference
+ (find-by-name "MessageWithCrossPackageReference" (proto-messages schema)))
+ (baz (find-by-name "baz" (proto-fields message-with-cross-package-reference)))
+ (bonk (find-by-name "bonk" (proto-fields message-with-cross-package-reference)))
+ (bam (find-by-name "bam" (proto-fields message-with-cross-package-reference)))
+ (bing (find-by-name "bing" (proto-fields message-with-cross-package-reference)))
+ (message-with-cross-package-extension
+ (find-by-name "MessageWithCrossPackageExtension" (proto-messages schema)))
+ (boo (find-by-name "boo" (proto-fields message-with-cross-package-extension)))
+ (service-with-cross-package-input-output
+ (find-by-name "ServiceWithCrossPackageInputOutput" (proto-services schema)))
+ (bloop (find-by-name "Bloop" (proto-methods service-with-cross-package-input-output)))
+ (beep (find-by-name "Beep" (proto-methods service-with-cross-package-input-output)))
+ (message-in-other-package-extend
+ (find-by-name "MessageInOtherPackage"
+ (proto-messages message-with-cross-package-extension)))
+ (baa (find-by-name "baa" (proto-extended-fields message-in-other-package-extend))))
+ (assert-equal 'protobuf-package-unittest2::message-in-other-package
+ (proto-class baz))
+ (assert-equal 'protobuf-package-unittest2::enum-in-other-package
+ (proto-class bonk))
+ (assert-equal 'protobuf-package-unittest1::message-defined-in-both-packages
+ (proto-class bam))
+ (assert-equal 'protobuf-package-unittest2::message-defined-in-both-packages
+ (proto-class bing))
+ (assert-equal 'protobuf-package-unittest2::message-in-other-package
+ (proto-class boo))
+ (assert-equal 'protobuf-package-unittest2::message-in-other-package
+ (proto-input-type bloop))
+ (assert-equal 'protobuf-package-unittest1::message-with-cross-package-reference
+ (proto-output-type bloop))
+ (assert-equal 'protobuf-package-unittest1::message-with-cross-package-reference
+ (proto-input-type beep))
+ (assert-equal 'protobuf-package-unittest2::message-in-other-package
+ (proto-output-type beep))
+ (assert-equal 'protobuf-package-unittest1::baa
+ (proto-value baa))))
+
+ (let* ((orig1 (make-instance 'protobuf-package-unittest1::message-with-cross-package-reference
+ :baz (make-instance 'protobuf-package-unittest2::message-in-other-package
+ :foo 123)
+ :bonk :bar
+ :bam (make-instance 'protobuf-package-unittest1::message-defined-in-both-packages
+ :boom "bomb")
+ :bing (make-instance 'protobuf-package-unittest2::message-defined-in-both-packages
+ :bang "gun")))
+ (orig2 (let ((extended-obj (make-instance 'protobuf-package-unittest2::message-in-other-package
+ :foo 123)))
+ (setf (protobuf-package-unittest1::baa extended-obj) 456)
+ (make-instance 'protobuf-package-unittest1::message-with-cross-package-extension
+ :boo extended-obj)))
+ (bytes1 (serialize-object-to-bytes orig1
+ 'protobuf-package-unittest1::message-with-cross-package-reference))
+ (bytes2 (serialize-object-to-bytes orig2
+ 'protobuf-package-unittest1::message-with-cross-package-extension))
+ (new1 (deserialize-object 'protobuf-package-unittest1::message-with-cross-package-reference
+ bytes1))
+ (new2 (deserialize-object 'protobuf-package-unittest1::message-with-cross-package-extension
+ bytes2)))
+ (assert-true (typep (protobuf-package-unittest1::baz new1)
+ 'protobuf-package-unittest2::message-in-other-package))
+ (assert-equal 123
+ (protobuf-package-unittest2::foo (protobuf-package-unittest1::baz new1)))
+ (assert-equal :bar
+ (protobuf-package-unittest1::bonk new1))
+ (assert-equal "bomb"
+ (protobuf-package-unittest1::boom (protobuf-package-unittest1::bam new1)))
+ (assert-equal "gun"
+ (protobuf-package-unittest2::bang (protobuf-package-unittest1::bing new1)))
+ (assert-true (typep (protobuf-package-unittest1::boo new2)
+ 'protobuf-package-unittest2::message-in-other-package))
+ (assert-equal 123
+ (protobuf-package-unittest2::foo (protobuf-package-unittest1::boo new2)))
+ (assert-equal 456
+ (protobuf-package-unittest1::baa (protobuf-package-unittest1::boo new2)))))
+
+(define-test forward-reference-test ()
+ (flet ((find-by-name (name proto-objects)
+ (find name proto-objects :key #'proto-name :test #'string=)))
+ (let* ((schema (find-schema :forward_reference))
+ (message-with-forward-reference
+ (find-by-name "MessageWithForwardReference" (proto-messages schema)))
+ (foo (find-by-name "foo" (proto-fields message-with-forward-reference)))
+ (bar (find-by-name "bar" (proto-fields message-with-forward-reference)))
+ (service-with-forward-reference
+ (find-by-name "ServiceWithForwardReference" (proto-services schema)))
+ (bloop (find-by-name "Bloop" (proto-methods service-with-forward-reference)))
+ (beep (find-by-name "Beep" (proto-methods service-with-forward-reference))))
+ (assert-equal 'protobuf-forward-reference-unittest::msg-w-overridden-lisp-class
+ (proto-class foo))
+ (assert-equal 'protobuf-forward-reference-unittest::ENUM-W-OVERRIDDEN-LISP-CLASS
+ (proto-class bar))
+ (assert-equal 'protobuf-forward-reference-unittest::MSG-W-OVERRIDDEN-LISP-CLASS
+ (proto-input-type bloop))
+ (assert-equal 'protobuf-forward-reference-unittest::MESSAGE-WITH-FORWARD-REFERENCE
+ (proto-output-type bloop))
+ (assert-equal 'protobuf-forward-reference-unittest::MESSAGE-WITH-FORWARD-REFERENCE
+ (proto-input-type beep))
+ (assert-equal 'protobuf-forward-reference-unittest::MSG-W-OVERRIDDEN-LISP-CLASS
+ (proto-output-type beep))))
+ (let* ((orig (make-instance 'protobuf-forward-reference-unittest::message-with-forward-reference
+ :foo (make-instance 'protobuf-forward-reference-unittest::msg-w-overridden-lisp-class
+ :baz 123)
+ :bar :baa))
+ (bytes (serialize-object-to-bytes orig
+ 'protobuf-forward-reference-unittest::message-with-forward-reference))
+ (new (deserialize-object 'protobuf-forward-reference-unittest::message-with-forward-reference
+ bytes)))
+ (assert-true (typep (protobuf-forward-reference-unittest::foo new)
+ 'protobuf-forward-reference-unittest::msg-w-overridden-lisp-class))
+ (assert-equal 123
+ (protobuf-forward-reference-unittest::baz (protobuf-forward-reference-unittest::foo new)))
+ (assert-equal :baa
+ (protobuf-forward-reference-unittest::bar new))))
+
+(defparameter *test-proto-preamble*
+ "syntax = \"proto2\";
+
+package proto_test;
+
+message DefinedMessage {
+ optional string foo = 1;
+}
+
+")
+
+
+(define-test undefined-types-test ()
+ (labels ((parse-schema-containing (string)
+ (with-input-from-string (s (concatenate 'string *test-proto-preamble* string))
+ (parse-schema-from-stream s
+ ;; Parsing from a string doesn't produce a name, so supply
+ ;; it
+ :name "proto_test"
+ :class 'dummy
+ :conc-name nil)))
+ (parse-message-with-field-type (type)
+ (parse-schema-containing (format nil "message MessageWithUndefinedFieldType {~%~
+ ~& optional ~a bar = 1;~%~
+ }~%" type)))
+ (parse-service-with-rpc (rpc)
+ (parse-schema-containing (format nil "service ServiceWithUndefinedMethodType {~%~
+ ~& ~a~%~
+ }~%" rpc)))
+ (poor-mans-assert-regex-equal (expected-strings actual-string)
+ (assert-true
+ (loop with index = 0
+ for expected-string in expected-strings
+ as position = (search expected-string actual-string :start2 index)
+ always position
+ do (setf index (+ position (length expected-string))))))
+ (do-field-test (field-type)
+ (let ((condition (assert-error undefined-field-type
+ (parse-message-with-field-type field-type))))
+ (poor-mans-assert-regex-equal
+ (list "Undefined type: Field #<"
+ "PROTOBUF-FIELD PROTOBUFS-TEST::BAR :: NIL = 1"
+ "in message #<"
+ "PROTOBUF-MESSAGE PROTOBUFS-TEST::MESSAGE-WITH-UNDEFINED-FIELD-TYPE"
+ (format nil "has unknown type \"~a\"." field-type))
+ (princ-to-string condition))
+ (assert-equal field-type (error-type-name condition))
+ (assert-equal "bar" (proto-name (error-field condition)))))
+ (method-test-assertions (condition where method-lisp-name method-proto-name type)
+ (poor-mans-assert-regex-equal
+ (list (format nil "Undefined type: ~a type for rpc #<" where)
+ (format nil "PROTOBUF-METHOD PROTOBUFS-TEST::~a" method-lisp-name)
+ "in service #<"
+ "PROTOBUF-SERVICE ServiceWithUndefinedMethodType"
+ (format nil "has unknown type \"~a\"." type))
+ (princ-to-string condition))
+ (assert-equal type (error-type-name condition))
+ (assert-equal method-proto-name (proto-name (error-method condition))))
+ (do-method-input-test (input-type)
+ (let ((condition (assert-error undefined-input-type
+ (parse-service-with-rpc
+ (format nil "rpc MethodWithUndefinedInput (~a) ~
+ returns (DefinedMessage);" input-type)))))
+ (method-test-assertions condition "Input" "METHOD-WITH-UNDEFINED-INPUT"
+ "MethodWithUndefinedInput" input-type)))
+ (do-method-output-test (output-type)
+ (let ((condition (assert-error undefined-output-type
+ (parse-service-with-rpc
+ (format nil "rpc MethodWithUndefinedOutput (DefinedMessage) ~
+ returns (~a);" output-type)))))
+ (method-test-assertions condition "Output" "METHOD-WITH-UNDEFINED-OUTPUT"
+ "MethodWithUndefinedOutput" output-type)))
+ (do-method-stream-test (stream-type)
+ (let ((condition (assert-error undefined-stream-type
+ (parse-service-with-rpc
+ (format nil "rpc MethodWithUndefinedStream (DefinedMessage) ~
+ returns (DefinedMessage) {~
+ ~& option stream_type = \"~a\";~
+ ~& };" stream-type)))))
+ (method-test-assertions condition "Stream" "METHOD-WITH-UNDEFINED-STREAM"
+ "MethodWithUndefinedStream" stream-type))))
+
+ (parse-message-with-field-type "int32")
+ (do-field-test "int")
+ (parse-message-with-field-type "DefinedMessage")
+ (do-field-test "UndefinedMessage")
+ (do-field-test "other_package.DefinedMessage")
+
+ (parse-service-with-rpc
+ "rpc MethodWithDefinedInputOutput (DefinedMessage) returns (DefinedMessage);")
+ (do-method-input-test "UndefinedMessage")
+ ;; my understanding is that primitive types are not allowed for method input/output; if this is
+ ;; incorrect, change to "int"
+ (do-method-input-test "int32")
+ (do-method-input-test "other_package.DefinedMessage")
+
+ (do-method-output-test "UndefinedMessage")
+ (do-method-output-test "int32")
+ (do-method-output-test "other_package.DefinedMessage")
+
+ ;; stream_type is required to be fully qualified
+ (parse-service-with-rpc (format nil "rpc MethodWithDefinedInputOutput (DefinedMessage) ~
+ returns (DefinedMessage) {~
+ ~& option stream_type = \"proto_test.DefinedMessage\";~
+ ~& };"))
+ (do-method-stream-test "proto_test.UndefinedMessage")
+ (do-method-stream-test "int32")
+ (do-method-stream-test "other_package.DefinedMessage")))
+
+
+(define-test-suite lisp-reference-tests ()
+ (cross-package-reference-test
+ forward-reference-test
+ undefined-types-test))
+
+(register-test 'lisp-reference-tests)
--- /dev/null
+// Free Software published under an MIT-like license. See LICENSE
+//
+// Copyright (c) 2012 Google, Inc. All rights reserved.
+//
+// Original author: Ben Wagner
+
+syntax = "proto2";
+
+import "package_test2.proto";
+
+package protobuf_package_unittest1;
+
+message MessageDefinedInBothPackages {
+ required string boom = 1;
+}
+
+message MessageWithCrossPackageReference {
+ required MessageInOtherPackage baz = 1;
+ required EnumInOtherPackage bonk = 2;
+ required MessageDefinedInBothPackages bam = 3;
+ required protobuf_package_unittest2.MessageDefinedInBothPackages bing = 5;
+}
+
+message MessageWithCrossPackageExtension {
+ extend MessageInOtherPackage {
+ required int32 baa = 1000;
+ }
+ required MessageInOtherPackage boo = 1;
+}
+
+service ServiceWithCrossPackageInputOutput {
+ rpc Bloop(MessageInOtherPackage) returns (MessageWithCrossPackageReference);
+ rpc Beep(MessageWithCrossPackageReference) returns (MessageInOtherPackage);
+}
--- /dev/null
+// Free Software published under an MIT-like license. See LICENSE
+//
+// Copyright (c) 2012 Google, Inc. All rights reserved.
+//
+// Original author: Ben Wagner
+
+syntax = "proto2";
+
+package protobuf_package_unittest2;
+
+message MessageInOtherPackage {
+ required int32 foo = 1;
+ extensions 1000 to max;
+}
+
+enum EnumInOtherPackage {
+ BAR = 1;
+}
+
+message MessageDefinedInBothPackages {
+ required string bang = 1;
+}
"RUN-TEST"
"ASSERT-EQUAL"
"ASSERT-TRUE"
- "ASSERT-FALSE"))
+ "ASSERT-FALSE"
+ "ASSERT-ERROR"))
(defpackage protobuf-unittest
(:use :common-lisp :protobufs)
(defpackage protobuf-geodata
(:use :common-lisp :protobufs)
(:nicknames :geodata))
+
+(defpackage protobuf-forward-reference-unittest
+ (:use :common-lisp :protobufs))
(format t "~&Running test ~A" test)
(funcall test)))
-(defmacro assert-equal (actual expected &key (test 'eql))
+(defmacro assert-equal (actual expected &key (test 'equal))
`(unless (,test ,actual ,expected)
(warn "The value ~S is not equal to the expected value ~S"
',actual ',expected)))
`(when ,form
(warn "The value ~S does not evaluate to 'false'"
',form)))
+
+(defmacro assert-error (condition &body body)
+ "Checks if BODY signals a condition of class CONDITION. If it does not, a failure is
+ reported. If it is, the condition is caught and the condition object returned so that the test
+ can perform further checks on the condition object."
+ (let ((c (gensym "C")))
+ `(handler-case (progn ,@body)
+ (,condition (,c)
+ ,c)
+ (:no-error ()
+ (warn "Expected condition ~a while evaluating~{ ~s~}" ',condition ',body)))))
(proto:define-message stable-add-color ()
(wheel :type stable-color-wheel)
(color :type stable-color))
+ (proto:define-message string-primitive ()
+ (string :type string))
(proto:define-service stable-color-wheel ()
- (get-stable-color (string => stable-color))
+ (get-stable-color (string-primitive => stable-color))
(set-stable-color (stable-color => stable-color)
:options (:deadline 1.0))))
required StableColor color = 2;
}
+message StringPrimitive {
+ required string string = 1;
+}
+
service StableColorWheel {
- rpc GetStableColor (String) returns (StableColor);
+ rpc GetStableColor (StringPrimitive) returns (StableColor);
rpc SetStableColor (StableColor) returns (StableColor) {
option deadline = 1.0;
}
(doseq (v (read-slot object slot reader))
(let ((v (funcall (proto-serializer msg) v)))
(print-prim v type field stream
- (or suppress-line-breaks indent))))))))
+ (or suppress-line-breaks indent))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While printing ~s to text format,"
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(let ((v (funcall (proto-serializer msg) v))
(type (proto-proto-type msg)))
(print-prim v type field stream
- (or suppress-line-breaks indent)))))))))))))
+ (or suppress-line-breaks indent))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While printing ~s to text format,"
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field)))))))))
(declare (dynamic-extent #'do-field))
(if print-name
(if suppress-line-breaks
(when slot
(pushnew slot rslots)
(push (funcall (proto-deserializer msg) val)
- (slot-value object slot))))))))
+ (slot-value object slot))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While parsing ~s from text format,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string type)
+ :field field))))
(t
(cond ((keywordp type)
(expect-char stream #\:)
(otherwise (parse-signed-int stream)))))
(when slot
(setf (slot-value object slot)
- (funcall (proto-deserializer msg) val)))))))))))))))
+ (funcall (proto-deserializer msg) val))))))
+ (t
+ (error 'undefined-field-type
+ :format-control "While parsing ~s from text format,"
+ :format-arguments (list message)
+ :type-name (prin1-to-string type)
+ :field field)))))))))))
(declare (dynamic-extent #'deserialize))
(deserialize (proto-class message) message)))
common-lisp.net / projects/qitab/cl-protobufs.git / commitdiff
