From 8a1ebcf649c9ba47d518a2a3ffbe7e867582f2b4 Mon Sep 17 00:00:00 2001 From: Scott McKay Date: Mon, 18 Jun 2012 15:00:19 +0000 Subject: [PATCH] Still better support for qualified names: - Add 'make-qualified-name' function that knows how to prepend message and package names. - All the places that create messages, enums, fields, etc, now generate a qualified name. - 'find-qualified-name' now thoroughly checks the qualified name. Passes 'precheckin' with the new Protobufs unit tests in place. git-svn-id: http://svn.internal.itasoftware.com/svn/ita/trunk/qres/lisp/libs/cl-protobufs@549563 f8382938-511b-0410-9cdd-bb47b084005c --- define-proto.lisp | 8 ++++++++ model-classes.lisp | 40 ++++++++++++++++++++++++++++++++++------ parser.lisp | 17 ++++++++++++----- utilities.lisp | 7 ++++++- 4 files changed, 60 insertions(+), 12 deletions(-) diff --git a/define-proto.lisp b/define-proto.lisp index ff78c5a..79918e0 100644 --- a/define-proto.lisp +++ b/define-proto.lisp @@ -130,6 +130,7 @@ (enum (make-instance 'protobuf-enum :class type :name name + :qualified-name (make-qualified-name *protobuf* name) :alias-for alias-for :options options :documentation documentation))) @@ -190,6 +191,7 @@ (message (make-instance 'protobuf-message :class type :name name + :qualified-name (make-qualified-name *protobuf* name) :parent *protobuf* :alias-for alias-for :conc-name conc-name @@ -295,6 +297,7 @@ (make-instance 'protobuf-message :class type :name name + :qualified-name (make-qualified-name *protobuf* name) :parent (proto-parent message) :alias-for alias-for :conc-name conc-name @@ -487,6 +490,7 @@ :name (slot-name->proto slot) :type name :class type + :qualified-name (make-qualified-name *protobuf* (slot-name->proto slot)) :required arity :index index :value slot @@ -495,6 +499,7 @@ (message (make-instance 'protobuf-message :class type :name name + :qualified-name (make-qualified-name *protobuf* name) :alias-for alias-for :conc-name conc-name :options (remove-options options "default" "packed") @@ -608,6 +613,7 @@ :name (or name (slot-name->proto slot)) :type ptype :class pclass + :qualified-name (make-qualified-name *protobuf* (or name (slot-name->proto slot))) ;; One of :required, :optional or :repeated :required reqd :index idx @@ -639,6 +645,7 @@ (service (make-instance 'protobuf-service :class type :name name + :qualified-name (make-qualified-name *protobuf* name) :options options :documentation documentation)) (index 0)) @@ -661,6 +668,7 @@ (method (make-instance 'protobuf-method :class function :name (or name (class-name->proto function)) + :qualified-name (make-qualified-name *protobuf* (or name (class-name->proto function))) :client-stub client-fn :server-stub server-fn :input-type input-type diff --git a/model-classes.lisp b/model-classes.lisp index e871b4c..be000e3 100644 --- a/model-classes.lisp +++ b/model-classes.lisp @@ -48,7 +48,7 @@ ;; A few things (the pretty printer) want to keep track of the current schema (defvar *protobuf* nil - "The Protobufs object currently being defined, e.g., a schema, a message, etc.") + "The Protobufs object currently being defined, either a schema or a message.") (defvar *protobuf-package* nil "The Lisp package in which the Protobufs schema is being defined.") @@ -82,10 +82,10 @@ :reader proto-name :initarg :name :initform nil) - (full-name :type (or null string) ;the fully qualified name, e.g., "proto2.MessageSet" + (qual-name :type string ;the fully qualified name, e.g., "proto2.MessageSet" :accessor proto-qualified-name :initarg :qualified-name - :initform nil) + :initform "") (options :type (list-of protobuf-option) ;options, mostly just passed along :accessor proto-options :initarg :options @@ -98,11 +98,13 @@ "The base class for all Protobufs model classes.")) (defun find-qualified-name (name protos - &key (proto-key #'proto-name) (lisp-key #'proto-class)) + &key (proto-key #'proto-name) (full-key #'proto-qualified-name) + (lisp-key #'proto-class)) "Find something by its string name. First do a simple name match. Failing that, exhaustively search qualified names." (or (find name protos :key proto-key :test #'string=) + (find name protos :key full-key :test #'string=) ;; Get desperate in the face of incomplete namespace support ;;--- This needs to be more sophisticated than just using Lisp packages (multiple-value-bind (name package path other) @@ -127,7 +129,7 @@ :accessor proto-package :initarg :package :initform nil) - (lisp-pkg :type (or null string) ;the Lisp package, from 'option lisp_package = ...' + (lisp-pkg :type (or null string) ;the Lisp package, from 'option lisp_package = ...' :accessor proto-lisp-package :initarg :lisp-package :initform nil) @@ -187,6 +189,16 @@ (format stream "~@[~S~]~@[ (package ~A)~]" (proto-class s) (proto-package s)))) +(defgeneric make-qualified-name (proto name) + (:documentation + "Give a schema or message and a name, + generate a fully qualified name string for the name.")) + +(defmethod make-qualified-name ((schema protobuf-schema) name) + ;; If we're at the parent, the qualified name is the schema's + ;; packaged "dot" the name + (strcat (proto-package schema) "." name)) + (defgeneric find-enum (protobuf type) (:documentation "Given a Protobufs schema or message and the name of an enum type, @@ -409,7 +421,7 @@ :accessor proto-message-type :initarg :message-type :initform :message)) - (:documentation + (:documentation "The model class that represents a Protobufs message.")) (defmethod make-load-form ((m protobuf-message) &optional environment) @@ -441,6 +453,22 @@ (eq (proto-message-type m) :group) (eq (proto-message-type m) :extends)))) +(defmethod proto-package ((message protobuf-message)) + (and (proto-parent message) + (proto-package (proto-parent message)))) + +(defmethod proto-lisp-package ((message protobuf-message)) + (and (proto-parent message) + (proto-lisp-package (proto-parent message)))) + +(defmethod make-qualified-name ((message protobuf-message) name) + ;; If there's a parent for this message (there should be -- the schema), + ;; make a partially qualified name of message name "dot" name, then + ;; ask the parent to add its own qualifiers + (if (proto-parent message) + (make-qualified-name (proto-parent message) (strcat (proto-name message) "." name)) + (strcat (proto-name message) "." name))) + (defmethod find-message ((message protobuf-message) (type symbol)) ;; Extended messages "shadow" non-extended ones (or (find type (proto-extenders message) :key #'proto-class) diff --git a/parser.lisp b/parser.lisp index ed1505e..e207606 100644 --- a/parser.lisp +++ b/parser.lisp @@ -381,7 +381,8 @@ (maybe-skip-comments stream))) (enum (make-instance 'protobuf-enum :class (proto->class-name name *protobuf-package*) - :name name))) + :name name + :qualified-name (make-qualified-name protobuf name)))) (loop (let ((name (parse-token stream))) (when (null name) @@ -425,7 +426,8 @@ (class (proto->class-name name *protobuf-package*)) (message (make-instance 'protobuf-message :class class - :name name + :name name + :qualified-name (make-qualified-name protobuf name) :parent protobuf ;; Maybe force accessors for all slots :conc-name (conc-name-for-type class *protobuf-conc-name*))) @@ -469,8 +471,9 @@ (message (find-message protobuf name)) (extends (and message (make-instance 'protobuf-message - :class (proto->class-name name *protobuf-package*) - :name name + :class (proto->class-name name *protobuf-package*) + :name name + :qualified-name (make-qualified-name protobuf name) :parent (proto-parent message) :conc-name (proto-conc-name message) :alias-for (proto-alias-for message) @@ -529,6 +532,7 @@ :name name :type type :class class + :qualified-name (make-qualified-name message name) ;; One of :required, :optional or :repeated :required reqd :index idx @@ -571,6 +575,7 @@ :name name :type type :class class + :qualified-name (make-qualified-name message name) :required (kintern required) :index idx :value slot @@ -635,7 +640,8 @@ (maybe-skip-comments stream))) (service (make-instance 'protobuf-service :class (proto->class-name name *protobuf-package*) - :name name)) + :name name + :qualified-name (make-qualified-name *protobuf* name))) (index 0)) (loop (let ((token (parse-token stream))) @@ -673,6 +679,7 @@ (method (make-instance 'protobuf-method :class stub :name name + :qualified-name (make-qualified-name *protobuf* name) :input-type (proto->class-name in *protobuf-package*) :input-name in :output-type (proto->class-name out *protobuf-package*) diff --git a/utilities.lisp b/utilities.lisp index 48b192f..62e9043 100644 --- a/utilities.lisp +++ b/utilities.lisp @@ -87,6 +87,11 @@ (string-equal string suffix :start1 (i- end (length suffix)) :end1 end) suffix)) +(defun strcat (&rest strings) + "Concatenate a bunch of strings." + (declare (dynamic-extent strings)) + (apply #'concatenate 'string strings)) + ;; (camel-case "camel-case") => "CamelCase" (defun camel-case (string &optional (separators '(#\-))) @@ -135,7 +140,7 @@ (cons #\. result))) (t (error "Invalid name character: ~A" ch)))))) - (concatenate 'string (nreverse (uncamel (concatenate 'list name) nil ()))))) + (strcat (nreverse (uncamel (concatenate 'list name) nil ()))))) (defun split-string (line &key (start 0) (end (length line)) (separators '(#\-))) -- 2.45.2