[ - 'find-message' and 'find-enum' need to search namespaces ]
[ if the quick compare against the name/class fails ]
- 'message Foo { message Bar { ... } ... }'
- should (maybe!) produce a Lisp class defaultly named 'foo.bar'
+ should not produce a Lisp class defaultly named 'foo.bar', but...
- Add a keyword arg, :class-name, that overrides this convention;
in .proto files this should be called lisp_class
- Also, add :slot-name for slots and :type-name for enums
(called lisp_slot and lisp_type in .proto files)
- - Or maybe not, since 'foo.bar' isn't very Lispy;
- for the most part, packages provide enough room to avoid name clashes
+ - Rationale: 'foo.bar' isn't very Lispy;
+ for the most part, packages provide enough namespaces to avoid clashes
- Get 'merge-from-message' fully working
- See the place in 'deserialize-object' that needs to merge, too
[ - &key name should give the Protobufs name for the field ]
[ - 'option lisp_name="pkg:name"' should give the Lisp name for the slot ]
+- Refactor 'define-message'/'define-extend'/'define-group'
+ to avoid so much duplicated code
+
[- Need search paths in the ASDF .proto module ]
[- Make 'import' really work ]
(defmethod input-files ((op load-op) (component protobuf-file))
"The input files are the .fasl and .proto-imports files."
(declare (ignorable op))
- (append (output-files (make-instance 'compile-op) component) ; fasl
- (cdr (output-files (make-instance 'proto-to-lisp) component)))) ; proto-imports
+ (append (output-files (make-instance 'compile-op) component) ;fasl
+ (cdr (output-files (make-instance 'proto-to-lisp) component)))) ;proto-imports
(defmethod perform ((op load-op) (component protobuf-file))
(let* ((input (protobuf-input-file component))
(setf (proto-imported-schemas schema)
(nconc (proto-imported-schemas schema) (list imported)))
(return-from import-one))
- (%process-import import import-name)
+ (do-process-import import import-name)
(let* ((imported (find-schema (class-name->proto import-name))))
(when imported
(setf (proto-imported-schemas schema)
(import-name (pathname-name import)))
;; If this schema has already been loaded, we're done.
(unless (find-schema (class-name->proto import-name))
- (%process-import import import-name)))))))
+ (do-process-import import import-name)))))))
-(defun %process-import (import import-name
- &key (search-path *protobuf-search-path*)
- (output-path *protobuf-output-path*))
+(defun do-process-import (import import-name
+ &key (search-path *protobuf-search-path*)
+ (output-path *protobuf-output-path*))
(dolist (path search-path (error "Could not import ~S" import))
(let* ((base-path (asdf::merge-pathnames* import path))
(proto-file (make-pathname :name import-name :type "proto"
(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."))
+ :initarg :type-name))
(: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"
+ (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."))
+ :initarg :field))
(: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."
+ (format stream "~? Field ~A in message ~A has unknown type ~A"
(simple-condition-format-control condition)
(simple-condition-format-arguments condition)
(error-field condition)
(proto-parent (error-field condition))
(error-type-name condition)))))
+;; The serializers use this a lot, so wrap it up
+(defun undefined-field-type (format-control object type field)
+ (error 'undefined-field-type
+ :format-control format-control
+ :format-arguments (list object)
+ :type-name (prin1-to-string type)
+ :field field))
+
(define-condition undefined-method-type (undefined-type)
((method :type protobuf-method
:reader error-method
- :initarg :method
- :documentation "The method that references TYPE-NAME.")
+ :initarg :method)
(where :type string
:reader error-where
:initarg :where
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."
+ (format stream "~? ~A type for RPC ~A in service ~A has unknown type ~A"
(simple-condition-format-control condition)
(simple-condition-format-arguments condition)
(error-where condition)
(setf (gethash (make-pathname :type nil :defaults path) *all-schemas*) schema))))))
(defmethod print-object ((s protobuf-schema) stream)
- (print-unreadable-object (s stream :type t :identity t)
- (format stream "~@[~S~]~@[ (package ~A)~]"
- (when (slot-boundp s 'class) (proto-class s)) (proto-package s))))
+ (if *print-escape*
+ (print-unreadable-object (s stream :type t :identity t)
+ (format stream "~@[~S~]~@[ (package ~A)~]"
+ (and (slot-boundp s 'class) (proto-class s)) (proto-package s)))
+ (format stream "~S" (and (slot-boundp s 'class) (proto-class s)))))
(defgeneric make-qualified-name (proto name)
(:documentation
(make-load-form-saving-slots o :environment environment))
(defmethod print-object ((o protobuf-option) stream)
- (print-unreadable-object (o stream :type t :identity t)
- (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o))))
+ (if *print-escape*
+ (print-unreadable-object (o stream :type t :identity t)
+ (format stream "~A~@[ = ~S~]" (proto-name o) (proto-value o)))
+ (format stream "~A" (proto-name o))))
(defgeneric find-option (protobuf name)
(:documentation
(make-load-form-saving-slots e :environment environment))
(defmethod print-object ((e protobuf-enum) stream)
- (print-unreadable-object (e stream :type t :identity t)
- (format stream "~S~@[ (alias for ~S)~]"
- (when (slot-boundp e 'class) (proto-class e)) (proto-alias-for e))))
+ (if *print-escape*
+ (print-unreadable-object (e stream :type t :identity t)
+ (format stream "~S~@[ (alias for ~S)~]"
+ (and (slot-boundp e 'class) (proto-class e)) (proto-alias-for e)))
+ (format stream "~S"
+ (and (slot-boundp e 'class) (proto-class e)))))
(defmethod make-qualified-name ((enum protobuf-enum) name)
;; The qualified name is the enum name "dot" the name
(make-load-form-saving-slots v :environment environment))
(defmethod print-object ((v protobuf-enum-value) stream)
- (print-unreadable-object (v stream :type t :identity t)
- (format stream "~A = ~D"
- (proto-name v) (proto-index v))))
+ (if *print-escape*
+ (print-unreadable-object (v stream :type t :identity t)
+ (format stream "~A = ~D"
+ (proto-name v) (proto-index v)))
+ (format stream "~A" (proto-name v))))
;; A Protobufs message
(setf (gethash name *all-messages*) message)))))
(defmethod print-object ((m protobuf-message) stream)
- (print-unreadable-object (m stream :type t :identity t)
- (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
- (when (slot-boundp m 'class) (proto-class m))
- (proto-alias-for m)
- (eq (proto-message-type m) :group)
- (eq (proto-message-type m) :extends))))
+ (if *print-escape*
+ (print-unreadable-object (m stream :type t :identity t)
+ (format stream "~S~@[ (alias for ~S)~]~@[ (group~*)~]~@[ (extended~*)~]"
+ (and (slot-boundp m 'class) (proto-class m))
+ (proto-alias-for m)
+ (eq (proto-message-type m) :group)
+ (eq (proto-message-type m) :extends)))
+ (format stream "~S" (and (slot-boundp m 'class) (proto-class m)))))
(defmethod proto-package ((message protobuf-message))
(and (proto-parent message)
(make-load-form-saving-slots f :environment environment))
(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)
- (when (slot-boundp f 'class) (proto-class f))
- (proto-index f)
- (eq (proto-message-type f) :group)
- (eq (proto-message-type f) :extends))))
+ (if *print-escape*
+ (print-unreadable-object (f stream :type t :identity t)
+ (format stream "~S :: ~S = ~D~@[ (group~*)~]~@[ (extended~*)~]"
+ (proto-value f)
+ (and (slot-boundp f 'class) (proto-class f))
+ (proto-index f)
+ (eq (proto-message-type f) :group)
+ (eq (proto-message-type f) :extends)))
+ (format stream "~S" (proto-value f))))
;; The 'value' slot really holds the name of the slot,
;; so let's give it a better name
(make-load-form-saving-slots s :environment environment))
(defmethod print-object ((s protobuf-service) stream)
- (print-unreadable-object (s stream :type t :identity t)
- (format stream "~A"
- (proto-name s))))
+ (if *print-escape*
+ (print-unreadable-object (s stream :type t :identity t)
+ (format stream "~S" (proto-name s)))
+ (format stream "~S" (proto-name s))))
(defgeneric find-method (service name)
(:documentation
(make-load-form-saving-slots m :environment environment))
(defmethod print-object ((m protobuf-method) stream)
- (print-unreadable-object (m stream :type t :identity t)
- (format stream "~S (~S) => (~S)"
- (proto-class m)
- (when (slot-boundp m 'itype) (proto-input-type m))
- (when (slot-boundp m 'otype) (proto-output-type m)))))
+ (if *print-escape*
+ (print-unreadable-object (m stream :type t :identity t)
+ (format stream "~S (~S) => (~S)"
+ (proto-class m)
+ (and (slot-boundp m 'itype) (proto-input-type m))
+ (and (slot-boundp m 'otype) (proto-output-type m))))
+ (format stream "~S" (proto-class m))))
;;; Lisp-only extensions
(make-load-form-saving-slots m :environment environment))
(defmethod print-object ((m protobuf-type-alias) stream)
- (print-unreadable-object (m stream :type t :identity t)
- (format stream "~S (maps ~S to ~S)"
- (proto-class m)
- (proto-lisp-type m) (proto-proto-type m))))
+ (if *print-escape*
+ (print-unreadable-object (m stream :type t :identity t)
+ (format stream "~S (maps ~S to ~S)"
+ (proto-class m)
+ (proto-lisp-type m) (proto-proto-type m)))
+ (format stream "~S" (proto-class m))))
(defgeneric find-type-alias (protobuf type)
(:documentation
: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."))
+ (: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
(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'."
+ "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)))
((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
+ ;;---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)))
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'."
+ "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)))
(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?
+ ;;---bwagner: Is 'extend' allowed to use a forward reference to a message?
(message (find-message protobuf name))
(extends (and message
(make-instance 'protobuf-message
(find-enum (proto-parent field) type)))))
(unless (or ptype message)
(error 'undefined-field-type
- :type-name type
- :field field))
+ :type-name type
+ :field field))
(setf (proto-class field) (or ptype (proto-class message))))
nil)
"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))
+ (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))
+ (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
+ ;; 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))
+ :type-name input-name
+ :method method))
(unless output-message
(error 'undefined-output-type
- :type-name output-name
- :method method))
+ :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))
+ :type-name streams-name
+ :method method))
(setf (proto-streams-type method) (proto-class streams-message))))
nil)
(let ((v (funcall (proto-serializer msg) v)))
(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))))
+ (undefined-field-type "While serializing ~S,"
+ object type field))))
(t
(cond ((eq type :bool)
;; We have to handle optional boolean fields specially
(setq index (serialize-prim v type tag buffer index))))))
((keywordp type)
(let ((v (read-slot object slot reader)))
- (when v
+ (when (and v (not (equal v (proto-default field))))
(let ((tag (make-tag type (proto-index field))))
(setq index (serialize-prim v type tag buffer index))))))
((typep (setq msg (and type (or (find-message trace type)
(do-field v msg f)))))))
((typep msg 'protobuf-enum)
(let ((v (read-slot object slot reader)))
- (when v
+ (when (and v (not (eql v (proto-default field))))
(let ((tag (make-tag $wire-type-varint (proto-index field))))
(setq index (serialize-enum v (proto-values msg) tag buffer index))))))
((typep msg 'protobuf-type-alias)
(tag (make-tag type (proto-index field))))
(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)))))))))
+ (undefined-field-type "While serializing ~S,"
+ object type field)))))))))
(declare (dynamic-extent #'do-field))
(dolist (field (proto-fields message))
(do-field object message field))))
(let ((v (funcall (proto-serializer msg) v)))
(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))))
+ (undefined-field-type "While computing the size of ~S,"
+ object type field))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(iincf size (prim-size v type tag))))))
((keywordp type)
(let ((v (read-slot object slot reader)))
- (when v
+ (when (and v (not (equal v (proto-default field))))
(let ((tag (make-tag type (proto-index field))))
(iincf size (prim-size v type tag))))))
((typep (setq msg (and type (or (find-message trace type)
(do-field v msg f)))))))
((typep msg 'protobuf-enum)
(let ((v (read-slot object slot reader)))
- (when v
+ (when (and v (not (eql v (proto-default field))))
(let ((tag (make-tag $wire-type-varint (proto-index field))))
(iincf size (enum-size (read-slot object slot reader) (proto-values msg) tag))))))
((typep msg 'protobuf-type-alias)
(tag (make-tag type (proto-index field))))
(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)))))))))
+ (undefined-field-type "While computing the size of ~S,"
+ object type field)))))))))
(declare (dynamic-extent #'do-field))
(dolist (field (proto-fields message))
(do-field object message field))
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
(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)))))
+ (undefined-field-type "While generating 'serialize-object' for ~S,"
+ message class field)))))
(t
(cond ((keywordp class)
(collect-serializer
(t :unbound))))
(unless (eq ,vval :unbound)
(setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))
- `(let ((,vval ,reader))
- (when ,vval
- (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))))))
+ (if (empty-default-p field)
+ `(let ((,vval ,reader))
+ (when ,vval
+ (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx))))
+ `(let ((,vval ,reader))
+ (when (and ,vval (not (equal ,vval ',(proto-default field))))
+ (setq ,vidx (serialize-prim ,vval ,class ,tag ,vbuf ,vidx)))))))))
((typep msg 'protobuf-message)
(collect-serializer
(if (eq (proto-message-type msg) :group)
((typep msg 'protobuf-enum)
(collect-serializer
(let ((tag (make-tag $wire-type-varint index)))
- `(let ((,vval ,reader))
- (when ,vval
- (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx)))))))
+ (if (empty-default-p field)
+ `(let ((,vval ,reader))
+ (when ,vval
+ (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))
+ `(let ((,vval ,reader))
+ (when (and ,vval (not (eql ,vval ',(proto-default field))))
+ (setq ,vidx (serialize-enum ,vval '(,@(proto-values msg)) ,tag ,vbuf ,vidx))))))))
((typep msg 'protobuf-type-alias)
(collect-serializer
(let* ((class (proto-proto-type msg))
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
(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))))))))
+ (undefined-field-type "While generating 'serialize-object' for ~S,"
+ message class field))))))))
`(defmethod serialize-object
(,vobj (,vclass (eql ,message)) ,vbuf &optional (,vidx 0) visited)
(declare #.$optimize-serialization)
(setq ,vidx idx)
(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))))
+ (undefined-field-type "While generating 'deserialize-object' for ~S,"
+ message class field))))
(t
(cond ((keywordp class)
(collect-deserializer
(setq ,vidx idx)
,(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))))))))
+ (undefined-field-type "While generating 'deserialize-object' for ~S,"
+ message class field))))))))
(let* ((rslots (delete-duplicates rslots :key #'first))
(rfields (mapcar #'first rslots))
(rtemps (mapcar #'second rslots)))
(let ((,vval (funcall #',(proto-serializer msg) ,vval)))
(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)))))
+ (undefined-field-type "While generating 'object-size' for ~S,"
+ message class field)))))
(t
(cond ((keywordp class)
(let ((tag (make-tag class index)))
(t :unbound))))
(unless (eq ,vval :unbound)
(iincf ,vsize (prim-size ,vval ,class ,tag)))))
- `(let ((,vval ,reader))
- (when ,vval
- (iincf ,vsize (prim-size ,vval ,class ,tag))))))))
+ (if (empty-default-p field)
+ `(let ((,vval ,reader))
+ (when ,vval
+ (iincf ,vsize (prim-size ,vval ,class ,tag))))
+ `(let ((,vval ,reader))
+ (when (and ,vval (not (equal ,vval ',(proto-default field))))
+ (iincf ,vsize (prim-size ,vval ,class ,tag)))))))))
((typep msg 'protobuf-message)
(collect-sizer
(if (eq (proto-message-type msg) :group)
((typep msg 'protobuf-enum)
(let ((tag (make-tag $wire-type-varint index)))
(collect-sizer
- `(let ((,vval ,reader))
- (when ,vval
- (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag)))))))
+ (if (empty-default-p field)
+ `(let ((,vval ,reader))
+ (when ,vval
+ (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))
+ `(let ((,vval ,reader))
+ (when (and ,vval (not (eql ,vval ',(proto-default field))))
+ (iincf ,vsize (enum-size ,vval '(,@(proto-values msg)) ,tag))))))))
((typep msg 'protobuf-type-alias)
(collect-sizer
(let* ((class (proto-proto-type msg))
(tag (make-tag class index)))
`(let ((,vval ,reader))
(when ,vval
- (iincf ,vsize (prim-size
- (funcall #',(proto-serializer msg) ,vval)
- ,class ,tag)))))))
+ (iincf ,vsize (prim-size (funcall #',(proto-serializer msg) ,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))))))))
+ (undefined-field-type "While generating 'object-size' for ~S,"
+ message class field))))))))
`(defmethod object-size
(,vobj (,vclass (eql ,message)) &optional visited)
(declare #.$optimize-serialization)
:conc-name nil)))
(parse-message-with-field-type (type)
(parse-schema-containing (format nil "message MessageWithUndefinedFieldType {~%~
- ~& optional ~a bar = 1;~%~
+ ~& optional ~A bar = 1;~%~
}~%" type)))
(parse-service-with-rpc (rpc)
(parse-schema-containing (format nil "service ServiceWithUndefinedMethodType {~%~
- ~& ~a~%~
+ ~& ~A~%~
}~%" rpc)))
(poor-mans-assert-regex-equal (expected-strings actual-string)
(assert-true
(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))
+ (list "Undefined type: Field "
+ "BAR"
+ "in message "
+ "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))
+ (list (format nil "Undefined type: ~A type for RPC " where)
+ (format nil "~A" method-lisp-name)
+ "in 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) ~
+ (format nil "rpc MethodWithUndefinedInput (~A) ~
returns (DefinedMessage);" input-type)))))
(method-test-assertions condition "Input" "METHOD-WITH-UNDEFINED-INPUT"
"MethodWithUndefinedInput" input-type)))
(let ((condition (assert-error undefined-output-type
(parse-service-with-rpc
(format nil "rpc MethodWithUndefinedOutput (DefinedMessage) ~
- returns (~a);" output-type)))))
+ returns (~A);" output-type)))))
(method-test-assertions condition "Output" "METHOD-WITH-UNDEFINED-OUTPUT"
"MethodWithUndefinedOutput" output-type)))
(do-method-stream-test (stream-type)
(parse-service-with-rpc
(format nil "rpc MethodWithUndefinedStream (DefinedMessage) ~
returns (DefinedMessage) {~
- ~& option stream_type = \"~a\";~
+ ~& option stream_type = \"~A\";~
~& };" stream-type)))))
(method-test-assertions condition "Stream" "METHOD-WITH-UNDEFINED-STREAM"
"MethodWithUndefinedStream" stream-type))))
"ASSERT-EQUAL"
"ASSERT-TRUE"
"ASSERT-FALSE"
+ "ASSERT-ERROR")
+ (:export
+ "DEFINE-TEST"
+ "DEFINE-TEST-SUITE"
+ "REGISTER-TEST"
+ "RUN-TEST"
+ "RUN-ALL-TESTS"
+ "ASSERT-EQUAL"
+ "ASSERT-TRUE"
+ "ASSERT-FALSE"
"ASSERT-ERROR"))
+
+;;; Packages used by .oroto files
+
(defpackage protobuf-unittest
(:use :common-lisp :protobufs)
(:nicknames :pbtest))
(defmacro assert-equal (actual expected &key (test '#'equal))
`(unless (funcall ,test ,actual ,expected)
- (warn "The value ~S is not equal to the expected value ~S"
- ',actual ',expected)))
+ (warn "The value of ~S (~S) is not equal to the expected value ~S"
+ ',actual ,actual ,expected)))
(defmacro assert-true (form)
`(unless ,form
- (warn "The value ~S does not evaluate to 'true'"
- ',form)))
+ (warn "The value of ~S (~S) does not evaluate to 'true'"
+ ',form ,form)))
(defmacro assert-false (form)
`(when ,form
- (warn "The value ~S does not evaluate to 'false'"
- ',form)))
+ (warn "The value ~S (~S) does not evaluate to 'false'"
+ ',form ,form)))
(defmacro assert-error (condition &body body)
"Checks if BODY signals a condition of class CONDITION. If it does not, a failure is
(print-prim v type field stream
(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))))
+ (undefined-field-type "While printing ~S to text format,"
+ object type field))))
(t
(cond ((eq type :bool)
(let ((v (cond ((or (eq (proto-required field) :required)
(or suppress-line-breaks indent)))))
((keywordp type)
(let ((v (read-slot object slot reader)))
- (when v
+ (when (and v (not (equal v (proto-default field))))
(print-prim v type field stream
(or suppress-line-breaks indent)))))
((typep (setq msg (and type (or (find-message trace type)
(format stream "~&~VT}~%" indent))))))
((typep msg 'protobuf-enum)
(let ((v (read-slot object slot reader)))
- (when v
+ (when (and v (not (eql v (proto-default field))))
(print-enum v msg field stream
(or suppress-line-breaks indent)))))
((typep msg 'protobuf-type-alias)
(print-prim v type field stream
(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)))))))))
+ (undefined-field-type "While printing ~S to text format,"
+ object type field)))))))))
(declare (dynamic-extent #'do-field))
(if print-name
(if suppress-line-breaks
(push (funcall (proto-deserializer msg) val)
(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))))
+ (undefined-field-type "While parsing ~S from text format,"
+ message type field))))
(t
(cond ((keywordp type)
(expect-char stream #\:)
(setf (slot-value object slot)
(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)))))))))))
+ (undefined-field-type "While parsing ~S from text format,"
+ message type field)))))))))))
(declare (dynamic-extent #'deserialize))
(deserialize (proto-class message) message)))
;;; Can a version of a Protobufs schema be upgraded to a new version
-(defgeneric schema-upgradable (old new &optional old-parent new-parent)
- (:documentation
- "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'.
- If the schema is not upgradable, the second value is a list of warnings."))
-
(defvar *upgrade-warnings*)
-(defmacro upgrade-warn ((predicate old new) format-string &optional name)
- "Collect an upgrade warning into *upgrade-warnings*."
+(defun upgrade-warn (format-string &rest format-args)
+ "Collect an upgrade warning into *upgrade-warnings*.
+ Returns the list of warnings."
+ (push (apply #'format nil format-string format-args) *upgrade-warnings*))
+
+(defmacro upgrade-assert ((predicate old new) format-string &optional name)
+ "Assert that the condition is true, otherwise issue an upgrade warning."
(with-gensyms (vold vnew)
`(let* ((,vold ,old)
(,vnew ,new))
(t
;; Note that this returns the non-NIL value of *upgrade-warnings*,
;; so the upgradable check will continue to collect warnings
- (push (format nil ,format-string
- ,@(if name (list name vold vnew) (list vold vnew)))
- *upgrade-warnings*))))))
+ (upgrade-warn ,format-string ,@(if name (list name vold vnew) (list vold vnew))))))))
+
+
+(defgeneric schema-upgradable (old new &optional old-parent new-parent)
+ (:documentation
+ "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'.
+ If the schema is not upgradable, the second value is a list of warnings."))
(defmethod schema-upgradable ((old protobuf-schema) (new protobuf-schema)
&optional old-parent new-parent)
(let ((*upgrade-warnings* ()))
(and
;; Are they named the same?
- (upgrade-warn (string= (proto-name old) (proto-name new))
- "Protobuf schema name changed from '~A' to '~A'")
- (upgrade-warn (string= (proto-package old) (proto-package new))
- "Protobuf schema package changed from '~A' to '~A'")
+ (upgrade-assert (string= (proto-name old) (proto-name new))
+ "Protobuf schema name changed from '~A' to '~A'")
+ (upgrade-assert (string= (proto-package old) (proto-package new))
+ "Protobuf schema package changed from '~A' to '~A'")
;; Is every enum in 'old' upgradable to an enum in 'new'?
(loop for old-enum in (proto-enums old)
as new-enum = (find (proto-name old-enum) (proto-enums new)
(declare (ignore new-enum))
;; No need to check that the names are equal, our caller did that already
;; Do they have the same index?
- (upgrade-warn (= (proto-index old) (proto-index new))
- "Enum index for '~A' changed from ~D to ~D"
- (format nil "~A.~A" (proto-name old-enum) (proto-name old))))
+ (upgrade-assert (= (proto-index old) (proto-index new))
+ "Enum index for '~A' changed from ~D to ~D"
+ (format nil "~A.~A" (proto-name old-enum) (proto-name old))))
(defmethod schema-upgradable ((old protobuf-message) (new protobuf-message)
(schema-upgradable old-fld new-fld old new)
;; If there's no new field, the old one must not be required
(or (member (proto-required old-fld) '(:optional :repeated))
- (push (format nil "Old field '~A.~A' was required, and is now missing"
- (proto-name old) (proto-name old-fld))
- *upgrade-warnings*))))))
+ (upgrade-warn "Old field '~A.~A' was required, and is now missing"
+ (proto-name old) (proto-name old-fld)))))))
(defmethod schema-upgradable ((old protobuf-field) (new protobuf-field)
&optional old-message new-message)
(flet ((arity-upgradable (old-arity new-arity)
(or (eq old-arity new-arity)
+ ;; Don't add new required fields
(not (eq new-arity :required))
;; Optional fields and extensions are compatible
(and (eq old-arity :optional)
;; No need to check that the names are equal, our caller did that already
(and
;; Do they have the same index?
- (upgrade-warn (= (proto-index old) (proto-index new))
- "Field index for '~A' changed from ~D to ~D"
- (format nil "~A.~A" (proto-name old-message) (proto-name old)))
+ (upgrade-assert (= (proto-index old) (proto-index new))
+ "Field index for '~A' changed from ~D to ~D"
+ (format nil "~A.~A" (proto-name old-message) (proto-name old)))
;; Are the arity and type upgradable?
- (upgrade-warn (arity-upgradable (proto-required old) (proto-required new))
- "Arity of ~A, ~S, is not upgradable to ~S"
- (format nil "~A.~A" (proto-name old-message) (proto-name old)))
- (upgrade-warn (type-upgradable (proto-type old) (proto-type new))
- "Type of '~A', ~A, is not upgradable to ~A"
- (format nil "~A.~A" (proto-name old-message) (proto-name old))))))
+ (upgrade-assert (arity-upgradable (proto-required old) (proto-required new))
+ "Arity of ~A, ~S, is not upgradable to ~S"
+ (format nil "~A.~A" (proto-name old-message) (proto-name old)))
+ (upgrade-assert (type-upgradable (proto-type old) (proto-type new))
+ "Type of '~A', ~A, is not upgradable to ~A"
+ (format nil "~A.~A" (proto-name old-message) (proto-name old)))
+ ;; Is the default the same?
+ (upgrade-assert (equal (proto-default old) (proto-default new))
+ "Old default for ~A, ~S, is not equal to new default ~S"
+ (format nil "~A.~A" (proto-name old-message) (proto-name old))))))
(defmethod schema-upgradable ((old protobuf-service) (new protobuf-service)
;; No need to check that the names are equal, our caller did that already
(and
;; Are their inputs and outputs the same?
- (upgrade-warn (string= (proto-input-name old) (proto-input-name new))
- "Input type for ~A, ~A, is not upgradable to ~A"
- (format nil "~A.~A" (proto-name old-service) (proto-name old)))
- (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)))))
+ (upgrade-assert (string= (proto-input-name old) (proto-input-name new))
+ "Input type for ~A, ~A, is not upgradable to ~A"
+ (format nil "~A.~A" (proto-name old-service) (proto-name old)))
+ (upgrade-assert (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 protobuf schemas equal?
(or (null (proto-class schema1)) (null (proto-class schema2))
(eql (proto-class schema1) (proto-class schema2)))
(or (null (proto-name schema1)) (null (proto-name schema2))
- (equalp (proto-name schema1) (proto-name schema2)))
- (equalp (proto-syntax schema1) (proto-syntax schema2))
- (equalp (proto-package schema1) (proto-package schema2))
- (equalp (proto-lisp-package schema1) (proto-lisp-package schema2))
- (equalp (proto-imports schema1) (proto-imports schema2))
+ (equal (proto-name schema1) (proto-name schema2)))
+ (equal (proto-syntax schema1) (proto-syntax schema2))
+ (equal (proto-package schema1) (proto-package schema2))
+ (equal (proto-lisp-package schema1) (proto-lisp-package schema2))
+ (equal (proto-imports schema1) (proto-imports schema2))
(= (length (proto-options schema1)) (length (proto-options schema2)))
(loop for option1 in (proto-options schema1)
as option2 = (find (proto-name option1) (proto-options schema2)
(defmethod schemas-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))))
+ (equal (proto-value option1) (proto-value option2))
+ (equal (proto-type option1) (proto-type option2))))
(defmethod schemas-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))
+ (eql (proto-class enum1) (proto-class enum2))
+ (equal (proto-name enum1) (proto-name enum2))
+ (equal (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)
(defmethod schemas-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))))
+ (eql (proto-class value1) (proto-class value2))
+ (equal (proto-name value1) (proto-name value2))
+ (eql (proto-index value1) (proto-index value2))
+ (equal (proto-value value1) (proto-value value2))))
(defmethod schemas-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))
+ (eql (proto-class message1) (proto-class message2))
+ (equal (proto-name message1) (proto-name message2))
+ (equal (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)
(defmethod schemas-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))
+ (eql (proto-class field1) (proto-class field2))
+ (equal (proto-name field1) (proto-name field2))
+ (equal (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))
+ (equal (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)
(defmethod schemas-equal ((service1 protobuf-service) (service2 protobuf-service))
(and
- (eql (proto-class service1) (proto-class service2))
- (equalp (proto-name service1) (proto-name service2))
+ (eql (proto-class service1) (proto-class service2))
+ (equal (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)
(defmethod schemas-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))
- (eql (proto-index method1) (proto-index method2))
+ (eql (proto-class method1) (proto-class method2))
+ (equal (proto-name method1) (proto-name method2))
+ (eql (proto-input-type method1) (proto-input-type method2))
+ (eql (proto-output-type method1) (proto-output-type method2))
+ (equal (proto-input-name method1) (proto-input-name method2))
+ (equal (proto-output-name method1) (proto-output-name method2))
+ (eql (proto-index method1) (proto-index 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)
;; A parameterized list type for repeated fields
;; The elements aren't type-checked
(deftype list-of (type)
- (if (eq type 'nil) ; a list that cannot have any element (element-type nil) is null.
+ (if (eq type 'nil) ;a list that cannot have any element (element-type nil) is null
'null
'list))
;; The same, but use a (stretchy) vector
(deftype vector-of (type)
- (if (eq type 'nil); an array that cannot have any element (element-type nil) is of size 0.
+ (if (eq type 'nil) ;an array that cannot have any element (element-type nil) is of size 0
'(array * (0))
- '(array * (*)))) ;an 1-dimensional array of any type
+ '(array * (*)))) ;a 1-dimensional array of any type
;; This corresponds to the :bytes Protobufs type
(deftype byte-vector () '(array (unsigned-byte 8) (*)))
projects / cl-protobufs.git / commitdiff