From 0d1611ab340edbc1ea982bd52ed91f6e8f6d2617 Mon Sep 17 00:00:00 2001 From: Scott McKay Date: Fri, 18 May 2012 21:04:02 +0000 Subject: [PATCH] Now that Protobufs has a test suite, it found a few things to fix. - Don't generate warnings for anonymous enums, they're harmless and ubiquitous. - 'member' types where are all the members are keywords, is a symbol, which got converted to a Protobufs 'string'. Wrong. - If a field has an enum type, the (Lisp) default value should be treated as a keyword. - When parsing a .proto file or using the 'define-xxx' macros, any options that are handled specially should be trimmed from the options list so that they don't get printed twice. - Add 'remove-options' for the above. - Make the options printer be more type-aware. - Clean up examples.lisp - 'schemas-equal' can ignore the schema name/class if they're null. Passes 'precheckin'. Even with the new unit tests in place. git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/quux/protobufs@544737 f8382938-511b-0410-9cdd-bb47b084005c --- asdf-support.lisp | 16 +- clos-transform.lisp | 13 +- define-proto.lisp | 25 +- examples.lisp | 588 +++---------------------------- model-classes.lisp | 19 + parser.lisp | 20 +- proto-pkgdcl.lisp => pkgdcl.lisp | 10 +- printer.lisp | 28 +- protobufs.asd | 69 ++-- upgradable.lisp | 7 +- wire-format.lisp | 22 +- 11 files changed, 194 insertions(+), 623 deletions(-) rename proto-pkgdcl.lisp => pkgdcl.lisp (95%) diff --git a/asdf-support.lisp b/asdf-support.lisp index 785e673..095d583 100644 --- a/asdf-support.lisp +++ b/asdf-support.lisp @@ -13,8 +13,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) -(defclass proto-file (asdf:cl-source-file) - ((asdf::type :initform "proto")) +(defclass protobuf-file (asdf:cl-source-file) + ((asdf::type :initform "protobuf")) (:documentation "This ASDF component defines COMPILE-OP and LOAD-OP operations that compiles the .proto file into a .lisp file, and the compiles @@ -22,29 +22,29 @@ ) ;eval-when -(defmethod asdf:output-files ((op asdf:compile-op) (c proto-file)) +(defmethod asdf:output-files ((op asdf:compile-op) (c protobuf-file)) (append (call-next-method) (make-pathname :type "lisp" :defaults (asdf:component-pathname c)))) -(defmethod asdf:perform ((op asdf:compile-op) (c proto-file)) +(defmethod asdf:perform ((op asdf:compile-op) (c protobuf-file)) (destructuring-bind (fasl-file lisp-file) (asdf:output-files op c) (funcall asdf::*compile-op-compile-file-function* (parse-protobuf-file (asdf:component-pathname c) lisp-file) :output-file fasl-file))) -(defmethod asdf:perform ((op asdf:load-source-op) (c proto-file)) +(defmethod asdf:perform ((op asdf:load-source-op) (c protobuf-file)) (destructuring-bind (fasl-file lisp-file) (asdf:output-files op c) (declare (ignore fasl-file)) (load (parse-protobuf-file (asdf:component-pathname c) lisp-file)))) -(defun parse-protobuf-file (proto-file lisp-file) - (let ((protobuf (parse-schema-from-file proto-file))) +(defun parse-protobuf-file (protobuf-file lisp-file) + (let ((schema (parse-schema-from-file protobuf-file))) (with-open-file (stream lisp-file :direction :output :if-exists :supersede) - (write-schema protobuf :stream stream :type :lisp))) + (write-schema schema :stream stream :type :lisp))) lisp-file) diff --git a/clos-transform.lisp b/clos-transform.lisp index 1239e2b..0e0512b 100644 --- a/clos-transform.lisp +++ b/clos-transform.lisp @@ -138,6 +138,7 @@ (every #'(lambda (name) (starts-with name prefix)) names)) (setq names (mapcar #'(lambda (name) (subseq name (length prefix))) names))) (unless (and unexpanded-type (symbolp unexpanded-type)) + #+ignore ;this happens constantly, the warning is not useful (protobufs-warn "Use DEFTYPE to define a MEMBER type instead of directly using ~S" expanded-type)) (make-instance 'protobuf-enum @@ -225,7 +226,8 @@ (values "string" :symbol)) (otherwise (cond ((ignore-errors - (subtypep type '(or string character symbol))) + (or (eql type 'symbol) + (subtypep type '(or string character)))) (values "string" :string)) ((ignore-errors (subtypep type 'byte-vector)) @@ -238,7 +240,7 @@ ((or) (when (or (> (length tail) 2) (not (member 'null tail))) - (protobufs-warn "The OR type ~S is too complicated" type)) + (protobufs-warn "The OR type ~S is too complicated, proceeding anyway" type)) (if (eq (first tail) 'null) (clos-type-to-protobuf-type (second tail)) (clos-type-to-protobuf-type (first tail)))) @@ -258,7 +260,7 @@ (t (let ((new-tail (remove-if #'(lambda (x) (and (listp x) (eq (car x) 'satisfies))) tail))) (when (> (length new-tail) 1) - (protobufs-warn "The AND type ~S is too complicated" type)) + (protobufs-warn "The AND type ~S is too complicated, proceeding anyway" type)) (type->protobuf-type (first tail)))))) ((member) ;maybe generate an enum type (if (or (equal type '(member t nil)) @@ -363,7 +365,10 @@ default) ((symbolp default) (cond ((eq type :bool) - (boolean-true-p default)))) + (boolean-true-p default)) + ;; If we've got a symbol, it must be to initialize an enum type + ;; whose values are represented by keywords in Lisp + (t (kintern (symbol-name default))))) ((stringp default) (cond ((eq type :bool) (boolean-true-p default)) diff --git a/define-proto.lisp b/define-proto.lisp index 9bad506..337c445 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -31,17 +31,19 @@ (let* ((name (or name (class-name->proto type))) (package (and package (if (stringp package) package (string-downcase (string package))))) (lisp-pkg (and lisp-package (if (stringp lisp-package) lisp-package (string lisp-package)))) - (options (loop for (key val) on options by #'cddr - collect (make-instance 'protobuf-option - :name (if (symbolp key) (slot-name->proto key) key) - :value val))) + (options (remove-options + (loop for (key val) on options by #'cddr + collect (make-instance 'protobuf-option + :name (if (symbolp key) (slot-name->proto key) key) + :value val)) + "optimize_for" "lisp_package")) (imports (if (listp import) import (list import))) (schema (make-instance 'protobuf-schema :class type :name name :syntax (or syntax "proto2") :package package - :lisp-package (or lisp-pkg package) + :lisp-package (or lisp-pkg (substitute #\- #\_ package)) :imports imports :options (if optimize (append options (list (make-instance 'protobuf-option @@ -191,7 +193,7 @@ :parent *protobuf* :alias-for alias-for :conc-name (and conc-name (string conc-name)) - :options options + :options (remove-options options "default" "packed") :documentation documentation)) (index 0) (*protobuf* message)) @@ -283,12 +285,13 @@ :class type :name name :parent (proto-parent message) - :conc-name conc-name :alias-for alias-for + :conc-name conc-name :enums (copy-list (proto-enums message)) :messages (copy-list (proto-messages message)) :fields (copy-list (proto-fields message)) - :options (or options (copy-list (proto-options message))) + :options (remove-options + (or options (copy-list (proto-options message))) "default" "packed") :extensions (copy-list (proto-extensions message)) :message-type :extends ;this message is an extension :documentation documentation))) @@ -445,7 +448,7 @@ 'writer' is a Lisp slot writer function to use to set the value." (check-type index integer) (check-type arity (member :required :optional :repeated)) - (let* ((slot (or (and name (proto->slot-name name *protobuf-package*)) type)) + (let* ((slot (or type (and name (proto->slot-name name *protobuf-package*)))) (name (or name (class-name->proto type))) (options (loop for (key val) on options by #'cddr collect (make-instance 'protobuf-option @@ -476,7 +479,7 @@ :name name :alias-for alias-for :conc-name (and conc-name (string conc-name)) - :options options + :options (remove-options options "default" "packed") :message-type :group ;this message is a group :documentation documentation)) (index 0) @@ -549,7 +552,7 @@ reader)) (options (append (loop for (key val) on other-options by #'cddr - unless (member key '(:type :reader :writer :name :default :packed :documentation)) + unless (member key '(:type :reader :writer :name :default :packed :documentation)) collect (make-instance 'protobuf-option :name (slot-name->proto key) :value val)) diff --git a/examples.lisp b/examples.lisp index e85d0d9..8cdcecf 100644 --- a/examples.lisp +++ b/examples.lisp @@ -11,28 +11,10 @@ (in-package "PROTO-IMPL") -;;; Examples, for manual testing - -;;--- Turn these into a test suite - -#|| -(setq pnr-schema (proto:generate-schema-for-classes - '(qres-core::legacy-pnr - qres-core::legacy-pnr-pax - qres-core::legacy-pnr-segment - qres-core::legacy-pnr-pax-segment) - :slot-filter #'quake::quake-slot-filter - :type-filter #'quake::quake-type-filter - :enum-filter #'quake::quake-enum-filter - :value-filter #'quake::quake-value-filter)) - -(proto:write-schema pnr-schema) -(proto:write-schema pnr-schema :type :lisp) - -(proto:serialize-object-to-stream pnr 'qres-core::legacy-pnr :stream nil) -||# +;;; Some examples; also for some for manual testing #|| +;; A pretty useful subset of air schedule objects (setq sched-schema (proto:generate-schema-for-classes '(quux::zoned-time sched::scheduled-flight @@ -54,7 +36,9 @@ (proto:write-schema sched-schema :type :lisp) ||# + #|| +;; A pretty useful subset of geographic business data (defclass geodata () ((countries :type (proto:list-of qres-core::country) :initform () :initarg :countries) (regions :type (proto:list-of qres-core::region) :initform () :initarg :regions) @@ -78,6 +62,7 @@ (proto:write-schema bizd-schema) (proto:write-schema bizd-schema :type :lisp) +;; Load the data (let* ((countries (loop for v being the hash-values of (qres-core::country-business-data) collect (car v))) (regions (loop for v being the hash-values of (qres-core::region-business-data) collect v)) (cities (loop for v being the hash-values of (qres-core::city-business-data) collect (car v))) @@ -112,403 +97,9 @@ 'geodata :stream nil)) ||# -#|| -(setq pschema (proto:generate-schema-for-classes - '(proto:protobuf proto:protobuf-option - proto:protobuf-enum proto:protobuf-enum-value - proto:protobuf-message proto:protobuf-field proto:protobuf-extension - proto:protobuf-service proto:protobuf-method))) - -(proto:write-schema pschema) -(proto:write-schema pschema :type :lisp) - -(progn (setq pser (proto:serialize-object-to-stream pschema 'proto:protobuf :stream nil)) nil) -(describe (proto:deserialize-object 'proto:protobuf pser)) - -(proto:print-text-format pschema) -(proto:print-text-format (proto:deserialize-object 'proto:protobuf pser)) - -(dolist (class '(proto:protobuf - proto:protobuf-option - proto:protobuf-enum - proto:protobuf-enum-value - proto:protobuf-message - proto:protobuf-field - proto:protobuf-extension - proto:protobuf-service - proto:protobuf-method)) - (let ((message (proto-impl:find-message pschema class))) - (eval (proto-impl:generate-object-size message)) - (eval (proto-impl:generate-serializer message)) - (eval (proto-impl:generate-deserializer message)))) -||# - -#|| -(defclass proto-test1 () - ((intval :type (integer -2147483648 +2147483647) - :initarg :intval))) - -(defclass proto-test2 () - ((intval :type (or null (integer -2147483648 +2147483647)) - :initform nil - :initarg :intval) - (strval :type (or null string) - :initform nil - :initarg :strval))) - -(defclass proto-test3 () - ((intval :type (or null (integer -2147483648 +2147483647)) - :initform nil - :initarg :intval) - (strval :type (or null string) - :initform nil - :initarg :strval) - (recval :type (or null proto-test1) - :initform nil - :initarg :recval))) - -(defclass proto-test4 () - ((intval :type (or null (integer -2147483648 +2147483647)) - :initform nil - :initarg :intval) - (strval :type (or null string) - :initform nil - :initarg :strval) - (recval :type (or null proto-test2) - :initform nil - :initarg :recval))) - -(defclass proto-test5 () - ((color :type (member :red :green :blue) - :initarg :color) - (intvals :type (proto:list-of integer) - :initform () - :initarg :intvals) - (strvals :type (proto:list-of string) - :initform () - :initarg :strvals))) - -(defclass proto-test6 () - ((intvals :type (proto:list-of integer) - :initform () - :initarg :intvals) - (strvals :type (proto:list-of string) - :initform () - :initarg :strvals) - (recvals :type (proto:list-of proto-test2) - :initform () - :initarg :recvals))) - -(setq test-schema (proto:generate-schema-for-classes - '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6) - :install t)) - -(proto:write-schema test-schema) -(proto:write-schema test-schema :type :lisp) - -(dolist (class '(proto-test1 proto-test2 proto-test3 proto-test4 proto-test5 proto-test6)) - (let ((message (proto-impl:find-message test-schema class))) - (eval (proto-impl:generate-object-size message)) - (eval (proto-impl:generate-serializer message)) - (eval (proto-impl:generate-deserializer message)))) - -(setq test1 (make-instance 'proto-test1 :intval 150)) -(setq test1b (make-instance 'proto-test1 :intval -150)) -(setq test2 (make-instance 'proto-test2 :strval "testing")) -(setq test2b (make-instance 'proto-test2 :strval "1 2 3")) -(setq test3 (make-instance 'proto-test3 :recval test1)) -(setq test4 (make-instance 'proto-test4 :recval test2)) -(setq test5 (make-instance 'proto-test5 :color :red - :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven"))) -(setq test6 (make-instance 'proto-test6 :intvals '(2 3 5 7) :strvals '("two" "three" "five" "seven") - :recvals (list test2 test2b))) - -(setq tser1 (proto:serialize-object-to-stream test1 'proto-test1 :stream nil)) -(equalp tser1 #(#x08 #x96 #x01)) -(describe (proto:deserialize-object 'proto-test1 tser1)) - -(setq tser1b (proto:serialize-object-to-stream test1b 'proto-test1 :stream nil)) -(equalp tser1b #(#x08 #xEA #xFE #xFF #xFF #x0F)) -(describe (proto:deserialize-object 'proto-test1 tser1b)) - -(setq tser2 (proto:serialize-object-to-stream test2 'proto-test2 :stream nil)) -(equalp tser2 #(#x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)) -(describe (proto:deserialize-object 'proto-test2 tser2)) - -(setq tser3 (proto:serialize-object-to-stream test3 'proto-test3 :stream nil)) -(equalp tser3 #(#x1A #x03 #x08 #x96 #x01)) -(describe (proto:deserialize-object 'proto-test3 tser3)) -(describe (slot-value (proto:deserialize-object 'proto-test3 tser3) 'recval)) - -(setq tser4 (proto:serialize-object-to-stream test4 'proto-test4 :stream nil)) -(equalp tser4 #(#x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67)) -(describe (proto:deserialize-object 'proto-test4 tser4)) -(describe (slot-value (proto:deserialize-object 'proto-test4 tser4) 'recval)) - -(setq tser5 (proto:serialize-object-to-stream test5 'proto-test5 :stream nil)) -(equalp tser5 #(#x08 #x00 - #x10 #x04 #x02 #x03 #x05 #x07 - #x1A #x03 #x74 #x77 #x6F #x1A #x05 #x74 #x68 #x72 #x65 #x65 #x1A #x04 #x66 #x69 #x76 #x65 #x1A #x05 #x73 #x65 #x76 #x65 #x6E)) -(describe (proto:deserialize-object 'proto-test5 tser5)) - -(setq tser6 (proto:serialize-object-to-stream test6 'proto-test6 :stream nil)) -(equalp tser6 #(#x08 #x04 #x02 #x03 #x05 #x07 #x12 #x03 #x74 #x77 #x6F #x12 #x05 #x74 #x68 #x72 #x65 #x65 #x12 #x04 #x66 #x69 #x76 #x65 #x12 #x05 #x73 #x65 #x76 #x65 #x6E #x1A #x09 #x12 #x07 #x74 #x65 #x73 #x74 #x69 #x6E #x67 #x1A #x07 #x12 #x05 #x31 #x20 #x32 #x20 #x33)) -(describe (proto:deserialize-object 'proto-test6 tser6)) -(describe (slot-value (proto:deserialize-object 'proto-test6 tser6) 'recvals)) - - -(equalp (mapcar #'proto-impl:zig-zag-encode32 - '(0 -1 1 -2 2 -2147483648 2147483647)) - '(0 1 2 3 4 4294967295 4294967294)) -(equalp (mapcar #'proto-impl:zig-zag-encode64 - '(0 -1 1 -2 2 -2147483648 2147483647 -1152921504606846976 1152921504606846975)) - '(0 1 2 3 4 4294967295 4294967294 2305843009213693951 2305843009213693950)) - -(proto:print-text-format test1) -(proto:print-text-format (proto:deserialize-object 'proto-test1 tser1)) -(let ((text (with-output-to-string (s) - (proto:print-text-format test1 'proto-test1 :stream s)))) - (with-input-from-string (s text) - (proto:parse-text-format 'proto-test1 :stream s))) - -(proto:print-text-format test2) -(proto:print-text-format (proto:deserialize-object 'proto-test2 tser2)) -(let ((text (with-output-to-string (s) - (proto:print-text-format test2 'proto-test2 :stream s)))) - (with-input-from-string (s text) - (proto:parse-text-format 'proto-test2 :stream s))) - -(proto:print-text-format test3) -(proto:print-text-format (proto:deserialize-object 'proto-test3 tser3)) -(let ((text (with-output-to-string (s) - (proto:print-text-format test3 'proto-test3 :stream s)))) - (with-input-from-string (s text) - (proto:parse-text-format 'proto-test3 :stream s))) - -(proto:print-text-format test4) -(proto:print-text-format (proto:deserialize-object 'proto-test4 tser4)) -(let ((text (with-output-to-string (s) - (proto:print-text-format test4 'proto-test4 :stream s)))) - (with-input-from-string (s text) - (proto:parse-text-format 'proto-test4 :stream s))) - -(proto:print-text-format test5) -(proto:print-text-format (proto:deserialize-object 'proto-test5 tser5)) -(let ((text (with-output-to-string (s) - (proto:print-text-format test5 'proto-test5 :stream s)))) - (with-input-from-string (s text) - (proto:parse-text-format 'proto-test5 :stream s))) - -(proto:print-text-format test6) -(proto:print-text-format (proto:deserialize-object 'proto-test6 tser6)) -(let ((text (with-output-to-string (s) - (proto:print-text-format test6 'proto-test6 :stream s)))) - (with-input-from-string (s text) - (proto:parse-text-format 'proto-test6 :stream s))) -||# - -#|| -(let* ((enums (list (make-instance 'proto:protobuf-enum - :name "ColorName" - :values (list (make-instance 'proto:protobuf-enum-value - :name "RED" - :index 1 - :value :red) - (make-instance 'proto:protobuf-enum-value - :name "GREEN" - :index 2 - :value :green) - (make-instance 'proto:protobuf-enum-value - :name "BLUE" - :index 3 - :value :blue))))) - (msgs (list (make-instance 'proto:protobuf-message - :name "Color" - :enums (list (make-instance 'proto:protobuf-enum - :name "ContrastName" - :values (list (make-instance 'proto:protobuf-enum-value - :name "LOW" - :index 1 - :value :high) - (make-instance 'proto:protobuf-enum-value - :name "HIGH" - :index 100 - :value :low)))) - :fields (list (make-instance 'proto:protobuf-field - :name "color" - :type "ColorName" - :required :required - :index 1) - (make-instance 'proto:protobuf-field - :name "contrast" - :type "ContrastName" - :required :optional - :index 2 - :default "LOW"))))) - (methods (list (make-instance 'proto:protobuf-method - :name "GetColor" - :input-name "string" - :output-name "Color") - (make-instance 'proto:protobuf-method - :name "SetColor" - :input-name "Color" - :output-name "Color" - :options (list (make-instance 'proto:protobuf-option - :name "deadline" :value 1.0))))) - (svcs (list (make-instance 'proto:protobuf-service - :name "ColorWheel" - :methods methods))) - (proto (make-instance 'proto:protobuf - :package "ita.color" - :imports '("descriptor.proto") - :enums enums - :messages msgs - :services svcs))) - ;; The output should be example the same as the output of 'write-schema' below - (proto:write-schema proto)) -||# - -#|| -(proto:define-schema color-wheel - (:package ita.color - :import "descriptor.proto" - :documentation "Color wheel example") - (proto:define-enum color-name - (:documentation "A color name") - red - green - blue) - (proto:define-message color - (:conc-name color- - :documentation "Color and contrast") - (proto:define-enum contrast-name - (:documentation "A contrast name") - (low 1) - (high 100)) - (color :type color-name) - (contrast :type (or null contrast-name) :default :low)) - (proto:define-service color-wheel - (:documentation "Get and set colors") - (get-color (string color)) - (set-color (color color) - :options ("deadline" 1.0)))) - -=> (PROGN - (DEFTYPE COLOR-NAME () '(MEMBER :RED :GREEN :BLUE)) - (DEFTYPE CONTRAST-NAME () '(MEMBER :LOW :HIGH)) - (DEFCLASS COLOR () - ((COLOR :TYPE COLOR-NAME :ACCESSOR COLOR-COLOR :INITARG :COLOR) - (CONTRAST :TYPE (OR NULL CONTRAST-NAME) :ACCESSOR COLOR-CONTRAST :INITARG :CONTRAST :INITFORM :LOW))) - (DEFVAR *COLOR-WHEEL* - (MAKE-INSTANCE 'PROTOBUF-SCHEMA - :NAME "ColorWheel" - :CLASS 'COLOR-WHEEL - :PACKAGE "ita.color" - :IMPORTS '("descriptor.proto") - :SYNTAX "proto2" - :OPTIONS () - :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM - :NAME "ColorName" - :CLASS 'COLOR-NAME - :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE - :NAME "RED" :INDEX 1 :VALUE :RED) - (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE - :NAME "GREEN" :INDEX 2 :VALUE :GREEN) - (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE - :NAME "BLUE" :INDEX 3 :VALUE :BLUE)))) - :MESSAGES (LIST (MAKE-INSTANCE 'PROTOBUF-MESSAGE - :NAME "Color" - :CLASS 'COLOR - :CONC-NAME "COLOR-" - :ENUMS (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM - :NAME "ContrastName" - :CLASS 'CONTRAST-NAME - :VALUES (LIST (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE - :NAME "LOW" :INDEX 1 :VALUE :LOW) - (MAKE-INSTANCE 'PROTOBUF-ENUM-VALUE - :NAME "HIGH" :INDEX 100 :VALUE :HIGH)))) - :MESSAGES (LIST) - :FIELDS (LIST (MAKE-INSTANCE 'PROTOBUF-FIELD - :NAME "color" - :TYPE "ColorName" - :CLASS 'COLOR-NAME - :REQUIRED :REQUIRED - :INDEX 1 - :VALUE 'COLOR - :DEFAULT NIL - :PACKED NIL) - (MAKE-INSTANCE 'PROTOBUF-FIELD - :NAME "contrast" - :TYPE "ContrastName" - :CLASS 'CONTRAST-NAME - :REQUIRED :OPTIONAL - :INDEX 2 - :VALUE 'CONTRAST - :DEFAULT "LOW" - :PACKED NIL)))) - :SERVICES (LIST (MAKE-INSTANCE 'PROTOBUF-SERVICE - :NAME "ColorWheel" - :CLASS 'COLOR-WHEEL - :METHODS (LIST (MAKE-INSTANCE 'PROTOBUF-METHOD - :NAME "GetColor" - :CLASS 'GET-COLOR - :INPUT-NAME "string" - :OUTPUT-NAME "Color" - :OPTIONS (LIST)) - (MAKE-INSTANCE 'PROTOBUF-METHOD - :NAME "SetColor" - :CLASS 'SET-COLOR - :INPUT-NAME "Color" - :OUTPUT-NAME "Color" - :OPTIONS (LIST (MAKE-INSTANCE 'PROTOBUF-OPTION - :NAME "deadline" :VALUE "1.0"))))))))) - -;; The output should be example the same as the output of 'write-schema' above -(proto:write-schema *color-wheel*) - -;; How does the Lisp version look? -(proto:write-schema *color-wheel* :type :lisp) - -(setq clr (make-instance 'color :color :red)) -(setq cser (proto:serialize-object-to-stream clr 'color :stream nil)) -(proto:print-text-format clr) -(proto:print-text-format (proto:deserialize-object 'color cser)) -||# - -#|| -(let ((ps "package ita.color; - -import \"descriptor.proto\"; - -enum ColorName { - RED = 1; - GREEN = 2; - BLUE = 3; -} - -message Color { - enum ContrastName { - LOW = 1; - HIGH = 100; - } - required ColorName color = 1; - optional ContrastName contrast = 2 [default = LOW]; -} - -service ColorWheel { - rpc GetColor (string) returns (Color); - rpc SetColor (Color) returns (Color) { - option deadline = 1.0; - } -}")) - (with-input-from-string (s ps) - (setq ppp (proto:parse-schema-from-stream s)))) - -(proto:write-schema ppp) -(proto:write-schema ppp :type :lisp) -||# #|| +;; Lisp lists :-) (proto:define-schema typed-list () (proto:define-message typed-list () (string-car :type (or null string) :reader string-car) @@ -558,41 +149,9 @@ service ColorWheel { (proto:parse-text-format 'typed-list :stream s)))) ||# -#|| -(proto:define-schema integrity-test () - (proto:define-message inner () - (i :type (or null integer))) - (proto:define-message outer () - (inner :type (proto:list-of inner)) - (simple :type (or null inner)) - (i :type (or null integer)))) - -(defun integrity-test (message) - (let* ((type (type-of message)) - (buf (proto:serialize-object-to-stream message type :stream nil)) - (new (proto:deserialize-object type buf)) - (newbuf (proto:serialize-object-to-stream new type :stream nil))) - (assert (equalp (length buf) (length newbuf))) - (assert (equalp buf newbuf)) - (assert (string= (with-output-to-string (s) - (proto:print-text-format message nil :stream s)) - (with-output-to-string (s) - (proto:print-text-format new nil :stream s)))) - new)) - -(integrity-test (make-instance 'outer :i 4)) - -(integrity-test (make-instance 'outer - :inner (mapcar #'(lambda (i) (make-instance 'inner :i i)) '(1 2 3)))) - -(integrity-test (make-instance 'outer - :simple (make-instance 'inner :i 4))) -||# - - -;;; Stubby examples #|| +;; Extension example (proto:define-schema color-wheel (:package color-wheel :optimize :speed @@ -628,83 +187,33 @@ service ColorWheel { (proto:write-schema *color-wheel*) (proto:write-schema *color-wheel* :type :lisp) -(progn ;with-rpc-channel (rpc) - (let* ((wheel (make-instance 'color-wheel :name "Colors")) - (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100)) - (rqst1 (make-instance 'add-color-request :wheel wheel :color color1)) - (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100)) - (rqst2 (make-instance 'add-color-request :wheel wheel :color color2))) - (setf (color-opacity color2) 50) - #-ignore (progn - (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity)) - (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil))) - (print ser1) - (proto:print-text-format rqst1) - (proto:print-text-format (proto:deserialize-object 'add-color-request ser1)))) - #-ignore (progn - (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity)) - (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color-request :stream nil))) - (print ser2) - (proto:print-text-format rqst2) - (proto:print-text-format (proto:deserialize-object 'add-color-request ser2)))) - #+stubby (add-color request) - #+ignore (add-color request))) +(let* ((wheel (make-instance 'color-wheel :name "Colors")) + (color1 (make-instance 'color :r-value 100 :g-value 0 :b-value 100)) + (rqst1 (make-instance 'add-color-request :wheel wheel :color color1)) + (color2 (make-instance 'color :r-value 100 :g-value 0 :b-value 100)) + (rqst2 (make-instance 'add-color-request :wheel wheel :color color2))) + (setf (color-opacity color2) 50) + (progn + (format t "~2&Unextended (has-extension ~S)~%" (has-extension color1 'opacity)) + (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color-request :stream nil))) + (print ser1) + (proto:print-text-format rqst1) + (proto:print-text-format (proto:deserialize-object 'add-color-request ser1)))) + (progn + (format t "~2&Extended (has-extension ~S)~%" (has-extension color2 'opacity)) + (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color-request :stream nil))) + (print ser2) + (proto:print-text-format rqst2) + (proto:print-text-format (proto:deserialize-object 'add-color-request ser2))))) ||# -#|| -(let ((ps "syntax = \"proto2\"; - -package color_wheel; - -option optimize_for = SPEED; - -message ColorWheel { - required string name = 1; - repeated Color colors = 2; - optional group Metadata = 3 { - optional string author = 1; - optional string revision = 2; - optional string date = 3; - } -} - -message Color { - optional string name = 1; - required int64 r_value = 2; - required int64 g_value = 3; - required int64 b_value = 4; - extensions 1000 to max; -} - -extend Color { - optional int64 opacity = 1000; -} - -message GetColorRequest { - required ColorWheel wheel = 1; - required string name = 2; -} - -message AddColorRequest { - required ColorWheel wheel = 1; - required Color color = 2; -} - -service ColorWheel { - rpc GetColor (GetColorRequest) returns (Color) { - option deadline = 1.0; - } - rpc AddColor (AddColorRequest) returns (Color) { - option deadline = 1.0; - } -}")) - (with-input-from-string (s ps) - (setq cw (proto:parse-schema-from-stream s)))) +#|| +;; Group example (proto:define-schema color-wheel1 (:package color-wheel ;; :optimize :speed - :documentation "Color wheel example, with nested") + :documentation "Color wheel example, with nested message") (proto:define-message color-wheel1 () (proto:define-message metadata1 () (author :type (or null string)) @@ -747,25 +256,24 @@ service ColorWheel { (proto:write-schema *color-wheel1*) (proto:write-schema *color-wheel2*) -(progn ;with-rpc-channel (rpc) - (let* ((meta1 (make-instance 'metadata1 :revision "1.0")) - (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1)) - (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100)) - (rqst1 (make-instance 'add-color1 :wheel wheel1 :color color1)) - (meta2 (make-instance 'metadata2 :revision "1.0")) - (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2)) - (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100)) - (rqst2 (make-instance 'add-color2 :wheel wheel2 :color color2))) - #-ignore (progn - (format t "~2&Nested") - (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color1 :stream nil))) - (print ser1) - (proto:print-text-format rqst1) - (proto:print-text-format (proto:deserialize-object 'add-color1 ser1)))) - #-ignore (progn - (format t "~2&Group") - (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color2 :stream nil))) - (print ser2) - (proto:print-text-format rqst2) - (proto:print-text-format (proto:deserialize-object 'add-color2 ser2)))))) +(let* ((meta1 (make-instance 'metadata1 :revision "1.0")) + (wheel1 (make-instance 'color-wheel1 :name "Colors" :metadata1 meta1)) + (color1 (make-instance 'color1 :r-value 100 :g-value 0 :b-value 100)) + (rqst1 (make-instance 'add-color1 :wheel wheel1 :color color1)) + (meta2 (make-instance 'metadata2 :revision "1.0")) + (wheel2 (make-instance 'color-wheel2 :name "Colors" :metadata2 meta2)) + (color2 (make-instance 'color2 :r-value 100 :g-value 0 :b-value 100)) + (rqst2 (make-instance 'add-color2 :wheel wheel2 :color color2))) + (progn + (format t "~2&Nested") + (let ((ser1 (proto:serialize-object-to-stream rqst1 'add-color1 :stream nil))) + (print ser1) + (proto:print-text-format rqst1) + (proto:print-text-format (proto:deserialize-object 'add-color1 ser1)))) + (progn + (format t "~2&Group") + (let ((ser2 (proto:serialize-object-to-stream rqst2 'add-color2 :stream nil))) + (print ser2) + (proto:print-text-format rqst2) + (proto:print-text-format (proto:deserialize-object 'add-color2 ser2))))) ||# diff --git a/model-classes.lisp b/model-classes.lisp index 4b8bb23..308a725 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -231,6 +231,25 @@ (and option (values (proto-value option) (proto-type option))))) +(defgeneric remove-option (protobuf names) + (:documentation + "Given a protobuf schema, message, enum, etc and a set of option names, + remove all of those options from the set of options.")) + +(defmethod remove-options ((protobuf base-protobuf) &rest names) + (dolist (name names) + (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=))) + (when option + ;; This side-effects 'proto-options' + (setf (proto-options protobuf) (remove option (proto-options protobuf))))))) + +(defmethod remove-options ((options list) &rest names) + (dolist (name names) + (let ((option (find name options :key #'proto-name :test #'option-name=))) + (when option + ;; This does not side-effect the list of options + (remove option options))))) + (defun option-name= (name1 name2) (let* ((name1 (string name1)) (name2 (string name2)) diff --git a/parser.lisp b/parser.lisp index b434e73..d01e88b 100644 --- a/parser.lisp +++ b/parser.lisp @@ -240,12 +240,15 @@ (let ((token (parse-token stream '(#\- #\+ #\.)))) (when token (skip-whitespace stream) - (cond ((starts-with token "0x") - (parse-integer (subseq token 2) :radix 16)) - ((starts-with token "-0x") - (- (parse-integer (subseq token 3) :radix 16))) - (t - (read-from-string token))))))) + (parse-numeric-string token))))) + +(defun parse-numeric-string (string) + (cond ((starts-with string "0x") + (parse-integer (subseq string 2) :radix 16)) + ((starts-with string "-0x") + (- (parse-integer (subseq string 3) :radix 16))) + (t + (read-from-string string)))) ;;; The parser itself @@ -278,6 +281,7 @@ (maybe-skip-comments stream) (let ((char (peek-char nil stream nil))) (cond ((null char) + (remove-options schema "lisp_package") (return-from parse-schema-from-stream schema)) ((proto-token-char-p char) (let ((token (parse-token stream))) @@ -356,7 +360,7 @@ (parse-string stream)) ((or (digit-char-p ch) (member ch '(#\- #\+ #\.))) (parse-number stream)) - (t (parse-token stream)))) + (t (kintern (parse-token stream))))) (setq terminator (expect-char stream terminators () "option")) (maybe-skip-comments stream))) (option (make-instance 'protobuf-option @@ -530,7 +534,7 @@ :default default :packed (and packed (boolean-true-p packed)) :message-type (proto-message-type message) - :options opts))) + :options (remove-options opts "default" "packed")))) (when extended-from (assert (index-within-extensions-p idx extended-from) () "The index ~D is not in range for extending ~S" diff --git a/proto-pkgdcl.lisp b/pkgdcl.lisp similarity index 95% rename from proto-pkgdcl.lisp rename to pkgdcl.lisp index db81b81..cc624cd 100644 --- a/proto-pkgdcl.lisp +++ b/pkgdcl.lisp @@ -11,7 +11,7 @@ (in-package "CL-USER") -;;; Package declaration for Protoubfs +;;; Package declaration for Protobufs (defpackage protobufs (:nicknames :proto) @@ -166,6 +166,7 @@ "FIND-ENUM" "FIND-FIELD" "FIND-OPTION" + "REMOVE-OPTIONS" ;; Printing "WRITE-SCHEMA-AS" @@ -187,12 +188,15 @@ "SERIALIZE-PRIM" "SERIALIZE-PACKED" "SERIALIZE-ENUM" + "SERIALIZE-PACKED-ENUM" "DESERIALIZE-PRIM" "DESERIALIZE-PACKED" "DESERIALIZE-ENUM" + "DESERIALIZE-PACKED-ENUM" "PRIM-SIZE" "PACKED-SIZE" "ENUM-SIZE" + "PACKED-ENUM-SIZE" "GENERATE-SERIALIZER" "GENERATE-DESERIALIZER" "GENERATE-OBJECT-SIZE" @@ -209,6 +213,8 @@ "ENCODE-UINT64" "ENCODE-FIXED32" "ENCODE-FIXED64" + "ENCODE-SFIXED32" + "ENCODE-SFIXED64" "ENCODE-SINGLE" "ENCODE-DOUBLE" "ENCODE-STRING" @@ -221,6 +227,8 @@ "DECODE-INT64" "DECODE-FIXED32" "DECODE-FIXED64" + "DECODE-SFIXED32" + "DECODE-SFIXED64" "DECODE-SINGLE" "DECODE-DOUBLE" "DECODE-STRING" diff --git a/printer.lisp b/printer.lisp index 5869c56..8021adb 100644 --- a/printer.lisp +++ b/printer.lisp @@ -94,7 +94,7 @@ (defun cl-user::protobuf-option (stream option colon-p atsign-p) (let ((type (or (second (find (proto-name option) *option-types* :key #'first :test #'string=)) - 'string))) + (proto-type option)))) (cond (colon-p ;~:/protobuf-option/ -- .proto format (let ((fmt-control (cond ((find (proto-name option) *lisp-options* :key #'first :test #'string=) @@ -103,9 +103,11 @@ (if (eq type 'symbol) "~A~@[ = ~A~]" "~A~@[ = ~S~]"))))) (format stream fmt-control (proto-name option) (proto-value option)))) (atsign-p ;~@/protobuf-option/ -- .lisp format - (format stream "~S ~S" (proto-name option) (proto-value option))) + (let ((fmt-control (if (eq type 'symbol) "~(~S~) ~A" "~(~S~) ~S"))) + (format stream fmt-control (proto-name option) (proto-value option)))) (t ;~/protobuf-option/ -- keyword/value format - (format stream "~(:~A~) ~S" (proto-name option) (proto-value option)))))) + (let ((fmt-control (if (eq type 'symbol) "~(:~A~) ~A" "~(:~A~) ~S"))) + (format stream fmt-control (proto-name option) (proto-value option))))))) (defmethod write-schema-as ((type (eql :proto)) (enum protobuf-enum) stream &key (indentation 0) more) @@ -204,20 +206,18 @@ (defmethod write-schema-as ((type (eql :proto)) (field protobuf-field) stream &key (indentation 0) more message) (declare (ignore more)) - (with-prefixed-accessors (name documentation required type index packed) (proto- field) + (with-prefixed-accessors (name documentation required type index packed options) (proto- field) (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field))) (msg (and (not (keywordp class)) - (or (find-message message class) (find-enum message class)))) - (options (remove-if #'(lambda (x) (or (string= (proto-name x) "default") - (string= (proto-name x) "packed"))) - (proto-options field)))) + (or (find-message message class) (find-enum message class))))) (cond ((and (typep msg 'protobuf-message) (eq (proto-message-type msg) :group)) (format stream "~&~@[~VT~]~(~A~) " (and (not (zerop indentation)) indentation) required) (write-schema-as :proto msg stream :indentation indentation :index index :arity required)) ((typep msg 'protobuf-enum) - (let ((default (let ((e (find (proto-default field) (proto-values msg) :key #'proto-name :test #'string=))) + (let ((default (let ((e (find (proto-default field) (proto-values msg) + :key #'proto-name :test #'string=))) (and e (proto-name e))))) (format stream "~&~@[~VT~]~(~A~) ~A ~A = ~D~ ~@[ [default = ~A]~]~@[ [packed = true]~*~]~{ [~:/protobuf-option/]~};~ @@ -503,7 +503,7 @@ (defparameter *protobuf-slot-comment-column* 56) (defmethod write-schema-as ((type (eql :lisp)) (field protobuf-field) stream &key (indentation 0) more message) - (with-prefixed-accessors (value reader writer required index packed documentation) (proto- field) + (with-prefixed-accessors (value reader writer required index packed options documentation) (proto- field) (let* ((class (if (eq (proto-class field) 'boolean) :bool (proto-class field))) (msg (and (not (keywordp class)) (or (find-message message class) (find-enum message class)))) @@ -529,10 +529,7 @@ `(or null ,cl)) ((eq required :repeated) `(list-of ,cl)) - (t cl)))) - (options (remove-if #'(lambda (x) (or (string= (proto-name x) "default") - (string= (proto-name x) "packed"))) - (proto-options field)))) + (t cl))))) (cond ((and (typep msg 'protobuf-message) (eq (proto-message-type msg) :group)) (write-schema-as :lisp msg stream :indentation indentation :index index :arity required)) @@ -541,7 +538,8 @@ (defaultp (not (null default))) (default (cond ((and (typep msg 'protobuf-enum) (stringp default)) - (let ((e (find default (proto-values msg) :key #'proto-name :test #'string=))) + (let ((e (find default (proto-values msg) + :key #'proto-name :test #'string=))) (and e (proto-value e)))) ((and (eq class :bool) defaultp) (boolean-true-p default)) diff --git a/protobufs.asd b/protobufs.asd index 898e54e..56f17e0 100644 --- a/protobufs.asd +++ b/protobufs.asd @@ -11,11 +11,10 @@ (in-package "CL-USER") -(defsystem :protobufs +(asdf:defsystem :protobufs :name "Protobufs" :author "Scott McKay" - :version "0.1" - :maintainer '("Scott McKay") + :version "1.0" :licence " ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; @@ -26,30 +25,54 @@ ;;; Original author: Scott McKay ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;" + :maintainer '("Scott McKay") :description "Protobufs for Common Lisp" :long-description "Protobufs for Common Lisp" - :depends-on (:cl-ppcre - :closer-mop - :split-sequence - :drakma - :cl-unicode) + :depends-on (:cl-ppcre :closer-mop :split-sequence :drakma :cl-unicode) :serial t :components - ((:module "protobufs" + ((:module "packages" + :serial t + :pathname #p"" + :components + ((:file "pkgdcl"))) + (:module "models" + :serial t + :pathname #p"" + :depends-on ("packages") + :components + ((:file "utilities") + (:file "model-classes"))) + (:module "parsing" + :serial t + :pathname #p"" + :depends-on ("models") + :components + ((:file "printer") + (:file "parser"))) + (:module "schema" + :serial t + :pathname #p"" + :depends-on ("models") + :components + ((:file "define-proto") + (:file "upgradable") + (:file "clos-transform"))) + (:module "serialization" + :serial t + :pathname #p"" + :depends-on ("models") + :components + ((:file "text-format") + (:file "wire-format") + (:file "serialize"))) + (:module "misc" :serial t - :components ((:file "proto-pkgdcl") - (:file "utilities") - (:file "model-classes") - (:file "printer") - (:file "parser") - (:file "define-proto") - (:file "upgradable") - (:file "clos-transform") - (:file "wire-format") - (:file "text-format") - (:file "serialize") - (:file "api") - (:file "asdf-support") - (:file "examples"))))) + :pathname #p"" + :depends-on ("models" "parsing" "schema" "serialization") + :components + ((:file "api") + (:file "asdf-support") + (:file "examples"))))) diff --git a/upgradable.lisp b/upgradable.lisp index f6d3c37..6c733d6 100644 --- a/upgradable.lisp +++ b/upgradable.lisp @@ -191,8 +191,11 @@ ;; These methods are pretty similar to the 'schema-upgradable' methods above (defmethod schemas-equal ((schema1 protobuf-schema) (schema2 protobuf-schema)) (and - (eql (proto-class schema1) (proto-class schema2)) - (equalp (proto-name schema1) (proto-name schema2)) + ;; If the name(s) are null, don't worry about them + (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)) diff --git a/wire-format.lisp b/wire-format.lisp index c000057..fe212fd 100644 --- a/wire-format.lisp +++ b/wire-format.lisp @@ -1024,8 +1024,8 @@ do (setq val (ilogior val (iash byte places)))) (values val index))) -(defun decode-sfixed32 (buffer index) - "Decodes the next 32-bit signed fixed integer in the buffer at the given index. +(defun decode-fixed64 (buffer index) + "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index. Returns both the decoded value and the new index into the buffer. Watch out, this function turns off all type checking and array bounds checking." (declare (optimize (speed 3) (safety 0) (debug 0))) @@ -1033,17 +1033,14 @@ (type fixnum index)) ;; Eight bits at a time, least significant bits first (let ((val 0)) - (declare (type fixnum val)) - (loop repeat 4 + (loop repeat 8 for places fixnum upfrom 0 by 8 for byte fixnum = (prog1 (aref buffer index) (iincf index)) - do (setq val (ilogior val (iash byte places)))) - (when (i= (ldb (byte 1 31) val) 1) ;sign bit set, so negative value - (decf val #.(ash 1 32))) + do (setq val (logior val (ash byte places)))) (values val index))) -(defun decode-fixed64 (buffer index) - "Decodes the next unsigned 64-bit fixed integer in the buffer at the given index. +(defun decode-sfixed32 (buffer index) + "Decodes the next 32-bit signed fixed integer in the buffer at the given index. Returns both the decoded value and the new index into the buffer. Watch out, this function turns off all type checking and array bounds checking." (declare (optimize (speed 3) (safety 0) (debug 0))) @@ -1051,10 +1048,13 @@ (type fixnum index)) ;; Eight bits at a time, least significant bits first (let ((val 0)) - (loop repeat 8 + (declare (type fixnum val)) + (loop repeat 4 for places fixnum upfrom 0 by 8 for byte fixnum = (prog1 (aref buffer index) (iincf index)) - do (setq val (logior val (ash byte places)))) + do (setq val (ilogior val (iash byte places)))) + (when (i= (ldb (byte 1 31) val) 1) ;sign bit set, so negative value + (decf val #.(ash 1 32))) (values val index))) (defun decode-sfixed64 (buffer index) -- 2.45.2