;;; ;;;
;;; Free Software published under an MIT-like license. See LICENSE ;;;
;;; ;;;
-;;; Copyright (c) 2012 Google, Inc. All rights reserved. ;;;
+;;; Copyright (c) 2012-2013 Google, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Scott McKay ;;;
;;; ;;;
;;; Protocol buffers model classes
(defvar *all-schemas* (make-hash-table :test #'equal)
- "A table mapping names to 'protobuf-schema' objects.")
+ "A global table mapping names to 'protobuf-schema' objects.")
(defgeneric find-schema (name)
(:documentation
"Given a name (a symbol or string), return the 'protobuf-schema' object having that name."))
(defmethod find-schema ((name symbol))
- (values (gethash (keywordify name) *all-schemas*)))
-
-(defmethod find-schema ((name string))
- (values (gethash (string-upcase name) *all-schemas*)))
+ (assert (not (keywordp name)))
+ (values (gethash name *all-schemas*)))
(defmethod find-schema ((path pathname))
"Given a pathname, return the 'protobuf-schema' object that came from that path."
- (values (gethash (make-pathname :type nil :defaults path) *all-schemas*)))
+ (values (gethash path *all-schemas*)))
(defvar *all-messages* (make-hash-table :test #'equal)
- "A table mapping Lisp class names to 'protobuf-message' objects.")
+ "A global table mapping Lisp class names to 'protobuf-message' objects.")
(defgeneric find-message-for-class (class)
(:documentation
(values (gethash (class-name class) *all-messages*)))
-;; A few things (the pretty printer) want to keep track of the current schema
+;;; "Thread-local" variables
+
+;; Parsing (and even pretty printing schemas) want to keep track of the current schema
(defvar *protobuf* nil
- "The Protobufs object currently being defined, either a schema or a message.")
+ "Bound to 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.")
+ "Bound to the Lisp package in which the Protobufs schema is being defined.")
+
+(defvar *protobuf-rpc-package* nil
+ "Bound to the Lisp package in which the Protobufs schema's service definitions are being defined.")
(defvar *protobuf-conc-name* nil
- "A global conc-name to use for all the messages in this schema. This controls
- the name of the accessors the fields of each message.
- When it's nil, there is no global conc-name.
+ "Bound to a conc-name to use for all the messages in the schema being defined.
+ This controls the name of the accessors the fields of each message.
+ When it's nil, there is no \"global\" conc-name.
When it's t, each message will use the message name as the conc-name.
When it's a string, that string will be used as the conc-name for each message.
'parse-schema-from-file' defaults conc-name to \"\", meaning that each field in
every message has an accessor whose name is the name of the field.")
(defvar *protobuf-pathname* nil
- "The name of the file from where the .proto file is being parsed.")
+ "Bound to he name of the file from where the .proto file is being parsed.")
(defvar *protobuf-search-path* ()
- "A search-path to use to resolve any relative pathnames.")
+ "Bound to the search-path to use to resolve any relative pathnames.")
(defvar *protobuf-output-path* ()
- "A path to use to direct output during imports, etc.")
+ "Bound to the path to use to direct output during imports, etc.")
;;; The model classes
(defclass abstract-protobuf () ())
+;; It would be nice if most of the slots had only reader functions, but
+;; that makes writing the Protobufs parser a good deal more complicated.
+;; Too bad Common Lisp exports '(setf foo)' when you only want to export 'foo'
(defclass base-protobuf (abstract-protobuf)
((class :type (or null symbol) ;the Lisp name for this object
:accessor proto-class ;this often names a type or class
"The model class that represents a Protobufs schema, i.e., one .proto file."))
(defmethod make-load-form ((s protobuf-schema) &optional environment)
- (with-slots (class name) s
+ (with-slots (class) s
(multiple-value-bind (constructor initializer)
(make-load-form-saving-slots s :environment environment)
(values `(let ((s ,constructor))
- (record-protobuf s ',class ',name nil)
+ (record-protobuf s ',class nil)
s)
initializer))))
-(defgeneric record-protobuf (schema &optional symbol name type)
+(defgeneric record-protobuf (schema &optional symbol type)
(:documentation
"Record all the names by which the Protobufs schema might be known.")
- (:method ((schema protobuf-schema) &optional symbol name type)
+ (:method ((schema protobuf-schema) &optional symbol type)
(declare (ignore type))
- (let ((symbol (or symbol (proto-class schema)))
- (name (or name (proto-name schema))))
+ (let ((symbol (or symbol (proto-class schema))))
(when symbol
- (setf (gethash (keywordify symbol) *all-schemas*) schema))
- (when name
- (setf (gethash (string-upcase name) *all-schemas*) schema))
- (let ((path (or *protobuf-pathname* *compile-file-pathname*)))
- (when path
- ;; Record the file from which the Protobufs schema came, sans file type
- (setf (gethash (make-pathname :type nil :defaults path) *all-schemas*) schema))))))
+ (setf (gethash symbol *all-schemas*) schema))
+ (when *protobuf-pathname*
+ ;; Record the file from which the Protobufs schema came
+ (setf (gethash *protobuf-pathname* *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))))
+
+(defun make-option (name value &optional (type 'string))
+ (check-type name string)
+ (make-instance 'protobuf-option
+ :name name :value value :type type))
(defgeneric find-option (protobuf name)
(:documentation
(values (proto-value option) (proto-type option) t)
(values nil nil nil))))
+(defgeneric add-option (protobuf name value &optional type)
+ (:documentation
+ "Given a Protobufs schema, message, enum, etc
+ add the option called 'name' with the value 'value' and type 'type'.
+ If the option was previoously present, it is replaced."))
+
+(defmethod add-option ((protobuf base-protobuf) (name string) value &optional (type 'string))
+ (let ((option (find name (proto-options protobuf) :key #'proto-name :test #'option-name=)))
+ (if option
+ ;; This side-effects the old option
+ (setf (proto-value option) value
+ (proto-type option) type)
+ ;; This side-effects 'proto-options'
+ (setf (proto-options protobuf)
+ (append (proto-options protobuf)
+ (list (make-option name value type)))))))
+
+(defmethod add-option ((options list) (name string) value &optional (type 'string))
+ (let ((option (find name options :key #'proto-name :test #'option-name=)))
+ (append (remove option options)
+ (list (make-option name value type)))))
+
(defgeneric remove-options (protobuf &rest names)
(:documentation
"Given a Protobufs schema, message, enum, etc and a set of option names,
(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
"The model class that represents a Protobufs message."))
(defmethod make-load-form ((m protobuf-message) &optional environment)
- (with-slots (class name message-type) m
+ (with-slots (class message-type) m
(multiple-value-bind (constructor initializer)
(make-load-form-saving-slots m :environment environment)
(values (if (eq message-type :extends)
constructor
`(let ((m ,constructor))
- (record-protobuf m ',class ',name ',message-type)
+ (record-protobuf m ',class ',message-type)
m))
initializer))))
-(defmethod record-protobuf ((message protobuf-message) &optional class name type)
+(defmethod record-protobuf ((message protobuf-message) &optional class type)
;; No need to record an extension, it's already been recorded
(let ((class (or class (proto-class message)))
- (name (or name (proto-name message)))
(type (or type (proto-message-type message))))
(unless (eq type :extends)
(when class
- (setf (gethash class *all-messages*) message))
- (when name
- (setf (gethash name *all-messages*) message)))))
+ (setf (gethash class *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
(defmethod print-object ((e protobuf-extension) stream)
(print-unreadable-object (e stream :type t :identity t)
(format stream "~D - ~D"
- (proto-extension-from e) (proto-extension-from e))))
+ (proto-extension-from e) (proto-extension-to e))))
;; A Protobufs service
(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
:initarg :lisp-type)
(proto-type :reader proto-proto-type ;a .proto type specifier
:initarg :proto-type)
+ (proto-type-str :reader proto-proto-type-str
+ :initarg :proto-type-str)
(serializer :reader proto-serializer ;Lisp -> Protobufs conversion function
:initarg :serializer)
(deserializer :reader proto-deserializer ;Protobufs -> Lisp conversion function
(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
projects / cl-protobufs.git / blobdiff