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

diff --git a/define-proto.lisp b/define-proto.lisp
index ff78c5a514e63c489f2ee5497eb9a69b39098880..79918e06809d445cde107775437bc6f9643b1df7 100644 (file)
--- 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 e871b4cdfc6e32c28e32c5dec608615a65c5ec81..be000e3044f7b2386f1c65e8f6ce24ec9afa483c 100644 (file)
--- 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 ed1505e2016b8e61d6a2ffbe1816207ac78fa98e..e207606a2ff152ed55b42d2ad3d97901f72e737b 100644 (file)
--- 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 48b192f8414f16ec2fe4d2a7cd1890b0e933a665..62e904332f801e292ce678d033a44bf6e67f7919 100644 (file)
--- 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 '(#\-)))